-- 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
  , csvFilenameLmsUserlist
  , csvFilenameLmsResult
  , 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.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

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