fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-05-04 16:33:27 +00:00
commit 8c350c2e54
15 changed files with 135 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/categories/courses/tutorial/en-eu.msg
View File

@ -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

1
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -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

9
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -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.

2
models/avs.model
View File

@ -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

7
src/Handler/Health.hs
View File

@ -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>

12
src/Handler/LMS.hs
View File

@ -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

48
src/Handler/Qualification.hs
View File

@ -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

2
src/Handler/Tutorial/Users.hs
View File

@ -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))

25
src/Handler/Utils/Avs.hs
View File

@ -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

31
src/Handler/Utils/Qualification.hs
View File

@ -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

13
src/Jobs/Handler/LMS.hs
View File

@ -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}|]

27
src/Utils/Avs.hs
View File

@ -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
-----------------------

12
src/Utils/Print.hs
View File

@ -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)

5
templates/letter/fraport_qualification.md
View File

@ -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}

8
test/Database/Fill.hs
View File

@ -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.|]