fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(letter): connect letter sending form

Browse Source
This commit is contained in:
Steffen Jost 2022-07-08 12:55:58 +02:00
parent d078257a70
commit cd6e560b4b
7 changed files with 78 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

121
src/Handler/PrintCenter.hs
View File

@ -21,107 +21,86 @@ import qualified Control.Monad.State.Class as State
import Handler.Utils import Handler.Utils
data MetaPinRenewal = MetaPinRenewal data MetaPinRenewal = MetaPinRenewal
{ mppDate :: Maybe Text { mppRecipient :: Text
, mppURL :: Maybe Text , mppAddress :: StoredMarkup
, mppLogin :: Text , mppLogin :: Text
, mppPin :: Text , mppPin :: Text
, mppRecipient :: Text , mppURL :: Maybe URI
, mppAddress :: StoredMarkup , mppDate :: Day
, mppLang :: Text , mppLang :: Lang
, mppOpening :: Maybe Text
, mppClosing :: Maybe Text
} }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Show, Generic, Typeable)
formToMetaValues :: MetaPinRenewal -> P.Meta formToMetaValues :: MetaPinRenewal -> P.Meta
formToMetaValues MetaPinRenewal{..} = P.Meta $ mconcat formToMetaValues MetaPinRenewal{..} = P.Meta $ mconcat
[ mbMeta "date" mppDate [ toMeta "recipient" mppRecipient
, mbMeta "url" mppURL , toMeta "address" (mppAddress & html2textlines)
, toMeta "login" mppLogin , toMeta "login" mppLogin
, toMeta "pin" mppPin , toMeta "pin" mppPin
, toMeta "recipient" mppRecipient , mbMeta "url" (mppURL <&> tshow)
, toMeta "address" (mppAddress & html2textlines) , toMeta "date" (mppDate & tshow) -- TODO: render according to user preference
, toMeta "lang" mppLang , toMeta "lang" mppLang
] , mbMeta keyOpening mppOpening
, mbMeta keyClosing mppClosing
]
where 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 mbMeta = foldMap . toMeta
toMeta :: P.ToMetaValue a => Text -> a -> Map Text P.MetaValue
toMeta k = singletonMap k . P.toMetaValue toMeta k = singletonMap k . P.toMetaValue
html2textlines :: StoredMarkup -> [Text] html2textlines :: StoredMarkup -> [Text]
html2textlines sm = T.lines . LT.toStrict $ markupInput sm html2textlines sm = T.lines . LT.toStrict $ markupInput sm
makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal makeRenewalForm :: Maybe MetaPinRenewal -> Form MetaPinRenewal
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateMetaPinRenewal $ \html -> do
now_day <- utctDay <$> liftIO getCurrentTime
flip (renderAForm FormStandard) html $ MetaPinRenewal flip (renderAForm FormStandard) html $ MetaPinRenewal
<$> aopt textField (fslI MsgMppDate) (mppDate <$> tmpl) <$> areq textField (fslI MsgMppRecipient) (mppRecipient <$> tmpl)
<*> aopt textField (fslI MsgMppURL) (mppURL <$> tmpl) <*> areq htmlField (fslI MsgMppAddress) (mppAddress <$> tmpl)
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl) <*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
<*> areq textField (fslI MsgMppPin) (mppPin <$> tmpl) <*> areq textField (fslI MsgMppPin) (mppPin <$> tmpl)
<*> areq textField (fslI MsgMppRecipient) (mppRecipient <$> tmpl) <*> aopt urlField (fslI MsgMppURL) (mppURL <$> tmpl)
<*> areq htmlField (fslI MsgMppAddress) (mppAddress <$> tmpl) <*> areq dayField (fslI MsgMppDate) ((mppDate <$> tmpl) <|> Just now_day)
<*> areq textField (fslI MsgMppLang) ((mppLang <$> tmpl) <|> Just "de-de") <*> 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 :: FormValidator MetaPinRenewal Handler ()
validateMetaPinRenewal = do validateMetaPinRenewal = do
MetaPinRenewal{..} <- State.get MetaPinRenewal{..} <- State.get
guardValidation MsgMppBadLanguage $ guardValidation MsgMppBadLanguage $ isDe mppLang || isEn mppLang
isPrefixOf "de" mppLang
|| isPrefixOf "en" mppLang
getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR, postPrintCenterR :: Handler Html
getPrintCenterR = postPrintCenterR getPrintCenterR = postPrintCenterR
postPrintCenterR = do postPrintCenterR = do
{-
((presult, pwidget), penctype) <- runFormPost $ makeRenewalForm Nothing
let procFormPerson fr = do
res <- runAvsPersonSearch fr
case res of
Left err -> return $ Just err
Right jsn -> return $ Just $ tshow jsn
mbPerson <- formResultMaybe presult procFormPerson
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
let procFormStatus fr = do
res <- runAvsStatusSearch fr
case res of
Left err -> return $ Just err
Right jsn -> return $ Just $ tshow jsn
mbStatus <- formResultMaybe sresult procFormStatus
-}
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuApc $ do siteLayoutMsg MsgMenuApc $ do
setTitleI MsgMenuApc setTitleI MsgMenuApc
{- $(widgetFile "print-center")
let personForm = wrapForm pwidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = penctype
}
statusForm = wrapForm swidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = senctype
}
-}
let personForm = [whamlet|TODO|]
mbPerson = Just ("Not yet implemented"::Text)
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "apc")
getPrintSendR, postPrintSendR:: Handler Html getPrintSendR, postPrintSendR:: Handler Html
getPrintSendR = postPrintSendR getPrintSendR = postPrintSendR
postPrintSendR = do postPrintSendR = do
siteLayoutMsg MsgMenuPrintSend $ do ((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm Nothing
setTitleI MsgMenuPrintSend let procFormSend MetaPinRenewal{..} = do
{- addMessage Info . toHtml $ "Brief wird gesendet an " <> mppRecipient
let personForm = wrapForm pwidget def -- TODO: continue here with acutal letter sending!
{ formAction = Just $ SomeRoute actionUrl return $ Just ()
, formEncoding = penctype mbPdfLink <- formResultMaybe sendResult procFormSend
} -- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
statusForm = wrapForm swidget def siteLayoutMsg MsgMenuPrintSend $ do
{ formAction = Just $ SomeRoute actionUrl setTitleI MsgMenuPrintSend
, formEncoding = senctype let sendForm = wrapForm sendWidget def
} { formEncoding = sendEnctype
-} -- , formAction = Just $ SomeRoute actionUrl
let personForm = [whamlet|TODO|] }
mbPerson = Just ("Not yet implemented"::Text) -- TODO: use i18nWidgetFile instead if this is to become permanent
-- TODO: use i18nWidgetFile instead if this is to become permanent $(widgetFile "print-send")
$(widgetFile "apc")

12
src/Jobs/Handler/LMS.hs
View File

@ -49,12 +49,12 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
case qualificationRefreshWithin quali of case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid Nothing -> return () -- no automatic scheduling for this qid
(Just renewalPeriod) -> do (Just renewalPeriod) -> do
let nowaday = utctDay now let now_day = utctDay now
renewalDate = addGregorianDurationClip renewalPeriod nowaday renewalDate = addGregorianDurationClip renewalPeriod now_day
renewalUsers <- E.select $ do renewalUsers <- E.select $ do
quser <- E.from $ E.table @QualificationUser quser <- E.from $ E.table @QualificationUser
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
E.&&. E.notExists (do E.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser luser <- E.from $ E.table @LmsUser
@ -130,8 +130,8 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
case qualificationRefreshWithin quali of case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid Nothing -> return () -- no automatic scheduling for this qid
(Just renewalPeriod) -> do (Just renewalPeriod) -> do
nowaday <- utctDay <$> liftIO getCurrentTime now_day <- utctDay <$> liftIO getCurrentTime
let renewalDate = addGregorianDurationClip renewalPeriod nowaday let renewalDate = addGregorianDurationClip renewalPeriod now_day
-- CONTINUE HERE: -- CONTINUE HERE:
-- select users that need renewal due to success -- select users that need renewal due to success
@ -144,7 +144,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
) )
E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification E.where_ $ E.val qid E.==. quser E.^. QualificationUserQualification
E.&&. E.val qid E.==. luser E.^. LmsUserQualification E.&&. E.val qid E.==. luser E.^. LmsUserQualification
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday -- still valid E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day -- still valid
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate -- due to renewal
E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known
pure (quser, luser) pure (quser, luser)

5
src/Utils/Lang.hs
View File

@ -25,6 +25,11 @@ import qualified Data.HashMap.Strict as HashMap
import Data.Containers.ListUtils import Data.Containers.ListUtils
isDe :: Lang -> Bool
isDe = isPrefixOf "de"
isEn :: Lang -> Bool
isEn = isPrefixOf "en"
selectLanguage :: MonadHandler m selectLanguage :: MonadHandler m
=> NonEmpty Lang -- ^ Available translations, first is default => NonEmpty Lang -- ^ Available translations, first is default

5
src/Utils/Print.hs
View File

@ -4,7 +4,7 @@ import Import.NoModel
-- import qualified Data.Foldable as Fold -- import qualified Data.Foldable as Fold
-- hiding (foldr) import Data.Foldable (foldr) -- hiding (foldr) import Data.Foldable (foldr)
import qualified Data.Text as T -- import qualified Data.Text as T
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Control.Monad.Except import Control.Monad.Except
import Import hiding (embedFile) import Import hiding (embedFile)
@ -74,8 +74,7 @@ addMeta m = appMeta (m <>)
setIsDeFromLang :: P.Meta -> P.Meta setIsDeFromLang :: P.Meta -> P.Meta
setIsDeFromLang m setIsDeFromLang m
| (Just (P.MetaString t)) <- P.lookupMeta "lang" m | (Just (P.MetaString t)) <- P.lookupMeta "lang" m
, T.isPrefixOf "de" t , isDe t = P.setMeta isde True m
= P.setMeta isde True m
| otherwise = P.deleteMeta isde m | otherwise = P.deleteMeta isde m
where where
isde = "is-de" isde = "is-de"

8
templates/apc.hamlet
View File

@ -1,8 +0,0 @@
<section>
<p>
Print Demo:
^{personForm}
$maybe answer <- mbPerson
<p>
Unverarbeitete Antwort: #
#{answer}

3
templates/print-center.hamlet Normal file
View File

@ -0,0 +1,3 @@
<section>
<p>
Hier soll bald eine Tabelle mit allen Druckaufträgen einsehbar sein.

12
templates/print-send.hamlet Normal file
View File

@ -0,0 +1,12 @@
<section>
<h2>
Vorfeldführerschein Renewal-Briefes versenden
<p>
^{sendForm}
$maybe pdfLink <- mbPdfLink
<section>
<h2>Soeben versendeter Brief
<p>
#{show pdfLink}
<p>
TODO: Hier Link auf generiertem Brief anzeigen