-- SPDX-FileCopyrightText: 2022-23 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 import Control.Monad.Random.Class (uniform) import Control.Monad.Trans.Random (evalRandTIO) 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_" <> "test" <> "_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv" -- | Return current datetime in YYYYMMDDHH format getYMTH :: MonadHandler m => m Text getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime -- | Given the QualificationAuditDuration, determines the 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 lmsDeletionDate :: Maybe Int -> Handler UTCTime lmsDeletionDate mbMaxAuditMonths = do now <- liftIO getCurrentTime LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf let ldd = addDiffDaysRollOver (fromDays $ negate lmsDeletionDays) now return $ case mbMaxAuditMonths of Nothing -> ldd (Just maxAuditMonths) -> max ldd (addDiffDaysRollOver (fromMonths $ negate maxAuditMonths) 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 -- | Generate Random Text of specified length using numbers and lower case letters plus supplied extra characters randomText :: MonadIO m => String -> Int -> m Text randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range where num_letters = ['2'..'9'] ++ ['a'..'h'] ++ 'k' : ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j and read "ji", "jf" as ligatures "ij", "fj" so we eliminate j as well range = extra ++ num_letters --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 't' . Text.cons 'j' <$> randomText [] (pred $ pred lengthIdent) -- idents must not contain '_' nor '-' randomLMSIdent (Just c) = LmsIdent . Text.cons 't' . Text.cons c <$> randomText [] (pred $ 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 -> Maybe Int -> Widget lmsStatusInfoCell extendedInfo auditMonths = [whamlet|$newline never

_{MsgTableLmsStatusTooltip auditMonths}

$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