154 lines
5.4 KiB
Haskell
154 lines
5.4 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
|
|
, csvLmsTimestamp
|
|
, csvLmsBlocked
|
|
, csvLmsSuccess
|
|
, csvLmsPin
|
|
, csvLmsResetPin
|
|
, csvLmsDelete
|
|
, csvLmsStaff
|
|
, csvFilenameLmsUser
|
|
, csvFilenameLmsUserlist
|
|
, csvFilenameLmsResult
|
|
, lmsUserToDelete, _lmsUserToDelete
|
|
, lmsUserToDeleteExpr
|
|
, randomLMSIdent, randomLMSIdentBut
|
|
, randomLMSpw, maxLmsUserIdentRetries
|
|
) where
|
|
|
|
-- general utils for LMS Interface Handlers
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Csv
|
|
import Data.Csv (HasHeader(..), FromRecord)
|
|
|
|
import qualified Data.Set as Set (notMember)
|
|
import qualified Database.Esqueleto.Legacy 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 = def { 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"
|
|
|
|
csvLmsTimestamp :: IsString a => a
|
|
csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel"
|
|
|
|
-- for Users Table
|
|
csvLmsPin :: IsString a => a
|
|
csvLmsPin = fromString "pin" -- "PIN"
|
|
|
|
csvLmsResetPin :: IsString a => a
|
|
csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen"
|
|
|
|
csvLmsDelete :: IsString a => a
|
|
csvLmsDelete = fromString "delete" -- "Account löschen"
|
|
|
|
csvLmsStaff :: IsString a => a
|
|
csvLmsStaff = fromString "staff" -- "Mitarbeiter"
|
|
|
|
-- for Userlist Table
|
|
csvLmsBlocked :: IsString a => a
|
|
csvLmsBlocked = fromString "blocked" -- "Sperrung"
|
|
|
|
-- for Result Table
|
|
csvLmsSuccess :: IsString a => a
|
|
csvLmsSuccess = fromString "success" -- "Datum"
|
|
|
|
|
|
-- | Filename for User transmission, contains current datestamp as agreed in LMS interface
|
|
csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text
|
|
csvFilenameLmsUser = makeLmsFilename "user"
|
|
|
|
-- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface
|
|
csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text
|
|
csvFilenameLmsUserlist = makeLmsFilename "userliste"
|
|
|
|
-- | Filename for Result transmission, contains current datestamp as agreed in LMS interface
|
|
csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text
|
|
csvFilenameLmsResult = makeLmsFilename "ergebnisse"
|
|
|
|
-- | 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
|
|
|
|
-- | Deceide whether LMS platform should delete an identifier
|
|
lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
|
|
lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus)
|
|
|
|
lmsUserToDelete :: LmsUser -> Bool
|
|
lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus
|
|
|
|
_lmsUserToDelete :: Getter LmsUser Bool
|
|
_lmsUserToDelete = to lmsUserToDelete
|
|
|
|
|
|
-- 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 = ['0'..'9'] ++ ['a'..'z']
|
|
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
|
|
|
|
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
|
|
randomLMSpw = randomText extra lengthPassword
|
|
where
|
|
extra = "+*:=!?#&" -- you cannot distinguish ;: and ., in printed letters
|