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

chore(avs): lenses for virtual avs fields created

Browse Source
This commit is contained in:
Steffen Jost 2024-01-17 16:14:21 +01:00
parent 45c3f11a83
commit e8d66a4734
16 changed files with 184 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/avs.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

4
models/company.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

4
models/users.model
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

2
src/Handler/Course/User.hs
View File

@ -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

25
src/Handler/Utils/Avs.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>
--
-- 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)

10
src/Handler/Utils/Mail.hs
View File

@ -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|
<h2>_{MsgMailSupervisedNote}
<p>

28
src/Handler/Utils/Pandoc.hs
View File

@ -1,17 +1,18 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
--
-- 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

41
src/Handler/Utils/Profile.hs
View File

@ -1,13 +1,13 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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)

2
src/Handler/Utils/Users.hs
View File

@ -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{..}

4
src/Jobs/Handler/QueueNotification.hs
View File

@ -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

43
src/Model/Types/Avs.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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"

5
src/Model/Types/Markup.hs
View File

@ -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
}

11
src/Utils.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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 (==',')

44
src/Utils/Mail.hs Normal file
View File

@ -0,0 +1,44 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- 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

43
src/Utils/Pandoc.hs Normal file
View File

@ -0,0 +1,43 @@
-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
--
-- 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

4
templates/course/user/profile.hamlet
View File

@ -1,6 +1,6 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
$# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
@ -24,7 +24,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
<dt .deflist__dt>_{MsgTableSex}
<dd .deflist__dd>_{sex}
<dt .deflist__dt>_{MsgTableEmail}
<dd .deflist__dd>#{mailtoHtml (pickValidEmail userDisplayEmail userEmail)}
<dd .deflist__dd>#{mailtoHtml (pickValidUserEmail userDisplayEmail userEmail)}
$maybe date <- mRegAt
<dt .deflist__dt>_{MsgRegisteredSince}
<dd .deflist__dd>#{date}