{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only module Handler.PrintCenter ( getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR -- TODO: for testing only, remove exports , mprToMeta ) 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 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 = "898989" , mppURL = Nothing , mppDate = fromGregorian 2022 07 27 , mppLang = "de-de" , mppOpening = Just "Lieber $recipient$ 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 [ toMeta "recipient" mppRecipient , toMeta "address" (mppAddress & html2textlines) , toMeta "login" mppLogin , toMeta "pin" mppPin , mbMeta "url" (mppURL <&> tshow) , toMeta "date" (mppDate & tshow) -- TODO: render according to user preference , 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 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 now <- liftIO getCurrentTime 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-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> numCell 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 (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview $ resultRecipient . _entityVal -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview $ resultSender . _entityVal -> 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-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)) -- TODO: continue here ] dbtFilterUI = mconcat [ -- TODO: continue here ] 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) over _1 postprocess <$> dbTable def 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 $ do let _acts :: Map PJTableAction (AForm Handler PJTableActionData) _acts = mconcat [ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData ] error "TODO: continue here" -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc $(widgetFile "print-center") 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 Right bs -> do liftIO $ LBS.writeFile "/tmp/generated.pdf" bs 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 siteLayoutMsg MsgMenuPrintSend $ do setTitleI MsgMenuPrintSend let sendForm = wrapForm sendWidget def { formEncoding = sendEnctype -- , formAction = Just $ SomeRoute actionUrl } -- TODO: use i18nWidgetFile instead if this is to become permanent $(widgetFile "print-send")