fradrive/src/Handler/Utils/LMS.hs

-- 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
  , lmsDeletionDate
  , lmsUserToDelete, _lmsUserToDelete
  , lmsUserToDeleteExpr
  , 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"

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

--
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.not_ (E.isNothing $ lmslist E.^. LmsUserStatus)
  E.&&. E.explicitUnsafeCoerceSqlExprValue "timestamp" ((lmslist E.^. LmsUserStatus) E.#>>. "{day}") E.<=. E.val cutoff
  
-- | Is everything since cutoff day or before?
lmsUserToDelete :: Day -> LmsUser -> Bool
lmsUserToDelete cutoff LmsUser{lmsUserEnded=Nothing, lmsUserStatus= Just lstat} = lmsStatusDay lstat < cutoff
lmsUserToDelete _ _ = False

_lmsUserToDelete :: Day -> Getter LmsUser Bool
_lmsUserToDelete cutoff = to $ lmsUserToDelete cutoff

-- 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'..'k'] ++ ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these
    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}
    <p>
      _{MsgLmsStatusDelay}
  |]

lmsStatusIcon :: LmsStatus -> Icon
lmsStatusIcon LmsSuccess{} = IconOK
lmsStatusIcon LmsExpired{} = IconExpired
lmsStatusIcon _other       = IconNotOK

lmsUserStatusWidget :: Bool -> LmsUser -> Widget
lmsUserStatusWidget _ LmsUser{lmsUserStatus=Just lStat} =
  [whamlet|$newline never
    ^{formatTimeW SelFormatDate (lmsStatusDay lStat)}
    \ ^{icon (lmsStatusIcon lStat)}
  |]
-- previously: IconWaitingForUser for lmsUserStatus==Nothing
lmsUserStatusWidget _ LmsUser{lmsUserNotified=Just d} =
  [whamlet|$newline never
    ^{formatTimeW SelFormatDate d}
    \ ^{icon IconNotificationSent}
  |]
lmsUserStatusWidget True LmsUser{lmsUserStarted} =  -- E-Learning started, but not yet notified; only intended for Admins
  [whamlet|$newline never
    ^{formatTimeW SelFormatDate lmsUserStarted}
    \ ^{icon IconPlanned}
  |]
lmsUserStatusWidget _ _ = mempty