-- 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