Merge branch 'fradrive/tutorial-overhaul'

messages/uniworx/categories/courses/tutorial/de-de-formal.msg

@@ -45,5 +45,7 @@ TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium
 TutorialUserDeregister: Vom Tutorium Abmelden
 TutorialUserSendMail: Mitteilung verschicken
 TutorialUserGrantQualification: Qualifikation vergeben
+TutorialUserRenewQualification: Qualifikation regulär verlängern
+TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
 TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben
 CommTutorial: Tutorium-Mitteilung

messages/uniworx/categories/courses/tutorial/en-eu.msg

@@ -46,5 +46,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
 TutorialUserDeregister: Deregister from tutorial
 TutorialUserSendMail: Send mail
 TutorialUserGrantQualification: Grant Qualification
+TutorialUserRenewQualification: Renew Qualification
+TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 CommTutorial: Tutorial message

models/lms.model

@@ -57,7 +57,7 @@ QualificationEdit
 QualificationUser
   user              UserId OnDeleteCascade OnUpdateCascade
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  validUntil        Day
+  validUntil        Day                           -- addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
   lastRefresh       Day                           -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
   firstHeld         Day                           -- first time the qualification was earned, should never change
   blockedDue        QualificationBlocked Maybe    -- isJust means that the qualification is currently revoked

src/Audit/Types.hs

@@ -201,7 +201,7 @@ data Transaction
   | TransactionQualificationUserEdit
     { transactionQualificationUser            :: QualificationUserId
     , transactionQualification                :: QualificationId
-    , transactionUser                         :: UserId
+    , transactionUser                         :: UserId                 -- qualification holder that is updated
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
     }

src/Database/Esqueleto/Utils.hs

@@ -38,7 +38,7 @@ module Database.Esqueleto.Utils
   , unKey
   , selectCountRows, selectCountDistinct
   , selectMaybe
-  , day, diffDays, diffTimes
+  , day, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
   , module Database.Esqueleto.Utils.TH
@@ -65,6 +65,8 @@ import Crypto.Hash (Digest, SHA256)
 import Data.Coerce (Coercible)
 
 import Data.Time.Clock (NominalDiffTime)
+import Data.Time.Calendar (CalendarDiffDays)
+import Data.Time.Format.ISO8601 (iso8601Show)
 
 import qualified Data.Text.Lazy.Builder as Text.Builder
 
@@ -525,6 +527,14 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
 day = E.unsafeSqlCastAs "date"
 
+interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
+-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example 
+interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
+  where 
+    singleQuote     = Text.Builder.singleton '\''
+    wrapSqlString b = singleQuote <> b <> singleQuote
+
+
 infixl 6 `diffDays`, `diffTimes`
 
 diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)

src/Handler/Admin/Avs.hs

@@ -23,6 +23,7 @@ import qualified Data.Map as Map
 
 import Handler.Utils
 import Handler.Utils.Avs
+-- import Handler.Utils.Qualification
 
 import Utils.Avs
 

src/Handler/LMS.hs

@@ -46,7 +46,7 @@ import Handler.LMS.Userlist as Handler.LMS
 import Handler.LMS.Result   as Handler.LMS
 import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
 
-import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
+-- import Handler.Utils.Qualification (validQualification)
 
 -- avoids repetition of local definitions
 single :: (k,a) -> Map k a

src/Handler/Qualification.hs

@@ -35,7 +35,7 @@ import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
 
-import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
+-- import Handler.Utils.Qualification (validQualification)
 
 -- avoids repetition of local definitions
 single :: (k,a) -> Map k a
@@ -269,12 +269,13 @@ mkQualificationTable ::
               ( Functor h, ToSortable h
               , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool                                        QualificationTableData))) cols
               )
-           => Entity Qualification
+           => Bool
+           -> Entity Qualification
            -> Map QualificationTableAction (AForm Handler QualificationTableActionData)           
            -> cols
            -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
            -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
-mkQualificationTable (Entity qid quali) acts cols psValidator = do
+mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
   svs <- getSupervisees
   now <- liftIO getCurrentTime
   currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute
@@ -284,7 +285,7 @@ mkQualificationTable (Entity qid quali) acts cols psValidator = do
     csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
     dbtIdent :: Text
     dbtIdent = "qualification"
-    fltrSvs = \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
+    fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
     dbtSQLQuery q = qualificationTableQuery qid fltrSvs q
     dbtRowKey = queryUser >>> (E.^. UserId)
     dbtProj = dbtProjFilteredPostId
@@ -379,6 +380,7 @@ getQualificationR,  postQualificationR :: SchoolId -> QualificationShorthand ->
 getQualificationR = postQualificationR
 postQualificationR sid qsh = do
   currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
+  isAdmin <- hasReadAccessTo AdminR
   ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
     qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
     let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
@@ -388,7 +390,7 @@ postQualificationR sid qsh = do
           ]
         colChoices = mconcat
           [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
-          , colUserNameLinkHdr MsgLmsUser AdminUserR
+          , colUserNameLinkHdr MsgLmsUser ForProfileR
           , colUserEmail
           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
           , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
@@ -403,10 +405,9 @@ postQualificationR sid qsh = do
                                                                                        $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu
           ]
         psValidator = def
-    tbl <- mkQualificationTable qent acts colChoices psValidator
+    tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
     return (tbl, qent)
-
+  
-  isAdmin <- hasReadAccessTo AdminR
   formResult lmsRes $ \case
     _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now
     (action, selectedUsers) | isExpiryAct action -> do 

src/Handler/Tutorial/Users.hs

@@ -26,10 +26,11 @@ import Handler.Course.Users
 
 
 data TutorialUserAction
-   = TutorialUserGrantQualification
+  = TutorialUserRenewQualification
-   | TutorialUserSendMail
+  | TutorialUserGrantQualification
-   | TutorialUserDeregister
+  | TutorialUserSendMail
-   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  | TutorialUserDeregister
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe TutorialUserAction
 instance Finite TutorialUserAction
@@ -37,13 +38,15 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''TutorialUserAction id
 
 data TutorialUserActionData
-   = TutorialUserGrantQualificationData
+  = TutorialUserRenewQualificationData
-     { tuQualification :: QualificationId
+    { tuQualification :: QualificationId }
-     , tuValidUntil    :: Day
+  | TutorialUserGrantQualificationData
-     }
+    { tuQualification :: QualificationId
-   | TutorialUserSendMailData
+    , tuValidUntil    :: Day
-   | TutorialUserDeregisterData{}
+    }
-   deriving (Eq, Ord, Read, Show, Generic)
+  | TutorialUserSendMailData
+  | TutorialUserDeregisterData{}
+  deriving (Eq, Ord, Read, Show, Generic)
 
 
 getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
@@ -85,7 +88,11 @@ postTUsersR tid ssh csh tutn = do
           }
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList
-        [ ( TutorialUserGrantQualification
+        [ ( TutorialUserRenewQualification
+          , TutorialUserRenewQualificationData
+            <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
+          )
+        , ( TutorialUserGrantQualification
           , TutorialUserGrantQualificationData
             <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
             <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
@@ -103,6 +110,10 @@ postTUsersR tid ssh csh tutn = do
       runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
       addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
       redirect $ CTutorialR tid ssh csh tutn TUsersR
+    (TutorialUserRenewQualificationData{..}, selectedUsers) -> do
+      noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers      
+      addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
+      redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserSendMailData{}, selectedUsers) -> do
         cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
         redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])

src/Handler/Users.hs

@@ -296,6 +296,12 @@ postUsersR = do
                       E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId)
                         E.&&.  E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
             )
+          , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion ->
+              E.from $ \usrAvs -> -- do 
+                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user E.^.UserId
+                    E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
+                          (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
+            )
           ]
       , dbtFilterUI  = \mPrev -> mconcat
           [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField  (fslI MsgName)
@@ -303,6 +309,7 @@ postUsersR = do
           , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
           -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField  (fslI MsgTableMatrikelNr)          
           , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
+          , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
           , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment)
           , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
           , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)

src/Handler/Utils/Avs.hs

@@ -5,9 +5,11 @@
 {-# LANGUAGE TypeApplications #-}
 
 
+-- Module for functions directly related to the AVS interface,
+-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
+
 module Handler.Utils.Avs
-  ( validQualification, validQualification'
+  ( guessAvsUser
-  , guessAvsUser
   , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
   -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , AvsLicenceDifferences(..)
@@ -35,6 +37,7 @@ import qualified Data.CaseInsensitive as CI
 import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
 
 import Handler.Utils.Company
+import Handler.Utils.Qualification
 
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
@@ -63,21 +66,7 @@ instance Exception AvsException
   Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
 -}
 
-------------------
--- SQL Snippets --
-------------------
 
-validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
-validQualification nowaday = \qualUser ->
-  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
-                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
-           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            
-
-validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
-validQualification' nowaday qualUser =
-  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
-                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
-     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            
 
 
 ------------------

src/Handler/Utils/Qualification.hs

@@ -3,16 +3,54 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 
-
+module Handler.Utils.Qualification
-module Handler.Utils.Qualification 
   ( module Handler.Utils.Qualification
-  ) where 
+  ) where
 
 import Import
 
+-- import Data.Time.Calendar (CalendarDiffDays(..))
+import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Utils as E
+
+
+
+------------------
+-- SQL Snippets --
+------------------
+
+-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date
+validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
+validQualification nowaday = \qualUser ->
+  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
+                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
+           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            
+
+validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
+validQualification' nowaday qualUser =
+  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
+                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
+     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            
+
+
+selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser]
+selectValidQualifications qid mbUids nowaday = 
+  -- nowaday <- utctDay <$> liftIO getCurrentTime
+  E.select $ do 
+    qUser <- E.from $ E.table @QualificationUser
+    E.where_ $  (qUser E.^. QualificationUserQualification E.==. E.val qid)
+          E.&&. validQualification nowaday qUser
+          E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
+    pure qUser
+
+
+------------------------
+-- Complete Functions --
+------------------------
+
 
 upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
-upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do   
+upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
   Entity quid _ <- upsert
     QualificationUser
       { qualificationUserFirstHeld        = qualificationUserLastRefresh
@@ -20,18 +58,46 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
       , ..
       }
-    ( 
+    (
       [ QualificationUserScheduleRenewal    =. scheduleRenewal              | Just scheduleRenewal <- [mbScheduleRenewal]
       ] ++
       [ QualificationUserValidUntil         =. qualificationUserValidUntil
       , QualificationUserLastRefresh        =. qualificationUserLastRefresh
       , QualificationUserBlockedDue         =. Nothing
       ]
-    )    
+    )
   audit TransactionQualificationUserEdit
-    { transactionQualificationUser        = quid
+    { transactionQualificationUser            = quid
-    , transactionQualification            = qualificationUserQualification
+    , transactionQualification                = qualificationUserQualification
-    , transactionUser                     = qualificationUserUser
+    , transactionUser                         = qualificationUserUser
-    , transactionQualificationValidUntil  = qualificationUserValidUntil
+    , transactionQualificationValidUntil      = qualificationUserValidUntil
     , transactionQualificationScheduleRenewal = mbScheduleRenewal
-    }
+    }
+
+renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
+renewValidQualificationUsers qid uids =
+  -- This code works in principle, but it does not allow audit log entries.
+  -- E.update $ \qu -> do
+  --   E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
+  --   E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
+  --       E.&&.  (qu E.^. QualificationUserUser `E.in_` E.valList uids)
+  get qid >>= \case     
+    Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
+      nowaday <- utctDay <$> liftIO getCurrentTime
+      quEntsAll <- selectValidQualifications qid (Just uids) nowaday     
+      let maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
+          quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
+      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do 
+        let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil        
+        update quId [ QualificationUserValidUntil   =. newValidTo
+                    , QualificationUserLastRefresh  =. nowaday
+                    ]
+        audit TransactionQualificationUserEdit
+          { transactionQualificationUser            = quId
+          , transactionQualification                = qualificationUserQualification
+          , transactionUser                         = qualificationUserUser
+          , transactionQualificationValidUntil      = newValidTo
+          , transactionQualificationScheduleRenewal = Nothing
+          }
+      return $ length quEnts
+    _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.

src/Jobs/Handler/LMS.hs

@@ -70,6 +70,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                   E.&&. quser E.^. QualificationUserScheduleRenewal
                   E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day
                   E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
+                  E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue)
                   E.&&. E.notExists (do
                           luser <- E.from $ E.table @LmsUser
                           E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
@@ -208,12 +209,20 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
               newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
           note <- if saneDate && isLmsSuccess newStatus
             then do
+              -- TODO: refactor using functions from Handler.Utils.Qualification to ensure nothing is forgotten!
               update quid [ QualificationUserValidUntil  =. newValidTo
                           , QualificationUserLastRefresh =. lmsResultSuccess
-                          ]
+                          ]                    
               update luid [ LmsUserStatus   =. Just newStatus
                           , LmsUserReceived =. Just lmsResultTimestamp
                           ]
+              audit TransactionQualificationUserEdit
+                { transactionQualificationUser            = quid
+                , transactionQualification                = qualificationUserQualification
+                , transactionUser                         = qualificationUserUser
+                , transactionQualificationValidUntil      = newValidTo
+                , transactionQualificationScheduleRenewal = Nothing
+                }
               return Nothing
             else do
               let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]

src/Utils/Form.hs

@@ -855,6 +855,19 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
   where anySeparator :: Char -> Bool
         anySeparator c = C.isSeparator c || c == ',' || c == ';'
 
+-- Version that splits conditionally whether or not a separator is found:
+-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
+-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
+--   where splitConditionally :: Text -> [Text]
+--         splitConditionally t 
+--           | ';' `telem` t = T.split (==';') t
+--           | ',' `telem` t = T.split (==',') t
+--           | otherwise  = T.split C.isSeparator t 
+--         -- Our version of Data.Text does not yet support T.elem
+--         telem :: Char -> Text -> Bool
+--         telem c = T.any (==c)
+
+
 -- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
 -- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
 --   where splitConditionally :: Text -> [Text]