-- 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
  , 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.Text as Text

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 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 => Maybe Char -> m LmsIdent
randomLMSIdent Nothing  = LmsIdent . Text.cons 'j'  <$> randomText [] (pred lengthIdent) -- idents must not contain '_' nor '-'
randomLMSIdent (Just c) = LmsIdent . Text.cons  c   <$> randomText [] (pred lengthIdent)

randomLMSIdentBut :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent)
randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
  where
    getIdentOk = do
      l <- randomLMSIdent prefix
      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
