diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index f274f32ad..825090d52 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -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") diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index e4ad4cb0a..4d550f650 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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) diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs index ad83921c1..e5dc649e3 100644 --- a/src/Utils/Lang.hs +++ b/src/Utils/Lang.hs @@ -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 diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index d2b34cc5c..a07d64b5e 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -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" diff --git a/templates/apc.hamlet b/templates/apc.hamlet deleted file mode 100644 index b696a644a..000000000 --- a/templates/apc.hamlet +++ /dev/null @@ -1,8 +0,0 @@ -
-

- Print Demo: - ^{personForm} - $maybe answer <- mbPerson -

- Unverarbeitete Antwort: # - #{answer} \ No newline at end of file diff --git a/templates/print-center.hamlet b/templates/print-center.hamlet new file mode 100644 index 000000000..df9d1833e --- /dev/null +++ b/templates/print-center.hamlet @@ -0,0 +1,3 @@ +

+

+ Hier soll bald eine Tabelle mit allen Druckaufträgen einsehbar sein. \ No newline at end of file diff --git a/templates/print-send.hamlet b/templates/print-send.hamlet new file mode 100644 index 000000000..1ce1521f6 --- /dev/null +++ b/templates/print-send.hamlet @@ -0,0 +1,12 @@ +

+

+ Vorfeldführerschein Renewal-Briefes versenden +

+ ^{sendForm} +$maybe pdfLink <- mbPdfLink +

+

Soeben versendeter Brief +

+ #{show pdfLink} +

+ TODO: Hier Link auf generiertem Brief anzeigen \ No newline at end of file