chore(print): add prinjobs to model
This commit is contained in:
parent
21c0015ba0
commit
51339ac289
10
models/print.model
Normal file
10
models/print.model
Normal file
@ -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
|
||||||
@ -101,27 +101,24 @@ postPrintCenterR = do
|
|||||||
$(widgetFile "print-center")
|
$(widgetFile "print-center")
|
||||||
|
|
||||||
|
|
||||||
getPrintSendR, postPrintSendR:: Handler TypedContent
|
getPrintSendR, postPrintSendR:: Handler Html
|
||||||
getPrintSendR = postPrintSendR
|
getPrintSendR = postPrintSendR
|
||||||
postPrintSendR = do
|
postPrintSendR = do
|
||||||
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm Nothing
|
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm Nothing
|
||||||
let procFormSend mpr@MetaPinRenewal{..} = do
|
let procFormSend mpr@MetaPinRenewal{..} = 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
|
||||||
Right bs -> do
|
Right bs -> do
|
||||||
liftIO $ LBS.writeFile "/tmp/generated.pdf" bs
|
liftIO $ LBS.writeFile "/tmp/generated.pdf" bs
|
||||||
sendByteStringAsFile "demoPDF.pdf" (LBS.toStrict bs) now
|
addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
|
||||||
-- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
|
Left err -> addMessage Error . toHtml $ P.renderError err
|
||||||
Left err ->
|
|
||||||
-- addMessage Error . toHtml $ P.renderError err
|
|
||||||
sendResponseStatus internalServerError500 $ toTypedContent $ P.renderError err
|
|
||||||
-- TODO: continue here with acutal letter sending!
|
-- TODO: continue here with acutal letter sending!
|
||||||
return $ Just ()
|
return $ Just ()
|
||||||
mbPdfLink <- formResultMaybe sendResult procFormSend
|
mbPdfLink <- formResultMaybe sendResult procFormSend
|
||||||
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
||||||
answer <- siteLayoutMsg MsgMenuPrintSend $ do
|
siteLayoutMsg MsgMenuPrintSend $ do
|
||||||
setTitleI MsgMenuPrintSend
|
setTitleI MsgMenuPrintSend
|
||||||
let sendForm = wrapForm sendWidget def
|
let sendForm = wrapForm sendWidget def
|
||||||
{ formEncoding = sendEnctype
|
{ formEncoding = sendEnctype
|
||||||
@ -129,4 +126,3 @@ postPrintSendR = do
|
|||||||
}
|
}
|
||||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||||
$(widgetFile "print-send")
|
$(widgetFile "print-send")
|
||||||
sendResponse $ toTypedContent answer
|
|
||||||
|
|||||||
@ -1,11 +1,11 @@
|
|||||||
module Utils.Print where
|
module Utils.Print where
|
||||||
|
|
||||||
import Import.NoModel
|
-- import Import.NoModel
|
||||||
-- import qualified Data.Foldable as Fold
|
-- import qualified Data.Foldable as Fold
|
||||||
-- hiding (foldr) import Data.Foldable (foldr)
|
-- hiding (foldr) import Data.Foldable (foldr)
|
||||||
|
|
||||||
-- import qualified Data.Text as T
|
-- 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 Control.Monad.Except
|
||||||
import Import hiding (embedFile)
|
import Import hiding (embedFile)
|
||||||
import Data.FileEmbed (embedFile)
|
import Data.FileEmbed (embedFile)
|
||||||
@ -46,25 +46,33 @@ compileTemplate tmpl = do
|
|||||||
where
|
where
|
||||||
str2pandocError = over _Left $ P.PandocTemplateError . pack
|
str2pandocError = over _Left $ P.PandocTemplateError . pack
|
||||||
|
|
||||||
makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO L.ByteString
|
makePDF :: P.WriterOptions -> P.Pandoc -> P.PandocIO LBS.ByteString
|
||||||
-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m L.ByteString -- only pandoc >= 2.18
|
-- makePDF :: (PandocMonad m, MonadIO m, MonadMask m) => P.WriterOptions -> P.Pandoc -> m LBS.ByteString -- only pandoc >= 2.18
|
||||||
makePDF wopts doc = do
|
makePDF wopts doc = do
|
||||||
mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc
|
mbPdf <- P.makePDF "lualatex" texopts P.writeLaTeX wopts doc
|
||||||
liftEither $ bs2pandocError mbPdf
|
liftEither $ bs2pandocError mbPdf
|
||||||
where
|
where
|
||||||
texopts = []
|
texopts = []
|
||||||
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . L.toStrict)
|
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict)
|
||||||
|
|
||||||
-- | Modify the Meta-Block of Pandoc
|
-- | Modify the Meta-Block of Pandoc
|
||||||
|
-- This could be a lens?
|
||||||
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
|
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
|
||||||
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
|
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 :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p
|
||||||
-- applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
|
-- applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
|
||||||
|
|
||||||
-- | Add meta to pandoc. Existing variables will be overwritten.
|
-- | Add meta to pandoc. Existing variables will be overwritten.
|
||||||
addMeta :: P.Meta -> P.Pandoc -> P.Pandoc
|
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
|
--addMeta m p = meta <> p
|
||||||
-- where meta = P.Pandoc m mempty
|
-- 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 }
|
defWriterOpts t = def { P.writerExtensions = P.pandocExtensions, P.writerTemplate = Just t }
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-------------------------
|
-------------------------
|
||||||
-- Readers and writers --
|
-- 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.PandocMonad m => Text -> m LBS.ByteString -- for pandoc > 2.18
|
||||||
pdfDIN5008' :: P.Meta -> Text -> P.PandocIO L.ByteString
|
pdfDIN5008' :: P.Meta -> Text -> P.PandocIO LBS.ByteString
|
||||||
pdfDIN5008' meta md = do
|
pdfDIN5008' meta md = do
|
||||||
tmpl <- compileTemplate templateDIN5008
|
tmpl <- compileTemplate templateDIN5008
|
||||||
let readerOpts = def { P.readerExtensions = P.pandocExtensions }
|
let readerOpts = def { P.readerExtensions = P.pandocExtensions }
|
||||||
@ -142,7 +151,7 @@ pdfDIN5008' meta md = do
|
|||||||
$ addMeta meta doc
|
$ addMeta meta doc
|
||||||
|
|
||||||
-- | creates a PDF using the din5008 template
|
-- | 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
|
pdfDIN5008 meta md = do
|
||||||
e_tmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008)
|
e_tmpl <- $cachedHereBinary ("din5008"::Text) (liftIO . P.runIO $ compileTemplate templateDIN5008)
|
||||||
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
|
actRight e_tmpl $ \tmpl -> liftIO . P.runIO $ do
|
||||||
@ -194,14 +203,29 @@ mdRenewal meta = runExceptT $ do
|
|||||||
|
|
||||||
|
|
||||||
-- | combines 'mdRenewal' and 'pdfDIN5008'
|
-- | 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
|
pdfRenewal meta = do
|
||||||
e_txt <- mdRenewal' meta
|
e_txt <- mdRenewal' meta
|
||||||
--actRight e_txt (pdfDIN5008 . appMeta setIsDeFromLang . addMeta meta) -- try this
|
--actRight e_txt (pdfDIN5008 . appMeta setIsDeFromLang . addMeta meta) -- try this
|
||||||
actRight e_txt $ pdfDIN5008 meta
|
actRight e_txt $ pdfDIN5008 meta
|
||||||
|
|
||||||
-- | like pdfRenewal but without caching
|
-- | like pdfRenewal but without caching
|
||||||
pdfRenewal' :: P.Meta -> P.PandocIO L.ByteString
|
pdfRenewal' :: P.Meta -> P.PandocIO LBS.ByteString
|
||||||
pdfRenewal' meta = do
|
pdfRenewal' meta = do
|
||||||
doc <- reTemplateLetter' meta templateRenewal
|
doc <- reTemplateLetter' meta templateRenewal
|
||||||
pdfDIN5008' meta doc
|
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 {..}
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user