276 lines
10 KiB
Haskell
276 lines
10 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 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
|
|
, lmsUserToLock
|
|
, 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
|
|
|
|
--
|
|
lmsDeletionDate :: Handler Day
|
|
lmsDeletionDate = do
|
|
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
|
|
addDays (fromIntegral $ negate lmsDeletionDays) . utctDay <$> liftIO getCurrentTime
|
|
|
|
-- | Decide whether LMS platform should delete an identifier
|
|
lmsUserToDeleteExpr :: Day -> 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 :: Day -> LmsUser -> Bool
|
|
lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatusDay= Just lstat} = lstat < cutoff
|
|
lmsUserToDelete _ _ = False
|
|
|
|
_lmsUserToDelete :: Day -> Getter LmsUser Bool
|
|
_lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff
|
|
|
|
|
|
lmsUserToResetTries :: LmsUser -> Bool
|
|
lmsUserToResetTries LmsUser{..} = lmsUserResetTries && lmsUserLocked &&
|
|
(lmsUserStatus == Just LmsBlocked || lmsUserStatus == Just LmsExpired)
|
|
-- only reset blocked learners
|
|
|
|
-- | Answers "Should the LMS lock a user out?"
|
|
-- Note that LmsUserLocked only logs the current LMS state, not what it should be.
|
|
lmsUserToLock :: LmsUser -> Bool
|
|
lmsUserToLock LmsUser{..} = isJust lmsUserStatus -- only open LMS should be accessible
|
|
|
|
lmsUserStaff :: LmsUser -> Bool
|
|
lmsUserStaff = const False -- legacy, currently ignored
|
|
|
|
-- 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'] ++ ['j','k'] ++ ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j
|
|
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 IconUndo}
|
|
<dd>_{MsgLmsStatusResetTries}
|
|
<p>
|
|
_{MsgLmsStatusDelay}
|
|
|]
|
|
|
|
lmsStatusIcon :: LmsStatus -> Icon
|
|
lmsStatusIcon LmsSuccess{} = IconOK
|
|
lmsStatusIcon LmsExpired{} = IconExpired
|
|
lmsStatusIcon _other = IconNotOK
|
|
|
|
lmsUserStatusWidget :: Bool -> LmsUser -> Widget
|
|
lmsUserStatusWidget isAdmin luser
|
|
| isAdmin = lmsUserStatusWidgetAux isAdmin luser <> toWidget lockIcon <> toWidget resetIcon
|
|
| otherwise = lmsUserStatusWidgetAux isAdmin luser
|
|
where
|
|
lmsUserStatusWidgetAux _ LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=Just aday} =
|
|
[whamlet|$newline never
|
|
^{formatTimeW SelFormatDate aday}
|
|
\ ^{iconFixed (lmsStatusIcon lStat)}
|
|
|]
|
|
-- previously: IconWaitingForUser for lmsUserStatus==Nothing
|
|
lmsUserStatusWidgetAux _ LmsUser{lmsUserNotified=Just d} =
|
|
[whamlet|$newline never
|
|
^{formatTimeW SelFormatDate d}
|
|
\ ^{iconFixed IconNotificationSent}
|
|
|]
|
|
lmsUserStatusWidgetAux True LmsUser{lmsUserStarted} = -- E-Learning started, but not yet notified; only intended for Admins
|
|
[whamlet|$newline never
|
|
^{formatTimeW SelFormatDate lmsUserStarted}
|
|
\ ^{iconFixed IconPlanned}
|
|
|]
|
|
lmsUserStatusWidgetAux _ _ = mempty
|
|
|
|
lockIcon
|
|
| lmsUserLocked luser == lmsUserToLock luser = mempty
|
|
| lmsUserLocked luser = iconFixed IconLocked
|
|
| otherwise = iconFixed IconUnlocked
|
|
|
|
resetIcon
|
|
| lmsUserResetTries luser = iconFixed IconUndo
|
|
| otherwise = mempty
|
|
|