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

chore(letter): fix build and add filters to print center

Browse Source
This commit is contained in:
Steffen Jost 2022-07-15 19:00:08 +02:00
parent efc13f4498
commit 399b2d3fc6
5 changed files with 44 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/print/de-de-formal.msg
View File

@ -8,4 +8,4 @@ PrintRecipient: Empfänger
PrintSender !ident-ok: Sender PrintSender !ident-ok: Sender
PrintCourse: Kurse PrintCourse: Kurse
PrintQualification: Qualifikation PrintQualification: Qualifikation
PrintPDF !ident-ok: pdf PrintPDF !ident-ok: PDF

2
messages/uniworx/categories/print/en-eu.msg
View File

@ -8,4 +8,4 @@ PrintRecipient: Recipient
PrintSender: Sender PrintSender: Sender
PrintCourse: Course PrintCourse: Course
PrintQualification: Qualification PrintQualification: Qualification
PrintPDF: pdf PrintPDF: PDF

20
src/CryptoID.hs
View File

@ -79,6 +79,7 @@ instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "Submission" (CI FilePath)) wh
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where
toMarkup = toMarkup . toPathPiece toMarkup = toMarkup . toPathPiece
-- CryptoIDNamespace (CI FilePath) UserId ~ "User" -- CryptoIDNamespace (CI FilePath) UserId ~ "User"
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "User" (CI FilePath)) where instance {-# OVERLAPS #-} PathPiece (E.CryptoID "User" (CI FilePath)) where
fromPathPiece (Text.unpack -> piece) = do fromPathPiece (Text.unpack -> piece) = do
@ -96,3 +97,22 @@ instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "User" (CI FilePath)) where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "User" (CI FilePath)) where instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "User" (CI FilePath)) where
toMarkup = toMarkup . toPathPiece toMarkup = toMarkup . toPathPiece
-- CryptoIDNamespace (CI FilePath) PrinJobId ~ "PrintJob"
instance {-# OVERLAPS #-} PathPiece (E.CryptoID "PrintJob" (CI FilePath)) where
fromPathPiece (Text.unpack -> piece) = do
piece' <- (stripPrefix `on` map CI.mk) "uwl" piece
return . CryptoID . CI.mk $ map CI.original piece'
toPathPiece = Text.pack . ("uwl" <>) . CI.foldedCase . ciphertext
instance {-# OVERLAPS #-} ToJSON (E.CryptoID "PrintJob" (CI FilePath)) where
toJSON = String . toPathPiece
instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "PrintJob" (CI FilePath)) where
toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
instance {-# OVERLAPS #-} FromJSON (E.CryptoID "PrintJob" (CI FilePath)) where
parseJSON = withText "CryptoFileNameUser" $ maybe (fail "Could not parse CryptoPrintJob") return . fromPathPiece
instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "PrintJob" (CI FilePath)) where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoPrintJob") return . fromPathPiece
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "PrintJob" (CI FilePath)) where
toMarkup = toMarkup . toPathPiece

33
src/Handler/PrintCenter.hs
View File

@ -178,16 +178,23 @@ mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
mkPJTable = do mkPJTable = do
currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here
let let
showId :: PrintJobId -> Widget
showId k = do
c <- encrypt k
let f :: CryptoUUIDPrintJob -> Text
f x = toPathPiece x
[whamlet|#{f c}|]
dbtSQLQuery = pjTableQuery dbtSQLQuery = pjTableQuery
dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
dbtProj = dbtProjFilteredPostId dbtProj = dbtProjFilteredPostId
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^? resultPrintJob . _entityVal . _printJobAcknowledged) [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
, sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow k) , sortable (toNothingS "pdf") (i18nCell MsgPrintPDF) $ \( view $ resultPrintJob . _entityKey -> k) -> anchorCellM (PrintDownloadR <$> encrypt k) (showId k)
-- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow . E.unSqlBackendKey $ unPrintJobKey k)
-- , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> cell (showId k)
, sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
, sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
, sortable (toNothingS "pdf") (i18nCell MsgPrintPDF) $ \( view $ resultPrintJob . _entityKey -> k) -> anchorCellM (PrintDownloadR <$> encrypt k) (text2widget "pdf")
, sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell , sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
@ -195,7 +202,7 @@ mkPJTable = do
] ]
dbtSorting = mconcat dbtSorting = mconcat
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
, single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId)) -- , single ("pj-id" , SortColumn $ queryPrintJob >>> (E.^. PrintJobId))
, single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
, single ("pj-recipient" , sortUserNameBareM queryRecipient) , single ("pj-recipient" , sortUserNameBareM queryRecipient)
@ -204,12 +211,13 @@ mkPJTable = do
, single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) , single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
-- TODO: continue here -- TODO: continue here
] ]
dbtFilterUI = mconcat dbtFilterUI mPrev = mconcat
[ [ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
-- TODO: continue here -- TODO: continue here
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
@ -265,9 +273,9 @@ postPrintCenterR = do
getPrintSendR, postPrintSendR :: Handler Html getPrintSendR, postPrintSendR :: Handler Html
getPrintSendR = postPrintSendR getPrintSendR = postPrintSendR
postPrintSendR = do postPrintSendR = do
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm Nothing ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm $ Just def
let procFormSend mpr@MetaPinRenewal{..} = do let procFormSend mpr = do
addMessage Info . toHtml $ "Brief wird gesendet an " <> mppRecipient -- addMessage Info . toHtml $ "Brief wird gesendet an " <> mppRecipient
e_pdf <- pdfRenewal $ mprToMeta mpr e_pdf <- pdfRenewal $ mprToMeta mpr
-- now <- liftIO getCurrentTime -- now <- liftIO getCurrentTime
case e_pdf of case e_pdf of
@ -276,7 +284,8 @@ postPrintSendR = do
-- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
uID <- maybeAuthId uID <- maybeAuthId
filepath <- runDB $ sendLetter "Test-Brief" bs Nothing uID Nothing Nothing filepath <- runDB $ sendLetter "Test-Brief" bs Nothing uID Nothing Nothing
addMessage Success $ toHtml $ "Druckauftrag angelegt für " <> filepath addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> filepath
redirect PrintCenterR
Left err -> addMessage Error . toHtml $ P.renderError err Left err -> addMessage Error . toHtml $ P.renderError err
-- TODO: continue here with acutal letter sending! -- TODO: continue here with acutal letter sending!
return $ Just () return $ Just ()

2
src/Utils/Print.hs
View File

@ -228,7 +228,7 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin
course <- fmap (CI.original . courseShorthand ) . join <$> mapM get printJobCourse course <- fmap (CI.original . courseShorthand ) . join <$> mapM get printJobCourse
quali <- fmap (CI.original . qualificationShorthand) . join <$> mapM get printJobQualification quali <- fmap (CI.original . qualificationShorthand) . join <$> mapM get printJobQualification
let printJobAcknowledged = Nothing let printJobAcknowledged = Nothing
printJobFilename = unpack . T.intercalate "_" . catMaybes $ [Just printJobName, quali, course, sender, recipient] printJobFilename = unpack $ (T.intercalate "_" . catMaybes $ [Just printJobName, quali, course, sender, recipient]) <> ".pdf"
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
printJobFile = LBS.toStrict pdf printJobFile = LBS.toStrict pdf
-- TODO: system call to lpr here! -- TODO: system call to lpr here!