129 lines
5.2 KiB
Haskell
129 lines
5.2 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.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 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
|
|
|
|
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 Papa 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
|
|
|
|
|
|
getPrintCenterR, postPrintCenterR :: Handler Html
|
|
getPrintCenterR = postPrintCenterR
|
|
postPrintCenterR = do
|
|
-- 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")
|