Merge branch 'fradrive/localmaster'

messages/uniworx/categories/courses/tutorial/en-eu.msg

@@ -46,8 +46,8 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
 TutorialUserDeregister: Deregister from tutorial
 TutorialUserSendMail: Send mail
 TutorialUserPrintQualification: Print certificate
-TutorialUserGrantQualification: Grant Qualification
+TutorialUserGrantQualification: Grant qualification
-TutorialUserRenewQualification: Renew Qualification
+TutorialUserRenewQualification: Renew qualification
 TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 CommTutorial: Tutorial message

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -86,6 +86,7 @@ QualificationSetUnexpire n@Int64: Benachrichtigung bei anstehender Erneuerung un
 QualificationActBlockSupervisor: Dauerhaft entziehen und Ansprechpartner entfernen, mit sofortiger Wirkung
 QualificationActBlock: Entziehen
 QualificationActUnblock: Entzug löschen
+QualificationActGrant: Qualifikation vergeben
 QualificationActRenew: Qualifikation regulär verlängern
 QualificationStatusBlock   l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} entzogen
 QualificationStatusUnblock l@QualificationShorthand n@Int m@Int: #{n}/#{m} #{l} reaktiviert

messages/uniworx/categories/qualification/en-eu.msg

@@ -65,13 +65,13 @@ CsvColumnLmsDelete: Will the identifier be deleted from the E-learning platfrom
 CsvColumnLmsStaff: Is the user an internal staff member? (Legacy, currently ignored)
 CsvColumnLmsSuccess: Timestamp of successful completion (UTC)
 CsvColumnLmsFailed: Blockier durch LMS, üblicherweise wegen zu vieler Fehlversuche
-LmsUserlistInsert: New LMS User
+LmsUserlistInsert: New LMS user
-LmsUserlistUpdate: Update of LMS User
+LmsUserlistUpdate: Update of LMS user
 LmsResultInsert: New LMS result
 LmsResultUpdate: Update of LMS result
 LmsResultCsvExceptionDuplicatedKey: CSV import with ambiguous key
 LmsUserlistCsvExceptionDuplicatedKey: CSV import with ambiguous key
-LmsDirectUpload: Direct upload for automated Systems
+LmsDirectUpload: Direct upload for automated systems
 LmsErrorNoRefreshElearning: Error: E-learning will not be started automatically due to refresh-within time period not being set.
 MailSubjectQualificationRenewal qname: Qualification #{qname} must be renewed shortly
 MailSubjectQualificationExpiry qname: Qualification #{qname} expires soon
@@ -86,7 +86,8 @@ QualificationSetUnexpire n: Expiry notification and e‑learning activated for #
 QualificationActBlockSupervisor: Waive permanently and remove all supervisiors, effective immediately
 QualificationActBlock: Revoke
 QualificationActUnblock: Clear revocation
-QualificationActRenew: Renew Qualification
+QualificationActGrant: Grant qualification
+QualificationActRenew: Renew qualification
 QualificationStatusBlock   l n m: #{n}/#{m} #{l} revoked
 QualificationStatusUnblock l n m: #{n}/#{m} #{l} reactivated
 LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with the FRADrive PDF-password of the examinee. If no PDF-password had been chosen yet, then the password is the Fraport id card number of the examinee, including the punctuation mark and the digit thereafter.

models/avs.model

@@ -29,5 +29,5 @@ UserAvsCard
   cardNo          AvsFullCardNo  
   card            AvsDataPersonCard
   lastSynch       UTCTime
-  UniqueAvsCard cardNo
+  -- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons
   deriving Generic

src/Handler/Health.hs

@@ -17,6 +17,8 @@ import qualified Data.Set as Set
 
 import Control.Concurrent.STM.Delay
 
+import System.Environment (lookupEnv) -- while git version number is not working
+
 -- import Data.FileEmbed (embedStringFile)
 
 getHealthR :: Handler TypedContent
@@ -107,7 +109,7 @@ getInstanceR = do
 getStatusR :: Handler Html
 getStatusR = do
   starttime <- getsYesod appStartTime
-  currtime <- liftIO getCurrentTime    
+  (currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
   -- ft <- formatTime'  "%Y-%m-%d %H:%M:%S" currtime
   withUrlRenderer 
     [hamlet|
@@ -116,6 +118,9 @@ getStatusR = do
         <head>        
           <title>Status
         <body>
+          $maybe env_ver <- env_version
+            <p>
+              Environment version #{env_ver}
           <p> 
             Current Time <br> 
             #{show currtime} <br>     

src/Handler/LMS.hs

@@ -439,13 +439,13 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
                 E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                 E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
         )        
-      , single ("avs-card"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
+      , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
-              E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do 
+            Nothing -> E.false
+            Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
                 E.on     $ usrAvs E.^. UserAvsPersonId  E.==. avsCard E.^. UserAvsCardPersonId  
-                E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
+                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user    E.^. UserId
-                    E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text)))
+                    E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
-                            `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text))))
+          )
-                )
       , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
           | Set.null criteria -> E.true
           | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria

src/Handler/Qualification.hs

@@ -249,6 +249,7 @@ data QualificationTableAction
   | QualificationActBlock
   | QualificationActUnblock
   | QualificationActRenew
+  | QualificationActGrant
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)  
 
 instance Universe QualificationTableAction
@@ -268,9 +269,10 @@ data QualificationTableActionData
   = QualificationActExpireData 
   | QualificationActUnexpireData  
   | QualificationActBlockSupervisorData
-  | QualificationActBlockData              { qualTableActBlockReason :: Text}
+  | QualificationActBlockData           { qualTableActBlockReason :: Text }
   | QualificationActUnblockData
   | QualificationActRenewData
+  | QualificationActGrantData           { qualTableActGrantUntil  :: Day }   
   deriving (Eq, Ord, Read, Show, Generic)  
 
 isExpiryAct :: QualificationTableActionData -> Bool
@@ -358,17 +360,26 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
                 E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
                     E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
                           (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
-      , single ("avs-card"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
+      , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
-              E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do 
+            Nothing -> E.false
+            Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
                 E.on     $ usrAvs E.^. UserAvsPersonId  E.==. avsCard E.^. UserAvsCardPersonId  
-                E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
+                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user    E.^. UserId
-                    E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text)))
+                    E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
-                            `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text))))
+          )
-                )
       , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
           | Set.null criteria -> E.true
           | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
         )
+      , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
+              E.from $ \(usrComp `E.InnerJoin` comp) -> do 
+                let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
+                                (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
+                    testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
+                    testcrit = maybe testname testnumber $ readMay $ CI.original criterion
+                E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
+                E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
+        )                                  
       , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
       , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
           if | Just renewal <- mbRenewal
@@ -459,9 +470,16 @@ getQualificationR,  postQualificationR :: SchoolId -> QualificationShorthand ->
 getQualificationR = postQualificationR
 postQualificationR sid qsh = do  
   isAdmin <- hasReadAccessTo AdminR  
+  now <- liftIO getCurrentTime
+  let nowaday = utctDay now
   ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
-    qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
+    qent@Entity{entityVal=Qualification{
-    let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
+        qualificationAuditDuration=auditMonths
+      , qualificationValidDuration=validMonths
+      }} <- getBy404 $ SchoolQualificationShort sid qsh
+
+    let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
+        acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
         acts = mconcat $
           [ singletonMap QualificationActExpire   $ pure QualificationActExpireData
           , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData          
@@ -471,6 +489,8 @@ postQualificationR sid qsh = do
           , singletonMap QualificationActBlock           $      QualificationActBlockData 
               <$> apreq textField (fslI MsgQualificationBlockReason) Nothing
           , singletonMap QualificationActRenew           $ pure QualificationActRenewData
+          , singletonMap QualificationActGrant           
+              (QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry)
           ] isAdmin
         linkLmsUser     = toMaybe isAdmin LmsUserR
         linkUserName    = bool ForProfileR                      ForProfileDataR          isAdmin
@@ -511,6 +531,10 @@ postQualificationR sid qsh = do
       noks <- runDB $ renewValidQualificationUsers qid $ Set.toList selectedUsers      
       addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
       reloadKeepGetParams $ QualificationR sid qsh
+    (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do      
+      runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
+      addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
+      reloadKeepGetParams $ QualificationR sid qsh
     (action, selectedUsers) | isExpiryAct action -> do
       let isUnexpire = action == QualificationActUnexpireData
       upd <- runDB $ updateWhereCount
@@ -521,9 +545,7 @@ postQualificationR sid qsh = do
       addMessageI msgKind msgVal
       reloadKeepGetParams $ QualificationR sid qsh
     (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData)  -> do      
-      now <- liftIO getCurrentTime
+      let selUserIds = Set.toList selectedUsers
-      let nowaday = utctDay now 
-          selUserIds = Set.toList selectedUsers
           qubr = case action of 
               QualificationActUnblockData         -> Nothing
               QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday

src/Handler/Tutorial/Users.hs

@@ -66,7 +66,7 @@ postTUsersR tid ssh csh tutn = do
     tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn    
     qualifications <- getCourseQualifications cid
     now <- liftIO getCurrentTime
-    let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications)  -- no instance Ord CalendarDiffDays        
+    let minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications  -- no instance Ord CalendarDiffDays
         dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
         colChoices  = mconcat $ catMaybes
           [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))

src/Handler/Utils/Avs.hs

@@ -339,12 +339,16 @@ guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoT
       _ -> return Nothing
 guessAvsUser someid = do 
   let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard      
-      extractUid     (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
-      extractUidCard (Entity _ UserAvsCard{userAvsCardPersonId=avid}) = getBy $ UniqueUserAvsId avid
   case discernAvsCardPersonalNo someid of    
-    Just cid@(Left cardNo) -> 
+    Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid
-      maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ 
+      -- NOTE: card validity might be outdated, so we must always check with avs
-        maybeM (return Nothing) extractUidCard $ getBy $ UniqueAvsCard cardNo
+      -- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do
+      --   let extractUid     (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
+      --       extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid
+      --   cards <- selectList [UserAvsCardCardNo ==. cardNo] []
+      --   case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of 
+      --     [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard)
+      --     _ -> return Nothing
     Just cid@(Right _wholeNumber) -> 
       maybeUpsertAvsUserByCard cid >>= \case
         Nothing -> 
@@ -493,15 +497,16 @@ upsertAvsUserById api = do
                         [UserPinPassword =. userPin]
             insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
         upsertUserCompany uid mbCompany userFirmAddr
-        forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard
+        forM_ avsPersonPersonCards $ \aCard -> do
+          let fcn = getFullCardNo aCard
+          -- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused
+          deleteWhere [UserAvsCardCardNo ==. fcn]
+          insert_ $ UserAvsCard
             { userAvsCardPersonId  = api
-            , userAvsCardCardNo    = getFullCardNo aCard
+            , userAvsCardCardNo    = fcn
             , userAvsCardCard      = aCard
             , userAvsCardLastSynch = now
             }
-            [ UserAvsCardCard      =. aCard
-            , UserAvsCardLastSynch =. now
-            ]
       return $ Just uid
 
 

src/Handler/Utils/Qualification.hs

@@ -138,3 +138,34 @@ qualificationUserBlocking qid uids qb = do
       , transactionQualificationBlock = qb
       }
   return $ fromIntegral oks
+
+qualificationUserUnblockByReason :: 
+  ( AuthId (HandlerSite m) ~ Key User
+  , IsPersistBackend (YesodPersistBackend (HandlerSite m))
+  , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
+  , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
+  , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
+  , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
+  , HasInstanceID (HandlerSite m) InstanceId
+  , YesodAuthPersist (HandlerSite m)
+  , HasAppSettings (HandlerSite m)
+  , MonadHandler m
+  , MonadCatch m
+  , Num n
+  ) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
+qualificationUserUnblockByReason qid uids reason = do
+  blockedUsers <- selectList [ QualificationUserQualification ==. qid
+                             , QualificationUserBlockedDue !=. Nothing
+                             , QualificationUserUser <-. uids
+                             ] [Asc QualificationUserId]
+  let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers
+  oks <- updateWhereCount  [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
+                           [ QualificationUserBlockedDue =. Nothing ]
+  forM_ toUnblock $ \ubl -> do     
+    audit TransactionQualificationUserBlocking 
+      { -- transactionQualificationUser  = quid
+        transactionQualification      = qid
+      , transactionUser               = ubl ^. _entityVal . _qualificationUserUser
+      , transactionQualificationBlock = Nothing
+      }                           
+  return $ fromIntegral oks

src/Jobs/Handler/LMS.hs

@@ -217,7 +217,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
           return (quser, luser, lresult)
         now <- liftIO getCurrentTime
         let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
-        forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
+        forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
           -- three separate DB operations per result is not so nice. All within one transaction though.
           let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
               saneDate    = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
@@ -226,15 +226,18 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
               -- newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
           note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
             then do
-              _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked remains unaffected
+              _ok <- renewValidQualificationUsers qid [qualificationUserUser] -- ignores possible blocks
               -- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
+              
+              -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
+              -- _ok <- qualificationUserUnblockByReason qid [qualificationUserUser] (qualificationBlockedReasonText QualificationBlockFailedELearning) -- affects audit log
+              when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qualificationUserBlockedDue ^? _Just . _qualificationBlockedReason) $
+                update quid [ QualificationUserBlockedDue =. Nothing ]
+
               update luid 
                 [ LmsUserStatus   =. newStatus
                 , LmsUserReceived =. Just lmsResultTimestamp
                 ]                          
-              -- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
-              -- when (Just (qualificationBlockedReasonText QualificationBlockFailedELearning) == qUsr ^? _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) $
-              --  update quid [ QualificationUserBlockedDue =. Nothing ]              
               return Nothing
             else do
               let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]

src/Utils/Avs.hs

@@ -32,10 +32,10 @@ type AVSGetRampLicences = "RampDrivingLicenceInfo"  :> ReqBody '[JSON] AvsQueryG
 type AVSSetRampLicences = "RampDrivingLicence"      :> ReqBody '[JSON] AvsQuerySetLicences  :> Post '[JSON] AvsResponseSetLicences
 
 avsMaxSetLicenceAtOnce :: Int
-avsMaxSetLicenceAtOnce = 90   -- maximum input set size for avsQuerySetLicences as enforced by AVS
+avsMaxSetLicenceAtOnce = 80   -- maximum input set size for avsQuerySetLicences as enforced by AVS
 
 avsMaxQueryAtOnce :: Int
-avsMaxQueryAtOnce = 900   -- maximum input set size for avsQueryStatus as enforced by AVS
+avsMaxQueryAtOnce = 500       -- maximum input set size for avsQueryStatus as enforced by AVS
 
 
 avsApi :: Proxy AVS
@@ -96,17 +96,18 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
       | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
     catch404toEmpty other = other
 
-    splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c)) 
+splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c)) 
-               => (a -> ClientM c) -> a -> ClientM c
+            => (a -> ClientM c) -> a -> ClientM c
-    splitQuery rawQuery q
+splitQuery rawQuery q
-        | Set.size s <= avsMaxQueryAtOnce = rawQuery q
+    | avsMaxQueryAtOnce >= Set.size s = rawQuery q
-        | otherwise = do
+    | otherwise = do
-            let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
+        $logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s)
-            res1 <-            rawQuery $ view _Unwrapped' avsid1
+        let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
-            res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
+        res1 <-            rawQuery $ view _Unwrapped' avsid1
-            return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
+        res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
-      where 
+        return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
-        s = view _Wrapped' q
+  where 
+    s = view _Wrapped' q
 #endif
 
 -----------------------

src/Utils/Print.hs

@@ -128,7 +128,8 @@ mdTemplating template meta = runExceptT $ do
                        }
   ExceptT . pure . over _Left P.renderError . P.runPure $ do
     md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc    
-    P.readMarkdown readerOpts md_txt
+    addMeta meta <$> P.readMarkdown readerOpts md_txt -- NOTE: meta is lost along the way somehow, despite P.pandocExtensions containing Ext_yaml_metadata_block
+    
 
 
 -- | creates a PDF using a LaTeX template
@@ -136,13 +137,12 @@ pdfLaTeX :: LetterKind -> P.Pandoc -> HandlerFor UniWorX (Either Text LBS.ByteSt
 pdfLaTeX lk doc = do
   -- e_tmpl <- fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk
   e_tmpl <- memcachedBy (Just . Right $ 6 * diffHour) ("LetterKind-latex: \n" <> tshow lk) (fmap (over _Left P.renderError) . liftIO . P.runIO $ compileTemplate $ templateLatex lk)
-  actRight e_tmpl $ \tmpl -> fmap (over _Left P.renderError) .liftIO . P.runIO $ do
+  actRight e_tmpl $ \tmpl -> fmap (over _Left P.renderError) . liftIO . P.runIO $ do
       let writerOpts  = def { P.writerExtensions = P.pandocExtensions
                             , P.writerTemplate   = Just tmpl }      
       makePDF writerOpts $ appMeta setIsDeFromLang doc
       
 
-
 renderLetter :: (MDLetter l) => Entity User -> l -> Text -> Handler (Either Text LBS.ByteString)
 renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
   now <- liftIO getCurrentTime  
@@ -161,7 +161,7 @@ renderLetter rcvrEnt@Entity{entityVal=rcvr} mdl apcIdent = do
             ]
   e_md <- mdTemplating tmpl meta
   actRight e_md $ pdfLaTeX kind
-  -- return $ over _Left P.renderError result
+
 
 -- TODO: apcIdent does not make sense for multiple letters 
 renderLetters :: (MDLetter l, Foldable f) => Entity User -> f l -> Text -> Handler (Either Text LBS.ByteString)

templates/letter/fraport_qualification.md

@@ -5,11 +5,6 @@
 lang: de-de
 is-de: true
 date: 11.11.1111
-test1: this **is really** a test
-test2: 'this **is another** test'
-test3: |
-    <h1>First</h1>
-    <p>Here is some text with <em>emphasis</em> to see.
 ...
 \renewcommand{\familydefault}{\sfdefault}
 

test/Database/Fill.hs

@@ -680,10 +680,10 @@ fillDb = do
   void . insert' $ UserAvs (AvsPersonId 4) sbarth 4
   void . insert' $ UserAvs (AvsPersonId 5) fhamann 5
   void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77
-  void . insert' $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True  Nothing Nothing AvsCardColorGelb (Set.fromList ['F'])     Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
+  insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True  Nothing Nothing AvsCardColorGelb (Set.fromList ['F'])     Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
-  void . insert' $ UserAvsCard (AvsPersonId 2)        (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True  Nothing Nothing AvsCardColorRot  (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
+  insert_ $ UserAvsCard (AvsPersonId 2)        (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True  Nothing Nothing AvsCardColorRot  (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
-  void . insert' $ UserAvsCard (AvsPersonId 3)        (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot  (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now
+  insert_ $ UserAvsCard (AvsPersonId 3)        (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot  (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now
-  void . insert' $ UserAvsCard (AvsPersonId 4)        (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True  Nothing Nothing AvsCardColorGelb (Set.fromList ['F'])     Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now
+  insert_ $ UserAvsCard (AvsPersonId 4)        (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True  Nothing Nothing AvsCardColorGelb (Set.fromList ['F'])     Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now
 
   let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
   let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]