353 lines
18 KiB
Haskell
353 lines
18 KiB
Haskell
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.PrintCenter
|
|
( getPrintCenterR, postPrintCenterR
|
|
, getPrintSendR , postPrintSendR
|
|
, getPrintDownloadR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy as LT
|
|
-- import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Text.Pandoc as P
|
|
import qualified Text.Pandoc.Builder as P
|
|
|
|
import Database.Persist.Sql (updateWhereCount)
|
|
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
import Utils.Print
|
|
-- import Data.Aeson (encode)
|
|
-- import qualified Data.Text as Text
|
|
-- import qualified Data.Set as Set
|
|
|
|
import Handler.Utils
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
data MetaPinRenewal = MetaPinRenewal
|
|
{ mppRecipient :: Text
|
|
, mppAddress :: StoredMarkup
|
|
, mppLogin :: Text
|
|
, mppPin :: Text
|
|
, mppURL :: Maybe URI
|
|
, mppDate :: Day
|
|
, mppLang :: Lang
|
|
, mppOpening :: Maybe Text
|
|
, mppClosing :: Maybe Text
|
|
}
|
|
deriving (Eq, Ord, Show, Generic, Typeable)
|
|
|
|
-- TODO: just for testing, remove in production
|
|
instance Default MetaPinRenewal where
|
|
def = MetaPinRenewal
|
|
{ mppRecipient = "Papa Schlumpf"
|
|
, mppAddress = plaintextToStoredMarkup ("Erdbeerweg 42\n98726 Schlumpfhausen"::Text)
|
|
, mppLogin = "keiner123"
|
|
, mppPin = "89998a"
|
|
, mppURL = Nothing
|
|
, mppDate = fromGregorian 2022 07 27
|
|
, mppLang = "de-de"
|
|
, mppOpening = Just "Lieber Schlumpfi,"
|
|
, mppClosing = Nothing
|
|
}
|
|
|
|
makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
|
|
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do
|
|
now_day <- utctDay <$> liftIO getCurrentTime
|
|
flip (renderAForm FormStandard) html $ MetaPinRenewal
|
|
<$> areq textField (fslI MsgMppRecipient) (mppRecipient <$> tmpl)
|
|
<*> areq htmlField (fslI MsgMppAddress) (mppAddress <$> tmpl)
|
|
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
|
|
<*> areq textField (fslI MsgMppPin) (mppPin <$> tmpl)
|
|
<*> aopt urlField (fslI MsgMppURL) (mppURL <$> tmpl)
|
|
<*> areq dayField (fslI MsgMppDate) ((mppDate <$> tmpl) <|> Just now_day)
|
|
<*> areq (langField True) (fslI MsgMppLang) ((mppLang <$> tmpl) <|> Just "de-de")
|
|
<*> aopt textField (fslI MsgMppOpening) (mppOpening <$> tmpl)
|
|
<*> aopt textField (fslI MsgMppClosing) (mppClosing <$> tmpl)
|
|
|
|
validateMetaPinRenewal :: FormValidator MetaPinRenewal Handler ()
|
|
validateMetaPinRenewal = do
|
|
MetaPinRenewal{..} <- State.get
|
|
guardValidation MsgMppBadLanguage $ isDe mppLang || isEn mppLang
|
|
|
|
|
|
mprToMeta :: MetaPinRenewal -> P.Meta
|
|
mprToMeta MetaPinRenewal{..} = P.Meta $ mconcat
|
|
-- formatTimeUser SelFormatDate mppDate mppRecipient
|
|
[ toMeta "recipient" mppRecipient
|
|
, toMeta "address" (mppRecipient : (mppAddress & html2textlines))
|
|
, toMeta "login" mppLogin
|
|
, toMeta "pin" mppPin
|
|
, mbMeta "url" (mppURL <&> tshow)
|
|
, toMeta "date" (mppDate & tshow) -- rendering according to user preference requires Handler Monad; deferred to Post-processing of P.Meta
|
|
, toMeta "lang" mppLang
|
|
, mbMeta keyOpening mppOpening
|
|
, mbMeta keyClosing mppClosing
|
|
]
|
|
where
|
|
deOrEn = if isDe mppLang then "de" else "en"
|
|
keyOpening = deOrEn <> "-opening"
|
|
keyClosing = deOrEn <> "-closing"
|
|
mbMeta :: P.ToMetaValue a => Text -> Maybe a -> Map Text P.MetaValue
|
|
mbMeta = foldMap . toMeta
|
|
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
|
|
toMeta k = singletonMap k . P.toMetaValue
|
|
html2textlines :: StoredMarkup -> [Text]
|
|
html2textlines sm = T.lines . LT.toStrict $ markupInput sm
|
|
|
|
mprToMetaUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity User -> MetaPinRenewal -> m P.Meta
|
|
mprToMetaUser entUser@Entity{entityVal = u} mpr = do
|
|
let userLang = userLanguages u >>= (listToMaybe . view _Wrapped) -- auch möglich `op Languages` statt `view _Wrapped`
|
|
meta = mprToMeta mpr{ mppRecipient = userDisplayName u
|
|
-- , mppAddress = userDisplayName u : html2textlines userAddress --TODO once we have User addresses within the DB
|
|
, mppLang = fromMaybe (mppLang mpr) userLang -- check if this is the desired behaviour!
|
|
}
|
|
userDate <- formatTimeUser SelFormatDate (mppDate mpr) (Just entUser)
|
|
return $ P.setMeta "date" userDate meta
|
|
|
|
|
|
data PJTableAction = PJActAcknowledge
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
|
|
instance Universe PJTableAction
|
|
instance Finite PJTableAction
|
|
nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''PJTableAction id
|
|
|
|
-- Not yet needed, since there is no additional data for now:
|
|
data PJTableActionData = PJActAcknowledgeData
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
type PJTableExpr = ( E.SqlExpr (Entity PrintJob)
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Course))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification))
|
|
)
|
|
|
|
queryPrintJob :: PJTableExpr -> E.SqlExpr (Entity PrintJob)
|
|
queryPrintJob = $(sqlLOJproj 5 1)
|
|
|
|
queryRecipient :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
|
|
queryRecipient = $(sqlLOJproj 5 2)
|
|
|
|
querySender :: PJTableExpr -> E.SqlExpr (Maybe (Entity User))
|
|
querySender = $(sqlLOJproj 5 3)
|
|
|
|
queryCourse :: PJTableExpr -> E.SqlExpr (Maybe (Entity Course))
|
|
queryCourse = $(sqlLOJproj 5 4)
|
|
|
|
queryQualification :: PJTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
|
|
queryQualification = $(sqlLOJproj 5 5)
|
|
|
|
type PJTableData = DBRow (Entity PrintJob, Maybe (Entity User), Maybe (Entity User), Maybe (Entity Course), Maybe (Entity Qualification))
|
|
|
|
resultPrintJob :: Lens' PJTableData (Entity PrintJob)
|
|
resultPrintJob = _dbrOutput . _1
|
|
|
|
resultRecipient :: Traversal' PJTableData (Entity User)
|
|
resultRecipient = _dbrOutput . _2 . _Just
|
|
|
|
resultSender :: Traversal' PJTableData (Entity User)
|
|
resultSender = _dbrOutput . _3 . _Just
|
|
|
|
resultCourse :: Traversal' PJTableData (Entity Course)
|
|
resultCourse = _dbrOutput . _4 . _Just
|
|
|
|
resultQualification :: Traversal' PJTableData (Entity Qualification)
|
|
resultQualification = _dbrOutput . _5 . _Just
|
|
|
|
pjTableQuery :: PJTableExpr -> E.SqlQuery
|
|
( E.SqlExpr (Entity PrintJob)
|
|
, E.SqlExpr (Maybe (Entity User))
|
|
, E.SqlExpr (Maybe (Entity User))
|
|
, E.SqlExpr (Maybe (Entity Course))
|
|
, E.SqlExpr (Maybe (Entity Qualification)))
|
|
pjTableQuery (printJob `E.LeftOuterJoin` recipient
|
|
`E.LeftOuterJoin` sender
|
|
`E.LeftOuterJoin` course
|
|
`E.LeftOuterJoin` quali ) = do
|
|
E.on $ printJob E.^. PrintJobRecipient E.==. recipient E.?. UserId
|
|
E.on $ printJob E.^. PrintJobSender E.==. sender E.?. UserId
|
|
E.on $ printJob E.^. PrintJobCourse E.==. course E.?. CourseId
|
|
E.on $ printJob E.^. PrintJobQualification E.==. quali E.?. QualificationId
|
|
return (printJob, recipient, sender, course, quali)
|
|
|
|
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)
|
|
, 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-filename") (i18nCell MsgPrintJobFilename) $ \( view $ resultPrintJob . _entityVal . _printJobFilename -> t) -> textCell t
|
|
, 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-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
|
|
, 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
|
|
, sortable (Just "pj-qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
|
|
]
|
|
dbtSorting = mconcat
|
|
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
|
|
, single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
|
|
-- , 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)
|
|
, single ("pj-sender" , sortUserNameBareM querySender )
|
|
, single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
|
, single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
|
|
, single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
|
|
, single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
|
, single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
|
|
, single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
|
|
, single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
|
|
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename)
|
|
, prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
|
|
, prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient)
|
|
, prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender)
|
|
, prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
|
|
, prismAForm (singletonFilter "pj-qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
|
|
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
|
dbtIdent :: Text
|
|
dbtIdent = "print-job"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= let acts :: Map PJTableAction (AForm Handler PJTableActionData)
|
|
acts = mconcat
|
|
[ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData
|
|
]
|
|
in renderAForm FormStandard
|
|
$ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
postprocess :: FormResult (First PJTableActionData, DBFormResult PrintJobId Bool PJTableData)
|
|
-> FormResult ( PJTableActionData, Set PrintJobId)
|
|
postprocess inp = do
|
|
(First (Just act), jobMap) <- inp
|
|
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
|
return (act, jobSet)
|
|
psValidator = def & defaultSorting [SortAscBy "pj-created"]
|
|
& defaultFilter (singletonMap "acknowledged" [toPathPiece False])
|
|
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
|
|
|
getPrintCenterR, postPrintCenterR :: Handler Html
|
|
getPrintCenterR = postPrintCenterR
|
|
postPrintCenterR = do
|
|
currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
|
(pjRes, pjTable) <- runDB mkPJTable
|
|
|
|
formResult pjRes $ \case
|
|
(PJActAcknowledgeData, pjIds) -> do
|
|
let setPJIds = Set.toList pjIds
|
|
now <- liftIO getCurrentTime
|
|
num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. setPJIds] [PrintJobAcknowledged =. Just now]
|
|
addMessageI Success $ MsgPrintJobAcknowledge num
|
|
redirect currentRoute
|
|
|
|
siteLayoutMsg MsgMenuApc $ do
|
|
setTitleI MsgMenuApc
|
|
$(widgetFile "print-center") -- i18nWidgetFile? Currently no text contained; displays just the table only
|
|
|
|
|
|
getPrintSendR, postPrintSendR :: Handler Html
|
|
getPrintSendR = postPrintSendR
|
|
postPrintSendR = do
|
|
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm $ Just def
|
|
let procFormSend mpr = do
|
|
receivers <- runDB $ Ex.select $ do
|
|
user <- Ex.from $ Ex.table @User
|
|
Ex.where_ $ E.val (mppRecipient mpr) `E.isInfixOf` (user E.^. UserIdent)
|
|
pure user
|
|
letters <- case receivers of
|
|
[] -> pure . (Nothing ,) <$> pdfRenewal (mprToMeta mpr)
|
|
_ -> forM receivers $ \usr -> do
|
|
meta <- mprToMetaUser usr mpr
|
|
pdf <- pdfRenewal meta
|
|
return (Just $ entityKey usr, pdf)
|
|
oks <- forM letters $ \case
|
|
(mbRecipient, Right bs) -> do
|
|
-- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
|
|
-- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
|
|
uID <- maybeAuthId
|
|
filepath <- runDB $ sendLetter "Test-Brief" bs mbRecipient uID Nothing Nothing
|
|
addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> filepath
|
|
-- TODO: continue here with acutal letter sending!
|
|
pure True
|
|
(Nothing, Left err) -> do
|
|
addMessage Error $ toHtml err
|
|
pure False
|
|
(Just uid, Left err) -> do
|
|
addMessage Error . toHtml $ "For uid " <> tshow uid <> ": " <> err
|
|
pure False
|
|
when (or oks) $ redirect PrintCenterR
|
|
formResult sendResult procFormSend
|
|
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
|
siteLayoutMsg MsgPrintManualRenewal $ do
|
|
setTitleI MsgMenuPrintSend
|
|
let sendForm = wrapForm sendWidget def
|
|
{ formEncoding = sendEnctype
|
|
-- , formAction = Just $ SomeRoute actionUrl
|
|
}
|
|
$(widgetFile "print-send") -- i18nWidgetFile? Currently no text contained; displays just the form only
|
|
|
|
|
|
getPrintDownloadR :: CryptoUUIDPrintJob -> Handler TypedContent
|
|
getPrintDownloadR cupj = do
|
|
pjId <- decrypt cupj
|
|
PrintJob {..} <- runDB $ get404 pjId
|
|
sendByteStringAsFile printJobFilename printJobFile printJobCreated
|
|
{- for PrintJobFile :: FileContentReference use this code, however, requires instances
|
|
HasFileReference PrintJob and IsFileReference PrintJob which seemed to complicated... :(
|
|
serveOneFile $ fileQuery .| C.map entityVal
|
|
where
|
|
fileQuery = E.selectSource $ E.from $
|
|
\pj -> do
|
|
-- filter to requested file
|
|
E.where_ (pj E.^. PrintJobId E.==. E.val pjId)
|
|
-- return file entity
|
|
return pj
|
|
-} |