311 lines
12 KiB
Haskell
311 lines
12 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- 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
|
|
, csvFilenameLmsUserlist
|
|
, csvFilenameLmsResult
|
|
, 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.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 Userlist transmission, contains current datestamp as agreed in LMS interface V2
|
|
csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text
|
|
csvFilenameLmsUserlist = makeLmsFilename "userliste"
|
|
|
|
-- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1
|
|
csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text
|
|
csvFilenameLmsResult = makeLmsFilename "ergebnisse"
|
|
|
|
-- | 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 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 => m LmsIdent
|
|
randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not contain '_' nor '-'
|
|
|
|
randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent)
|
|
randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
|
|
where
|
|
getIdentOk = do
|
|
l <- randomLMSIdent
|
|
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
|
|
<p>
|
|
_{MsgTableLmsStatusTooltip auditMonths}
|
|
<p>
|
|
<dl .glossary>
|
|
$if extendedInfo
|
|
<dt>^{icon IconPlanned}
|
|
<dd>_{MsgLmsStatusPlanned}
|
|
<dt>^{icon IconNotificationSent}
|
|
<dd>_{MsgLmsStatusNotificationSent}
|
|
<dt>^{icon IconNotOK}
|
|
<dd>_{MsgLmsStatusBlocked}
|
|
<dt>^{icon IconExpired}
|
|
<dd>_{MsgLmsStatusExpired}
|
|
<dt>^{icon IconOK}
|
|
<dd>_{MsgLmsStatusSuccess}
|
|
$if extendedInfo
|
|
<dt>^{icon IconLocked}
|
|
<dd>_{MsgLmsStatusLocked}
|
|
<dt>^{icon IconUnlocked}
|
|
<dd>_{MsgLmsStatusUnlocked}
|
|
<dt>^{icon IconResetTries}
|
|
<dd>_{MsgLmsStatusResetTries}
|
|
<p>
|
|
_{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
|