diff --git a/models/avs.model b/models/avs.model index 5147f382e..30e5e8ea8 100644 --- a/models/avs.model +++ b/models/avs.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/models/company.model b/models/company.model index c022ad5f1..811af197d 100644 --- a/models/company.model +++ b/models/company.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,7 +9,7 @@ Company shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future avsId Int default=0 -- primary key from avs prefersPostal Bool default=false -- new company users prefers letters by post instead of email - postAddress StoredMarkup Maybe -- default company postal address + postAddress StoredMarkup Maybe -- default company postal address, including company name email UserEmail Maybe -- Case-insensitive generic company eMail address UniqueCompanyName name UniqueCompanyShorthand shorthand diff --git a/models/users.model b/models/users.model index 02f5f8af9..7ee24e9fb 100644 --- a/models/users.model +++ b/models/users.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -45,7 +45,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available pinPassword Text Maybe -- used to encrypt pins within emails - postAddress StoredMarkup Maybe + postAddress StoredMarkup Maybe -- including company name, if any postLastUpdate UTCTime Maybe -- record postal address updates prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index b7e54719c..b24dfd744 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -11,7 +11,7 @@ import Import import Utils.Form import Handler.Utils import Handler.Utils.SheetType -import Handler.Utils.Profile (pickValidEmail) +import Handler.Utils.Profile (pickValidUserEmail) import Handler.Utils.StudyFeatures import Handler.Submission.List diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 644f47af6..2d7084829 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -603,31 +603,34 @@ updateAvsUserByIds apids = do | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order) | otherwise = fmap maybeMonoid . runDB . runMaybeT $ do (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid - oldAvsPersonInfo <- hoistMaybe $ userAvsLastPersonInfo usravs -- TODO this hoist maybe should not abort the entire synch!!! - -- oldAvsFirmInfo <- hoistMaybe $ userAvsLastFirmInfo usravs -- TODO this hoist maybe should not abort the entire synch!!! + let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here + let oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here let usrId = userAvsUser usravs usr <- MaybeT $ get usrId now <- liftIO getCurrentTime - let usr_ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) + let usr_ups = maybeEmpty oldAvsPersonInfo $ \oldAvsPersonInfo' -> mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo') [ CheckAvsUpdate UserFirstName _avsInfoFirstName , CheckAvsUpdate UserSurname _avsInfoLastName , CheckAvsUpdate UserDisplayName _avsInfoDisplayName , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo + -- , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo ] - -- frm_ups = mapMaybe (mkUpdate usr avsFirmInfo oldAvsFirmInfo) - -- [ CheckAvsUpdate + frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr avsFirmInfo oldAvsFirmInfo') + [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup) - -- ] - avs_ups = [ UserAvsNoPerson =. api | Just api <- [readMay $ avsInfoPersonNo avsPersonInfo]] + ] + -- TODO: update Email + -- _avsFirmPrimaryEmail <|> _avsInfoPersonEMail + -- TODO: update Company + avs_ups = maybeToList ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo avsPersonInfo)) <> [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing , UserAvsLastPersonInfo =. Just avsPersonInfo , UserAvsLastFirmInfo =. Just avsFirmInfo ] - lift $ update usrId usr_ups - lift $ update uaId avs_ups + lift $ update usrId $ usr_ups <> frm_ups + lift $ update uaId avs_ups return $ Set.singleton (apid, usrId) diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 851928033..7511a9673 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -37,7 +37,7 @@ addRecipientsDB :: ( MonadMail m addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient where addRecipient (Entity _ User{userEmail, userDisplayEmail, userDisplayName}) = do - let addr = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + let addr = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail _mailTo %= flip snoc addr userAddressFrom :: User -> Address @@ -51,16 +51,16 @@ userAddress :: User -> Address -- -- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy. userAddress User{userEmail, userDisplayEmail, userDisplayName} - = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address -- Like userAddress', but does not require a complete entity userAddress' userEmail userDisplayEmail userDisplayName - = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address) userAddressError User{userEmail, userDisplayEmail, userDisplayName} - | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) + | Just okEmail <- pickValidUserEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) | otherwise = do $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " / " <> tshow userEmail <> ". Sent to support instead." -- <> " with subject " <> tshow failedSubject (False,) <$> getsYesod (view _appMailSupport) @@ -74,7 +74,7 @@ userMailT :: ( MonadHandler m userMailT uid mAct = do (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid let undername = underling ^. _userDisplayName -- nameHtml' underling - undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail) + undermail = CI.original $ pickValidUserEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail) infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|

_{MsgMailSupervisedNote}

diff --git a/src/Handler/Utils/Pandoc.hs b/src/Handler/Utils/Pandoc.hs index 797bcf625..c138f0a76 100644 --- a/src/Handler/Utils/Pandoc.hs +++ b/src/Handler/Utils/Pandoc.hs @@ -1,17 +1,18 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Pandoc - ( htmlField, htmlFieldSmall - , renderMarkdownWith, parseMarkdownWith - , htmlReaderOptions, markdownReaderOptions - , markdownWriterOptions, htmlWriterOptions + ( module Utils.Pandoc + , htmlField, htmlFieldSmall + , renderMarkdownWith, parseMarkdownWith ) where import Import.NoFoundation +import Utils.Pandoc import Handler.Utils.I18n + import qualified Data.Text as Text import qualified Data.Text.Lazy as LT @@ -86,20 +87,3 @@ plaintextToMarkdownWith writerOptions text = where logPandocError = $logErrorS "renderMarkdown" . tshow pandoc = P.Pandoc mempty [P.Plain [P.Str text]] - - -htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions -htmlReaderOptions = markdownReaderOptions -markdownReaderOptions = def - { P.readerExtensions = P.pandocExtensions - & P.enableExtension P.Ext_hard_line_breaks - & P.enableExtension P.Ext_autolink_bare_uris - , P.readerTabStop = 2 - } - -markdownWriterOptions, htmlWriterOptions :: P.WriterOptions -markdownWriterOptions = def - { P.writerExtensions = P.readerExtensions markdownReaderOptions - , P.writerTabStop = P.readerTabStop markdownReaderOptions - } -htmlWriterOptions = markdownWriterOptions diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 4f8e87546..ee321a491 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -1,13 +1,13 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later -- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? -- TODO: consider merging with Handler.Utils.Users? module Handler.Utils.Profile - ( validDisplayName, checkDisplayName, fixDisplayName - , validPostAddress - , validEmail, validEmail', pickValidEmail, pickValidEmail' + ( module Utils.Mail + , validDisplayName, checkDisplayName, fixDisplayName + , validPostAddress , validFraportPersonalNumber ) where @@ -16,16 +16,12 @@ import Import.NoFoundation import Data.Char import qualified Data.Text as Text import qualified Data.Text.Lazy as LT -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set -import qualified Text.Email.Validate as Email - --- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. -stripFold :: Text -> Text -stripFold = Text.toCaseFold . Text.strip +import Utils.Mail -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname". -- Input "givennames surname" is left unchanged, except for removing excess whitespace @@ -78,31 +74,6 @@ validPostAddress (Just StoredMarkup {markupInput = addr}) = True validPostAddress _ = False --- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type -validEmail :: Email -> Bool -- Email = Text -validEmail email = validRFC5322 && not invalidFraport - where - validRFC5322 = Email.isValid $ encodeUtf8 email - invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of - Just fralogin -> all isDigit $ drop 1 fralogin - Nothing -> False - -validEmail' :: UserEmail -> Bool -- UserEmail = CI Text -validEmail' = validEmail . CI.original - --- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function -pickValidEmail :: UserEmail -> UserEmail -> UserEmail -pickValidEmail x y - | validEmail' x = x - | otherwise = y - --- | returns first valid email address or none if none are valid -pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail -pickValidEmail' x y - | validEmail' x = Just x - | validEmail' y = Just y - | otherwise = Nothing - validFraportPersonalNumber :: Maybe Text -> Bool validFraportPersonalNumber Nothing = False validFraportPersonalNumber (Just t) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 5c85c9c73..223f58f28 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -86,7 +86,7 @@ getPostalPreferenceAndAddress usr@User{userPrefersPostal} = emailPossible = isJust $ getEmailAddress usr getEmailAddress :: User -> Maybe UserEmail -getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail +getEmailAddress User{userDisplayEmail, userEmail} = pickValidUserEmail' userDisplayEmail userEmail getPostalAddress :: User -> Maybe [Text] getPostalAddress User{..} diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index a4a407afa..6d1d5a317 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -16,7 +16,7 @@ import Jobs.Queue import qualified Data.Set as Set -import Handler.Utils.Profile (pickValidEmail') +import Handler.Utils.Profile (pickValidUserEmail') import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.ExternalExam @@ -28,7 +28,7 @@ dispatchJobQueueNotification jNotification = JobHandlerAtomic $ runConduit $ yield jNotification .| transPipe (hoist lift) determineNotificationCandidates .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) -> - and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $ + and2M (return $ isJust $ pickValidUserEmail' userDisplayEmail userEmail) $ or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification') .| sinkDBJobs diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 18388afb4..63fb8cf53 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -27,6 +27,7 @@ import qualified Data.Set as Set import Data.Aeson import Data.Aeson.Types +import Utils.Mail {- -- | Like (.:) but attempts parsing with case-insensitve keys as fallback. @@ -77,6 +78,22 @@ instance FromJSON SloppyBool where parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid +------------------------ +-- Specific Utilities -- +------------------------ + +composeAddress :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text +composeAddress street zipcode city country = toMaybe (notNull compAddr) compAddr + where + compAddr = textUnlines $ stripList [street, zipCity, country'] + zipCity = Just $ Text.unwords $ stripList [zipcode, city] + country' = case country of + (Just "Deutschland") -> Nothing -- letters sent by APC originate in Germany + other -> other + + stripList xs = [y | Just x <- xs, let y = Text.strip x, notNull y] + + ------------------- -- AVS Datatypes -- ------------------- @@ -552,6 +569,10 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where canonical other = other makeLenses_ ''AvsFirmCommunication +_avsCommunicationAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmCommunication (Maybe Text) +_avsCommunicationAddress = to mkAddr + where + mkAddr AvsFirmCommunication{..} = composeAddress avsCommunicationStreetANDHouseNo avsCommunicationZIPCode avsCommunicationCity avsCommunicationCountry instance FromJSON AvsFirmCommunication where parseJSON = withObject "AvsFirmCommunication" $ \o -> AvsFirmCommunication @@ -586,6 +607,26 @@ data AvsFirmInfo = AvsFirmInfo makeLenses_ ''AvsFirmInfo +-- | FirmAddress is never empty, since it always includes the company name +_avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text +_avsFirmAddress = to mkAddr + where + mkAddr AvsFirmInfo{..} = + let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry + commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress + in textUnlines $ avsFirmFirm : catMaybes [commAddr <|> firmAddr] + +_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +_avsFirmPrimaryEmail = to mkEmail + where + mkEmail afi = + let candidates = catMaybes + [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail + , afi ^. _avsFirmEMailSuperior + , afi ^. _avsFirmEMail + ] + in pickValidEmail candidates -- should we return an invalid email rather than none? + instance FromJSON AvsFirmInfo where parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo <$> o .: "Firm" diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index 0715b65b5..b2a22915d 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -32,6 +32,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Persist.Sql +import Utils.Pandoc data MarkupFormat = MarkupMarkdown @@ -67,7 +68,7 @@ plaintextToStoredMarkup :: Textual t => t -> StoredMarkup plaintextToStoredMarkup (repack -> t) = StoredMarkup { markupInputFormat = MarkupPlaintext , markupInput = t - , markupOutput = toMarkup t + , markupOutput = plaintextToHtml $ LT.toStrict t } preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup preEscapedToStoredMarkup (repack -> t) = StoredMarkup @@ -79,7 +80,7 @@ markdownToStoredMarkup :: Textual t => t -> StoredMarkup markdownToStoredMarkup (repack -> t) = StoredMarkup { markupInputFormat = MarkupMarkdown , markupInput = t - , markupOutput = toMarkup t -- not sure here + , markupOutput = plaintextToHtml $ LT.toStrict t } diff --git a/src/Utils.hs b/src/Utils.hs index 21cda5764..5ae894f30 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -305,6 +305,11 @@ tshowCrop = cropText . tshow stripCI :: Text -> CI Text stripCI = CI.mk . Text.strip +-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. +stripFold :: Text -> Text +stripFold = Text.toCaseFold . Text.strip + + -- | just to avoid adding an import for this ciOriginal :: CI Text -> Text ciOriginal = CI.original @@ -513,6 +518,10 @@ snakecase2camelcase t = Text.concat $ map textToCapital words words = Text.splitOn '_' t -} +-- | Unlike @Data.Text.unlines, there is no trailing LF at the end +textUnlines :: [Text] -> Text +textUnlines = Text.intercalate $ Text.singleton '\n' + -- also see Utils.Form.cfCommaSeparatedSet commaSeparatedText :: Text -> Set Text commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',') diff --git a/src/Utils/Mail.hs b/src/Utils/Mail.hs new file mode 100644 index 000000000..954ef207f --- /dev/null +++ b/src/Utils/Mail.hs @@ -0,0 +1,44 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Utils.Mail where + + +import Import.NoModel + +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import qualified Text.Email.Validate as Email + +-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type +validEmail :: Text -> Bool -- Email = Text +validEmail email = validRFC5322 && not invalidFraport + where + validRFC5322 = Email.isValid $ encodeUtf8 email + invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of + Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin + Nothing -> False + +validEmail' :: CI Text -> Bool -- UserEmail = CI Text +validEmail' = validEmail . CI.original + +-- | returns the first valid Email, if any +pickValidEmail :: [Text] -> Maybe Text +pickValidEmail = find validEmail + + +-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function +pickValidUserEmail :: CI Text -> CI Text -> CI Text +pickValidUserEmail x y + | validEmail' x = x + | otherwise = y + +-- | returns first valid email address or none if none are valid +pickValidUserEmail' :: CI Text -> CI Text -> Maybe (CI Text) +pickValidUserEmail' x y + | validEmail' x = Just x + | validEmail' y = Just y + | otherwise = Nothing \ No newline at end of file diff --git a/src/Utils/Pandoc.hs b/src/Utils/Pandoc.hs new file mode 100644 index 000000000..ad7582377 --- /dev/null +++ b/src/Utils/Pandoc.hs @@ -0,0 +1,43 @@ +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Utils.Pandoc where + + +import Import.NoModel + +import Data.Either (fromRight) +-- import qualified Data.Char as Char +-- import qualified Data.Text as Text +-- import qualified Data.CaseInsensitive as CI +import Text.Blaze (toMarkup) +import Text.Blaze.Html.Renderer.Text (renderHtml) +import qualified Text.Pandoc as P + + +markdownToHtml :: Html -> Either P.PandocError Html +markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html) + +plaintextToHtml :: Text -> Html +plaintextToHtml text = fromRight (toMarkup text) $ P.runPure $ + P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text + -- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code + -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]] + + +htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions +htmlReaderOptions = markdownReaderOptions +markdownReaderOptions = def + { P.readerExtensions = P.pandocExtensions + & P.enableExtension P.Ext_hard_line_breaks + & P.enableExtension P.Ext_autolink_bare_uris + , P.readerTabStop = 2 + } + +markdownWriterOptions, htmlWriterOptions :: P.WriterOptions +markdownWriterOptions = def + { P.writerExtensions = P.readerExtensions markdownReaderOptions + , P.writerTabStop = P.readerTabStop markdownReaderOptions + } +htmlWriterOptions = markdownWriterOptions \ No newline at end of file diff --git a/templates/course/user/profile.hamlet b/templates/course/user/profile.hamlet index b43e61c70..c18be7f33 100644 --- a/templates/course/user/profile.hamlet +++ b/templates/course/user/profile.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +$# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -24,7 +24,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

_{MsgTableSex}
_{sex}
_{MsgTableEmail} -
#{mailtoHtml (pickValidEmail userDisplayEmail userEmail)} +
#{mailtoHtml (pickValidUserEmail userDisplayEmail userEmail)} $maybe date <- mRegAt
_{MsgRegisteredSince}
#{date}