285 lines
13 KiB
Haskell
285 lines
13 KiB
Haskell
{-# 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")
|