diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index cdcf22eda..d793fe028 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/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 -TutorialUserRenewQualification: Renew Qualification +TutorialUserGrantQualification: Grant 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 diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 6267eff82..eae8b0e69 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 6880fa3ee..77a2dfbb5 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/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 -LmsUserlistUpdate: Update of LMS User +LmsUserlistInsert: New 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. diff --git a/models/avs.model b/models/avs.model index 45f2321d7..4f495bd25 100644 --- a/models/avs.model +++ b/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 diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index a34361191..aad83d566 100644 --- a/src/Handler/Health.hs +++ b/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 Status <body> + $maybe env_ver <- env_version + <p> + Environment version #{env_ver} <p> Current Time <br> #{show currtime} <br> diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 1b2107632..1499ebb1d 100644 --- a/src/Handler/LMS.hs +++ b/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 -> - E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do + , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of + 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.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text))) - `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text)))) - ) + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) + ) , 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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6ddeb3dde..2a5e2c0b8 100644 --- a/src/Handler/Qualification.hs +++ b/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 -> - E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do + , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of + 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.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text))) - `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text)))) - ) + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) + ) , 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 - let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) + qent@Entity{entityVal=Qualification{ + 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 @@ -520,10 +544,8 @@ postQualificationR sid qsh = do msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire addMessageI msgKind msgVal reloadKeepGetParams $ QualificationR sid qsh - (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do - now <- liftIO getCurrentTime - let nowaday = utctDay now - selUserIds = Set.toList selectedUsers + (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do + let selUserIds = Set.toList selectedUsers qubr = case action of QualificationActUnblockData -> Nothing QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index b32f1aeb8..207bc1731 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/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)) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b3e3dfd8f..3a6083fae 100644 --- a/src/Handler/Utils/Avs.hs +++ b/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) -> - maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ - maybeM (return Nothing) extractUidCard $ getBy $ UniqueAvsCard cardNo + Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid + -- NOTE: card validity might be outdated, so we must always check with avs + -- 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 diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 1e8302ecf..c259e9867 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -137,4 +137,35 @@ qualificationUserBlocking qid uids qb = do , transactionUser = uid , 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 \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 36e668a08..074a3b866 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/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}|] diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 7dfe7148c..e7007921a 100644 --- a/src/Utils/Avs.hs +++ b/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)) - => (a -> ClientM c) -> a -> ClientM c - splitQuery rawQuery q - | Set.size s <= avsMaxQueryAtOnce = rawQuery q - | otherwise = do - let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s - res1 <- rawQuery $ view _Unwrapped' avsid1 - res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 - return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') - where - s = view _Wrapped' q +splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c)) + => (a -> ClientM c) -> a -> ClientM c +splitQuery rawQuery q + | avsMaxQueryAtOnce >= Set.size s = rawQuery q + | otherwise = do + $logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) + let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s + res1 <- rawQuery $ view _Unwrapped' avsid1 + res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 + return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') + where + s = view _Wrapped' q #endif ----------------------- diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 5cd1a7e4f..c4cef4499 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -127,8 +127,9 @@ mdTemplating template meta = runExceptT $ do , P.writerTemplate = Just tmpl } ExceptT . pure . over _Left P.renderError . P.runPure $ do - md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc - P.readMarkdown readerOpts md_txt + md_txt <- P.writeMarkdown writerOpts $ appMeta setIsDeFromLang $ addMeta meta doc + 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,12 +137,11 @@ 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 @@ -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) diff --git a/templates/letter/fraport_qualification.md b/templates/letter/fraport_qualification.md index 01af7f394..2a7f86a65 100644 --- a/templates/letter/fraport_qualification.md +++ b/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} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8d34c713b..d165ed9fc 100644 --- a/test/Database/Fill.hs +++ b/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 - 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 - 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 - 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 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") 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 + 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 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.|]