From 399b2d3fc6d24c1ec8b8150f0df2188db2df4363 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 15 Jul 2022 19:00:08 +0200 Subject: [PATCH] chore(letter): fix build and add filters to print center --- .../uniworx/categories/print/de-de-formal.msg | 2 +- messages/uniworx/categories/print/en-eu.msg | 2 +- src/CryptoID.hs | 20 +++++++++++ src/Handler/PrintCenter.hs | 33 ++++++++++++------- src/Utils/Print.hs | 2 +- 5 files changed, 44 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index a74940bdf..8916728ec 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -8,4 +8,4 @@ PrintRecipient: Empfänger PrintSender !ident-ok: Sender PrintCourse: Kurse PrintQualification: Qualifikation -PrintPDF !ident-ok: pdf \ No newline at end of file +PrintPDF !ident-ok: PDF \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index 3be983bf7..b4e98234e 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -8,4 +8,4 @@ PrintRecipient: Recipient PrintSender: Sender PrintCourse: Course PrintQualification: Qualification -PrintPDF: pdf \ No newline at end of file +PrintPDF: PDF \ No newline at end of file diff --git a/src/CryptoID.hs b/src/CryptoID.hs index b8ef9c70b..377c26691 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -79,6 +79,7 @@ instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "Submission" (CI FilePath)) wh instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "Submission" (CI FilePath)) where toMarkup = toMarkup . toPathPiece + -- CryptoIDNamespace (CI FilePath) UserId ~ "User" instance {-# OVERLAPS #-} PathPiece (E.CryptoID "User" (CI FilePath)) where 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 instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "User" (CI FilePath)) where 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 \ No newline at end of file diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 8be6937ef..ac7bb8515 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -178,16 +178,23 @@ mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) mkPJTable = do currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here let + showId :: PrintJobId -> Widget + showId k = do + c <- encrypt k + let f :: CryptoUUIDPrintJob -> Text + f x = toPathPiece x + [whamlet|#{f c}|] dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtProj = dbtProjFilteredPostId 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-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-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-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell @@ -195,7 +202,7 @@ mkPJTable = do ] dbtSorting = mconcat [ 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-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("pj-recipient" , sortUserNameBareM queryRecipient) @@ -204,12 +211,13 @@ mkPJTable = do , single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) ] 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 ] - 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 ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} @@ -265,9 +273,9 @@ postPrintCenterR = do getPrintSendR, postPrintSendR :: Handler Html getPrintSendR = postPrintSendR postPrintSendR = do - ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm Nothing - let procFormSend mpr@MetaPinRenewal{..} = do - addMessage Info . toHtml $ "Brief wird gesendet an " <> mppRecipient + ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm $ Just def + let procFormSend mpr = do + -- addMessage Info . toHtml $ "Brief wird gesendet an " <> mppRecipient e_pdf <- pdfRenewal $ mprToMeta mpr -- now <- liftIO getCurrentTime case e_pdf of @@ -276,7 +284,8 @@ postPrintSendR = do -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" uID <- maybeAuthId 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 -- TODO: continue here with acutal letter sending! return $ Just () diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 96689199b..c469eea93 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -228,7 +228,7 @@ sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse prin course <- fmap (CI.original . courseShorthand ) . join <$> mapM get printJobCourse quali <- fmap (CI.original . qualificationShorthand) . join <$> mapM get printJobQualification 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 = LBS.toStrict pdf -- TODO: system call to lpr here!