-- SPDX-FileCopyrightText: 2022-2025 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter module Handler.Utils.LMS ( getLmsCsvDecoder , csvLmsIdent , csvLmsDate , csvLmsTimestamp , csvLmsBlocked , csvLmsSuccess , csvLmsPin , csvLmsResetPin , csvLmsDelete , csvLmsStaff , csvLmsResetTries , csvLmsLock , csvLmsResult , csvFilenameLmsUser , csvFilenameLmsReport , lmsDeletionDate , lmsUserToDelete , _lmsUserToDelete , lmsUserToDeleteExpr , lmsUserToResetTries , _lmsUserToResetTries , lmsUserToResetTriesExpr , lmsUserToLock , _lmsUserToLock , lmsUserToLockExpr , lmsUserStaff , _lmsUserStaff , lmsStatusInfoCell , lmsStatusIcon, lmsUserStatusWidget , randomLMSIdent, randomLMSIdentBut , randomLMSpw, maxLmsUserIdentRetries ) where -- general utils for LMS Interface Handlers import Import import Handler.Utils.DateTime import Handler.Utils.Csv import Data.Csv (HasHeader(..), FromRecord) import qualified Data.Text as Text import qualified Data.Set as Set (notMember) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => Handler (ConduitT ByteString csv m ()) getLmsCsvDecoder = do LmsConf{..} <- getsYesod $ view _appLmsConf if | Just upDelim <- lmsUploadDelimiter -> do let fmtOpts = (review csvPreset CsvPresetRFC) { csvDelimiter = upDelim , csvIncludeHeader = lmsUploadHeader } csvOpts = def { csvFormat = fmtOpts } return $ decodeCsvWith csvOpts | lmsUploadHeader -> return decodeCsv | otherwise -> return $ decodeCsvPositional NoHeader -- generic Column names csvLmsIdent :: IsString a => a csvLmsIdent = fromString "user" -- "Benutzerkennung" V1, V2 csvLmsDate :: IsString a => a csvLmsDate = fromString "date" -- "Datum", V2 csvLmsTimestamp :: IsString a => a csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" V1 -- for Users Table csvLmsPin :: IsString a => a csvLmsPin = fromString "pin" -- "PIN" V1, V2 csvLmsResetPin :: IsString a => a csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen" V1, V2 csvLmsDelete :: IsString a => a csvLmsDelete = fromString "delete" -- "Account löschen" V1, V2 csvLmsStaff :: IsString a => a csvLmsStaff = fromString "staff" -- "Mitarbeiter" V1, V2 csvLmsResetTries :: IsString a => a csvLmsResetTries = fromString "reset_tries" -- Anzahl Versuche zurücksetzen, V2 csvLmsLock :: IsString a => a csvLmsLock = fromString "lock" -- Ist der Login derzeit gesperrt? V2 -- for Userlist Table V1 csvLmsBlocked :: IsString a => a csvLmsBlocked = fromString "blocked" -- "Sperrung" V1 -- for Result Table V1 csvLmsSuccess :: IsString a => a csvLmsSuccess = fromString "success" -- "Datum" V1 -- for Report Table V2 csvLmsResult :: IsString a => a csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offen, 2=Bestanden V2 -- | Filename for User transmission, contains current datestamp as agreed in LMS interface V1 & V2 csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUser = makeLmsFilename "user" -- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2 csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsReport = makeLmsFilename "report" -- | Create filenames as specified by the LMS interface agreed with Know How AG makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text makeLmsFilename ftag (citext2lower -> qsh) = do ymth <- getYMTH return $ "fradrive_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv" -- | Return current datetime in YYYYMMDDHH format getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime -- | Given QualificationAuditDuration and current time, determine time to signal the deletion of an LMS User to the e-learning server. Note that the e-learning server ought to delete LMS users on its own now. lmsDeletionDate :: UTCTime -> Int -> UTCTime lmsDeletionDate now qualiAuditDuration = addDiffDaysRollOver (fromDays $ negate qualiAuditDuration) now -- | Decide whether LMS platform should delete an identifier lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr cutoff lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.isJust (lmslist E.^. LmsUserStatus) E.&&. E.isJust (lmslist E.^. LmsUserStatusDay) E.&&. lmslist E.^. LmsUserStatusDay E.<=. E.justVal cutoff -- | Is everything since cutoff day or before? lmsUserToDelete :: UTCTime -> LmsUser -> Bool lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay=Just lstat} = lstat <= cutoff lmsUserToDelete _ _ = False _lmsUserToDelete :: UTCTime -> Getter LmsUser Bool _lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff lmsUserToResetTriesExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToResetTriesExpr luser = (luser E.^. LmsUserResetTries) E.&&. (luser E.^. LmsUserLocked) E.&&. ((luser E.^. LmsUserStatus) `E.in_` E.justValList [LmsBlocked, LmsExpired]) lmsUserToResetTries :: LmsUser -> Bool lmsUserToResetTries LmsUser{..} = lmsUserResetTries && lmsUserLocked && (lmsUserStatus == Just LmsBlocked || lmsUserStatus == Just LmsExpired) -- only reset blocked learners _lmsUserToResetTries :: Getter LmsUser Bool _lmsUserToResetTries = to lmsUserToResetTries -- | Answers "Should the LMS lock a user out?" -- Note that LmsUserLocked only logs the current LMS state, not what it should be. lmsUserToLockExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToLockExpr luser = E.isJust (luser E.^. LmsUserStatus) lmsUserToLock :: LmsUser -> Bool lmsUserToLock LmsUser{..} = isJust lmsUserStatus -- only open LMS should be accessible _lmsUserToLock :: Getter LmsUser Bool _lmsUserToLock = to lmsUserToLock lmsUserStaff :: LmsUser -> Bool lmsUserStaff = const False -- legacy, currently ignored _lmsUserStaff :: Getter LmsUser Bool _lmsUserStaff = to lmsUserStaff -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? lengthIdent :: Int lengthIdent = 8 lengthPassword :: Int lengthPassword = 8 -- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent maxLmsUserIdentRetries :: Int maxLmsUserIdentRetries = 27 --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though -- import qualified Data.Elocrypt as Elo -- randomLMSIdent :: MonadRandom m => m LmsIdent -- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt -- where -- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent randomLMSIdent Nothing = LmsIdent . Text.cons 'j' <$> randomText [] (pred lengthIdent) -- idents must not contain '_' nor '-' randomLMSIdent (Just c) = LmsIdent . Text.cons c <$> randomText [] (pred lengthIdent) randomLMSIdentBut :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent) randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk where getIdentOk = do l <- randomLMSIdent prefix return $ toMaybe (Set.notMember l banList) l randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_' randomLMSpw = randomText extra lengthPassword where extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters lmsStatusInfoCell :: Bool -> Int -> Widget lmsStatusInfoCell extendedInfo lmsAuditDays = [whamlet|$newline never

_{MsgTableLmsStatusTooltip lmsAuditDays}

$if extendedInfo
^{icon IconPlanned}
_{MsgLmsStatusPlanned}
^{icon IconNotificationSent}
_{MsgLmsStatusNotificationSent}
^{icon IconNotOK}
_{MsgLmsStatusBlocked}
^{icon IconExpired}
_{MsgLmsStatusExpired}
^{icon IconOK}
_{MsgLmsStatusSuccess} $if extendedInfo
^{icon IconLocked}
_{MsgLmsStatusLocked}
^{icon IconUnlocked}
_{MsgLmsStatusUnlocked}
^{icon IconResetTries}
_{MsgLmsStatusResetTries}

_{MsgLmsStatusDelay} |] lmsStatusIcon :: LmsStatus -> Icon lmsStatusIcon LmsSuccess{} = IconOK lmsStatusIcon LmsExpired{} = IconExpired lmsStatusIcon _other = IconNotOK lmsUserStatusWidget :: Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> Widget lmsUserStatusWidget adminInfo mbLink luser = case luser of LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} -> [whamlet|$newline never ^{dateWgt mbDay} \ ^{iconFixed (lmsStatusIcon lStat)} $if adminInfo \ ^{lockIcon} \ ^{resetIcon} |] LmsUser{lmsUserNotified=mbDay@(Just _)} -> [whamlet|$newline never ^{dateWgt mbDay} \ ^{iconFixed IconNotificationSent} $if adminInfo \ ^{lockIcon} \ ^{resetIcon} |] LmsUser{lmsUserStarted=dstart} | adminInfo -> -- E-Learning started, but not yet notified; only intended for Admins; [whamlet|$newline never ^{dateWgt (Just dstart)} \ ^{iconFixed IconPlanned} $if adminInfo \ ^{resetIcon} |] -- would always display Iconlocked _ -> mempty where lockIcon | lmsUserLocked luser == lmsUserToLock luser = mempty | lmsUserLocked luser = iconFixed IconLocked | otherwise = iconFixed IconUnlocked resetIcon | lmsUserResetTries luser = iconFixed IconResetTries | otherwise = mempty dateWgt :: Maybe UTCTime -> Widget dateWgt = let mkDayWgt = maybe (text2widget "--.--.----") (formatTimeW SelFormatDateTime) in case mbLink of Nothing -> mkDayWgt (Just mkLink) -> \mbDay -> do uuid <- liftHandler $ encrypt $ luser ^. _lmsUserUser modal (mkDayWgt mbDay) $ Left $ SomeRoute $ mkLink uuid