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
data MetaPinRenewal = MetaPinRenewal
{ mppDate :: Maybe Text
, mppURL :: Maybe Text
{ mppRecipient :: Text
, mppAddress :: StoredMarkup
, mppLogin :: Text
, mppPin :: Text
, mppRecipient :: Text
, mppAddress :: StoredMarkup
, mppLang :: Text
, mppURL :: Maybe URI
, mppDate :: Day
, 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 $ mconcat
[ mbMeta "date" mppDate
, mbMeta "url" mppURL
[ toMeta "recipient" mppRecipient
, toMeta "address" (mppAddress & html2textlines)
, toMeta "login" mppLogin
, toMeta "pin" mppPin
, toMeta "recipient" mppRecipient
, toMeta "address" (mppAddress & html2textlines)
, toMeta "lang" mppLang
]
, 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
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
<$> aopt textField (fslI MsgMppDate) (mppDate <$> tmpl)
<*> aopt textField (fslI MsgMppURL) (mppURL <$> tmpl)
<*> areq textField (fslI MsgMppLogin) (mppLogin <$> tmpl)
<*> areq textField (fslI MsgMppPin) (mppPin <$> tmpl)
<*> areq textField (fslI MsgMppRecipient) (mppRecipient <$> tmpl)
<*> areq htmlField (fslI MsgMppAddress) (mppAddress <$> tmpl)
<*> areq textField (fslI MsgMppLang) ((mppLang <$> tmpl) <|> Just "de-de")
<$> 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 $
isPrefixOf "de" mppLang
|| isPrefixOf "en" mppLang
guardValidation MsgMppBadLanguage $ isDe mppLang || isEn mppLang
getPrintCenterR, postPrintCenterR :: Handler Html
getPrintCenterR = postPrintCenterR
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
siteLayoutMsg MsgMenuApc $ do
setTitleI MsgMenuApc
{-
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")
$(widgetFile "print-center")
getPrintSendR, postPrintSendR:: Handler Html
getPrintSendR = postPrintSendR
postPrintSendR = do
siteLayoutMsg MsgMenuPrintSend $ do
setTitleI MsgMenuPrintSend
{-
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")
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm Nothing
let procFormSend MetaPinRenewal{..} = do
addMessage Info . toHtml $ "Brief wird gesendet an " <> mppRecipient
-- 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")

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

@ -49,12 +49,12 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid
(Just renewalPeriod) -> do
let nowaday = utctDay now
renewalDate = addGregorianDurationClip renewalPeriod nowaday
let now_day = utctDay now
renewalDate = addGregorianDurationClip renewalPeriod now_day
renewalUsers <- E.select $ do
quser <- E.from $ E.table @QualificationUser
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.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser
@ -130,8 +130,8 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
case qualificationRefreshWithin quali of
Nothing -> return () -- no automatic scheduling for this qid
(Just renewalPeriod) -> do
nowaday <- utctDay <$> liftIO getCurrentTime
let renewalDate = addGregorianDurationClip renewalPeriod nowaday
now_day <- utctDay <$> liftIO getCurrentTime
let renewalDate = addGregorianDurationClip renewalPeriod now_day
-- CONTINUE HERE:
-- 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.&&. 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.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success -- result already known
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
isDe :: Lang -> Bool
isDe = isPrefixOf "de"
isEn :: Lang -> Bool
isEn = isPrefixOf "en"
selectLanguage :: MonadHandler m
=> 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
-- 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 Control.Monad.Except
import Import hiding (embedFile)
@ -74,8 +74,7 @@ addMeta m = appMeta (m <>)
setIsDeFromLang :: P.Meta -> P.Meta
setIsDeFromLang m
| (Just (P.MetaString t)) <- P.lookupMeta "lang" m
, T.isPrefixOf "de" t
= P.setMeta isde True m
, isDe t = P.setMeta isde True m
| otherwise = P.deleteMeta isde m
where
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