chore(avs): lenses for virtual avs fields created

models/avs.model

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

models/company.model

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

models/users.model

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

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
 

src/Handler/Utils/Avs.hs

@@ -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!!!
+          let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here
-          -- oldAvsFirmInfo   <- hoistMaybe $ userAvsLastFirmInfo usravs   -- TODO this hoist maybe should not abort the entire synch!!!
+          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)
+              frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr avsFirmInfo oldAvsFirmInfo')
-              --           [ CheckAvsUpdate 
+                        [ 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 usrId $ usr_ups <> frm_ups
-          lift $ update uaId  avs_ups
+          lift $ update uaId    avs_ups
           return $ Set.singleton (apid, usrId)

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

src/Handler/Utils/Pandoc.hs

@@ -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
+  ( module Utils.Pandoc
-  , renderMarkdownWith, parseMarkdownWith
+  , htmlField, htmlFieldSmall
-  , htmlReaderOptions, markdownReaderOptions
+  , renderMarkdownWith, parseMarkdownWith  
-  , markdownWriterOptions, htmlWriterOptions
   ) 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

src/Handler/Utils/Profile.hs

@@ -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
+  ( module Utils.Mail
-  , validPostAddress  
+  , validDisplayName, checkDisplayName, fixDisplayName
-  , validEmail, validEmail', pickValidEmail, pickValidEmail'
+  , 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
+import Utils.Mail 
-
--- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
-stripFold :: Text -> Text 
-stripFold = Text.toCaseFold . Text.strip
 
 -- | 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)

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

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

src/Model/Types/Avs.hs

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

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
   }  
 
 

src/Utils.hs

@@ -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 (==',')

src/Utils/Mail.hs

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

src/Utils/Pandoc.hs

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

templates/course/user/profile.hamlet

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