{-# LANGUAGE TypeApplications #-} module Handler.PrintCenter ( getPrintCenterR, postPrintCenterR , getPrintAcknowR, postPrintAcknowR , 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{..} = mkMeta -- 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" 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 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 MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey t = r ^. resultPrintJob . _entityVal . _printJobFilename in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) , 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 , sortable (Just "pj-lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> q) -> ifIconCell (isJust q) IconMenuLms ] dbtSorting = mconcat [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) , single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , 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)) , single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.isJust . (E.^. PrintJobLmsUser))) ] 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-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) --, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , 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-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) , prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) , prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) --, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- ) , 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, Set.toList -> pjIds) -> do now <- liftIO getCurrentTime num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [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 runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing Nothing) >>= \case -- calls lpr Left err -> do let msg = "PDF printing failed with error: " <> err $logErrorS "LPR" msg addMessage Error $ toHtml msg pure False Right (ok, fpath) -> do let response = if null ok then mempty else " Response: " <> ok addMessage Success $ toHtml $ "Druckauftrag angelegt: " <> pack fpath <> response 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 -} getPrintAcknowR, postPrintAcknowR :: Day -> Int -> Int -> Handler Html getPrintAcknowR = postPrintAcknowR postPrintAcknowR ackDay numAck chksm = do ((ackRes, ackWgt), ackEnctype) <- runFormPost (identifyForm FIDPrintAcknowledge buttonForm :: Form ButtonConfirm) let ackForm = wrapForm ackWgt def { formAction = Just $ SomeRoute $ PrintAcknowR ackDay numAck chksm , formEncoding = ackEnctype , formSubmit = FormNoSubmit } formResult ackRes $ \BtnConfirm -> do numNew <- runDB $ do pjs <- Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob let pjDay = E.day $ pj Ex.^. PrintJobCreated Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) Ex.&&. (pjDay Ex.==. Ex.val ackDay) return $ pj Ex.^. PrintJobId let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs)) if changed then return (-1) else do now <- liftIO getCurrentTime E.updateCount $ \pj -> do let pjDay = E.day $ pj E.^. PrintJobCreated E.set pj [ PrintJobAcknowledged E.=. E.just (E.val now) ] E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) E.&&. (pjDay E.==. E.val ackDay) -- Ex.updateCount $ do -- pj <- Ex.from $ Ex.table @PrintJob -- let pjDay = E.day $ pj Ex.^. PrintJobCreated -- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ] -- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) -- Ex.&&. (pjDay Ex.==. Ex.val ackDay) if numNew > 0 then addMessageI Success $ MsgPrintJobAcknowledge numNew else addMessageI Error MsgPrintJobAcknowledgeFailed redirect PrintCenterR ackDayText <- formatTime SelFormatDate ackDay siteLayoutMsg (MsgPrintJobAcknowledgeQuestion numAck ackDayText) ackForm