From 51339ac2896bc9eed873564be441dd9126648696 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 13 Jul 2022 17:08:19 +0200 Subject: [PATCH] chore(print): add prinjobs to model --- models/print.model | 10 +++++++++ src/Handler/PrintCenter.hs | 16 +++++-------- src/Utils/Print.hs | 46 +++++++++++++++++++++++++++++--------- 3 files changed, 51 insertions(+), 21 deletions(-) create mode 100644 models/print.model diff --git a/models/print.model b/models/print.model new file mode 100644 index 000000000..82dd0ddfb --- /dev/null +++ b/models/print.model @@ -0,0 +1,10 @@ +PrintJob + name Text + file FileContentReference + created UTCTime + acknowledged UTCTime Maybe + recipient UserId Maybe -- optional as some letters may contain just an address + sender UserId Maybe -- senders and associations are optional + course CourseId Maybe OnDeleteCascade OnUpdateCascade + qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade + deriving Generic \ No newline at end of file diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 51a1240ce..d16d74f32 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -101,27 +101,24 @@ postPrintCenterR = do $(widgetFile "print-center") -getPrintSendR, postPrintSendR:: Handler TypedContent +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 e_pdf <- pdfRenewal $ mprToMeta mpr - now <- liftIO getCurrentTime - _ <- case e_pdf of + -- now <- liftIO getCurrentTime + case e_pdf of Right bs -> do liftIO $ LBS.writeFile "/tmp/generated.pdf" bs - sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict bs) now - -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" - Left err -> - -- addMessage Error . toHtml $ P.renderError err - sendResponseStatus internalServerError500 $ toTypedContent $ P.renderError err + addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf" + Left err -> addMessage Error . toHtml $ P.renderError err -- TODO: continue here with acutal letter sending! return $ Just () mbPdfLink <- formResultMaybe sendResult procFormSend -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute - answer <- siteLayoutMsg MsgMenuPrintSend $ do + siteLayoutMsg MsgMenuPrintSend $ do setTitleI MsgMenuPrintSend let sendForm = wrapForm sendWidget def { formEncoding = sendEnctype @@ -129,4 +126,3 @@ postPrintSendR = do } -- TODO: use i18nWidgetFile instead if this is to become permanent $(widgetFile "print-send") - sendResponse $ toTypedContent answer diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 6c69b6a67..7b5b33c96 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -1,11 +1,11 @@ module Utils.Print where -import Import.NoModel +-- import Import.NoModel -- import qualified Data.Foldable as Fold -- hiding (foldr) import Data.Foldable (foldr) -- import qualified Data.Text as T -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy as LBS import Control.Monad.Except import Import hiding (embedFile) import Data.FileEmbed (embedFile) @@ -46,25 +46,33 @@ compileTemplate tmpl = do where str2pandocError = over _Left $ P.PandocTemplateError . pack -makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO L.ByteString --- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m L.ByteString -- only pandoc >= 2.18 +makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO LBS.ByteString +-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m LBS.ByteString -- only pandoc >= 2.18 makePDF wopts doc = do mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc liftEither $ bs2pandocError mbPdf where texopts = [] - bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . L.toStrict) + bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict) -- | Modify the Meta-Block of Pandoc +-- This could be a lens? appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs +-- appMeta f = _Meta %~ f + +_Meta :: Lens' P.Pandoc P.Meta +_Meta = lens mg mp + where + mg (P.Pandoc m _) = m + mp (P.Pandoc _ b) m = P.Pandoc m b -- applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p -- applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas -- | Add meta to pandoc. Existing variables will be overwritten. addMeta :: P.Meta -> P.Pandoc -> P.Pandoc -addMeta m = appMeta (<> m) +addMeta m = appMeta (<> m) -- Data.Map says: (<>) == union and union should prefer the left operand, but somehow it does not! --addMeta m p = meta <> p -- where meta = P.Pandoc m mempty @@ -86,6 +94,7 @@ defWriterOpts :: P.Template Text -> P.WriterOptions defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplate = Just t } + ------------------------- -- Readers and writers -- ------------------------- @@ -129,8 +138,8 @@ reTemplateLetter' meta md = do } ---pdfDIN5008 :: P.PandocMonad m => Text -> m L.ByteString -- for pandoc > 2.18 -pdfDIN5008' :: P.Meta -> Text -> P.PandocIO L.ByteString +--pdfDIN5008 :: P.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18 +pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString pdfDIN5008' meta md = do tmpl <- compileTemplate templateDIN5008 let readerOpts = def { P.readerExtensions = P.pandocExtensions } @@ -142,7 +151,7 @@ pdfDIN5008' meta md = do $ addMeta meta doc -- | creates a PDF using the din5008 template -pdfDIN5008 :: P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError L.ByteString) +pdfDIN5008 :: P.Meta -> Text -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) pdfDIN5008 meta md = do e_tmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008) actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do @@ -194,14 +203,29 @@ mdRenewal meta = runExceptT $ do -- | combines 'mdRenewal' and 'pdfDIN5008' -pdfRenewal :: P.Meta -> HandlerFor UniWorX (Either P.PandocError L.ByteString) +pdfRenewal :: P.Meta -> HandlerFor UniWorX (Either P.PandocError LBS.ByteString) pdfRenewal meta = do e_txt <- mdRenewal' meta --actRight e_txt (pdfDIN5008 . appMeta setIsDeFromLang . addMeta meta) -- try this actRight e_txt $ pdfDIN5008 meta -- | like pdfRenewal but without caching -pdfRenewal' :: P.Meta -> P.PandocIO L.ByteString +pdfRenewal' :: P.Meta -> P.PandocIO LBS.ByteString pdfRenewal' meta = do doc <- reTemplateLetter' meta templateRenewal pdfDIN5008' meta doc + + + +--------------- +-- PrintJobs -- +--------------- + +sendLetter :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB () +sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do + let printJobAcknowledged = Nothing + printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- sinkFileDB: Boolean Field problematic? Hashing? + printJobCreated <- liftIO getCurrentTime + insert_ PrintJob {..} + +