-- SPDX-FileCopyrightText: 2023-2025 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances

module Handler.LMS.Learners
  ( getLmsLearnersR
  , getLmsLearnersDirectR
  , getLmsOrphansR
  )
  where


import Import

import Handler.Utils
import Handler.Utils.Csv
import Handler.Utils.LMS

import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E

data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
  { csvLUTident :: LmsIdent
  , csvLUTpin   :: Text
  , csvLUTresetPin, csvLUTdelete, csvLUTstaff -- V1
  , csvLUTresetTries, csvLUTlock :: LmsBool   -- V2
  }
  deriving Generic
makeLenses_ ''LmsUserTableCsv

lmsUserDelete2csv :: LmsIdent -> LmsUserTableCsv
lmsUserDelete2csv lid = LmsUserTableCsv
  { csvLUTident     = lid
  , csvLUTpin       = "00000000"
  , csvLUTresetPin  = LmsBool False
  , csvLUTdelete    = LmsBool $ isJust $ Text.find Char.isLetter $ getLmsIdent lid    -- safety-catch: do not delete LMS Test-users, FRADrive LMS Idents always contain at least one letter
  , csvLUTstaff     = LmsBool False
  , csvLUTresetTries= LmsBool False
  , csvLUTlock      = LmsBool True
  }

-- | Mundane conversion needed for direct download without dbTable only
lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv
lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv
  { csvLUTident     = lmsUserIdent
  , csvLUTpin       = lmsUserPin
  , csvLUTresetPin  = LmsBool  lmsUserResetPin
  , csvLUTdelete    = LmsBool (lmsUserToDelete cutoff lu)
  , csvLUTstaff     = LmsBool (lmsUserStaff lu)
  , csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended!
  , csvLUTlock      = LmsBool (lmsUserToLock lu)
  }

-- csv without headers
instance Csv.ToRecord   LmsUserTableCsv
instance Csv.FromRecord LmsUserTableCsv

-- csv with headers
lmsUserTableCsvHeader :: Csv.Header
lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff, csvLmsResetTries, csvLmsLock ]

instance ToNamedRecord LmsUserTableCsv where
  toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
    [ csvLmsIdent       Csv..= csvLUTident
    , csvLmsPin         Csv..= csvLUTpin
    , csvLmsResetPin    Csv..= csvLUTresetPin
    , csvLmsDelete      Csv..= csvLUTdelete
    , csvLmsStaff       Csv..= csvLUTstaff
    , csvLmsResetTries  Csv..= csvLUTresetTries
    , csvLmsLock        Csv..= csvLUTlock
    ]
instance FromNamedRecord LmsUserTableCsv where
  parseNamedRecord (lsfHeaderTranslate -> csv)
    = LmsUserTableCsv
        <$> csv Csv..: csvLmsIdent
        <*> csv Csv..: csvLmsPin
        <*> csv Csv..: csvLmsResetPin
        <*> csv Csv..: csvLmsDelete
        <*> csv Csv..: csvLmsStaff
        <*> csv Csv..: csvLmsResetTries
        <*> csv Csv..: csvLmsLock

instance CsvColumnsExplained LmsUserTableCsv where
  csvColumnsExplanations _ = Map.fromList
    [ (csvLmsIdent      , msg2widget MsgCsvColumnLmsIdent)
    , (csvLmsPin        , msg2widget MsgCsvColumnLmsPin)
    , (csvLmsResetPin   , msg2widget MsgCsvColumnLmsResetPin)
    , (csvLmsDelete     , msg2widget MsgCsvColumnLmsDelete)
    , (csvLmsStaff      , msg2widget MsgCsvColumnLmsStaff)
    , (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries)
    , (csvLmsLock       , msg2widget MsgCsvColumnLmsLock)
    ]


mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
mkUserTable _sid qsh qid cutoff = do
  dbtCsvName <- csvFilenameLmsUser qsh
  let dbtCsvSheetName = dbtCsvName
  let
    userDBTable = DBTable{..}
      where
        dbtSQLQuery lmsuser = do
          E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
              E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
          return lmsuser
        dbtRowKey = (E.^. LmsUserId)
        dbtProj = dbtProjId
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)      $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident
          , sortable (Just csvLmsPin)       (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
                                                                         )   $ \(view $ _dbrOutput . _entityVal . _lmsUserPin                  -> pin  ) -> textCell pin
          , sortable (Just csvLmsResetPin)  (i18nCell MsgTableLmsResetPin)   $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin             -> reset) -> ifIconCell reset IconReset
          , sortable (Just csvLmsDelete)    (i18nCell MsgTableLmsDelete)     $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff      -> del  ) -> ifIconCell del   IconRemoveUser
          , sortable Nothing                (i18nCell MsgTableLmsStaff)      $ \(view $ _dbrOutput . _entityVal . _lmsUserStaff                -> staff) -> ifIconCell staff IconOK
          , sortable (Just csvLmsResetTries)(i18nCell MsgTableLmsResetTries) $ \(view $ _dbrOutput . _entityVal . _lmsUserToResetTries         -> reset) -> ifIconCell reset IconResetTries
          , sortable (Just csvLmsLock)      (i18nCell MsgTableLmsLock)       $ \(view $ _dbrOutput . _entityVal . _lmsUserToLock               -> lock ) -> ifIconCell lock  IconLocked
          ]
        dbtSorting = Map.fromList
          [ (csvLmsIdent      , SortColumn (E.^. LmsUserIdent))
          , (csvLmsPin        , SortColumn (E.^. LmsUserPin))
          , (csvLmsResetPin   , SortColumn (E.^. LmsUserResetPin))
          , (csvLmsDelete     , SortColumn (lmsUserToDeleteExpr cutoff))
          -- , (csvLmsStaff   , E.false) -- currently always false
          , (csvLmsResetTries , SortColumn lmsUserToResetTriesExpr)
          , (csvLmsLock       , SortColumn lmsUserToLockExpr)
          ]
        dbtFilter = Map.fromList
          [ (csvLmsIdent    , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsUserIdent ))
          , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast                      (E.^. LmsUserResetPin))
          ]
        dbtFilterUI = \mPrev -> mconcat
          [ prismAForm (singletonFilter csvLmsIdent    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
          , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift boolField') (fslI MsgTableLmsResetPin)
          ]
        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "lms-user"
        dbtCsvEncode = Just DBTCsvEncode {..}
          where
            dbtCsvExportForm   = pure ()
            dbtCsvNoExportData = Just id
            dbtCsvExampleData  = Nothing
            dbtCsvHeader       = const $ return lmsUserTableCsvHeader
            dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
            doEncode' = LmsUserTableCsv
              <$> view (_dbrOutput . _entityVal . _lmsUserIdent)
              <*> view (_dbrOutput . _entityVal . _lmsUserPin)
              <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
              <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool)
              <*> view (_dbrOutput . _entityVal . to lmsUserStaff         . _lmsBool)
              <*> view (_dbrOutput . _entityVal . to lmsUserToResetTries  . _lmsBool)
              <*> view (_dbrOutput . _entityVal . to lmsUserToLock        . _lmsBool)

        dbtCsvDecode = Nothing
        dbtExtraReps = []

    userDBTableValidator = def
      & defaultSorting [SortAscBy csvLmsIdent]
  dbTable userDBTableValidator userDBTable

getQidCutoff ::  SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime)
getQidCutoff sid qsh = do
  Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh
  now <- liftIO getCurrentTime
  let cutoff = lmsDeletionDate now auditDur
  return (qid, cutoff)

getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsLearnersR sid qsh = do
  (lmsTable, nr_orphans) <- runDB $ do
    (qid, cutoff) <- getQidCutoff sid qsh
    lmsTable <- view _2 <$> mkUserTable sid qsh qid cutoff
    nr_orphans <- count [LmsOrphanQualification ==. qid]
    return (lmsTable, nr_orphans)
  when (nr_orphans > 0) $ addMessageI Warning $ MsgLmsOrphanNr nr_orphans
  siteLayoutMsg MsgMenuLmsLearners $ do
    setTitleI MsgMenuLmsLearners
    lmsTable


-- selectOrphans :: QualificationId -> UTCTime -> DB [(LmsOrphanId, LmsIdent)]
selectOrphans :: (MonadHandler m, HasAppSettings (HandlerSite m), BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
              => Key Qualification -> UTCTime -> ReaderT backend m [(LmsOrphanId, LmsIdent)]
selectOrphans qid now = do
    lmsConf <- getsYesod $ view _appLmsConf
    let cutoff_seen_first   = addLocalDays (negate $ lmsConf ^. _lmsOrphanDeletionDays) now
        cutoff_deleted_last = addHours     (negate $ lmsConf ^. _lmsOrphanRepeatHours)  now
        cutoff_seen_last    = cutoff_deleted_last
        orphan_max_batch    =                        lmsConf ^. _lmsOrphanDeletionBatch
    $(E.unValueN 2) <<$>> (Ex.select $ do
        orv <- Ex.from $ Ex.table @LmsOrphan
        Ex.where_ $ Ex.val qid                 E.==. orv Ex.^. LmsOrphanQualification
            Ex.&&.  E.hasLetter                     (orv Ex.^. LmsOrphanIdent)                        -- do not delete LMS Test-users, FRADrive LMS Idents always contain at least one letter
            Ex.&&.  Ex.val cutoff_seen_first   E.>=. orv Ex.^. LmsOrphanSeenFirst                     -- has been seen for while
            Ex.&&.  Ex.val cutoff_seen_last    E.<=. orv Ex.^. LmsOrphanSeenLast                      -- was still seen recently
            Ex.&&.  Ex.val cutoff_deleted_last E.>~. orv Ex.^. LmsOrphanDeletedLast                   -- not already recently deleted
            Ex.&&. Ex.notExists (do                                                                   -- not currently used anywhere (LmsIdent share the namespace)
                lusr <- Ex.from $ Ex.table @LmsUser
                Ex.where_ $ lusr Ex.^. LmsUserIdent E.==. orv Ex.^.LmsOrphanIdent
              )
        Ex.orderBy [Ex.desc $ orv Ex.^. LmsOrphanDeletedLast, Ex.asc $ orv Ex.^. LmsOrphanSeenLast]   -- Note for PostgreSQL: DESC == DESC NULLS FIRST
        Ex.limit orphan_max_batch
        return (orv E.^. LmsOrphanId, orv E.^. LmsOrphanIdent)
      )

getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsLearnersDirectR sid qsh = do
  -- $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
  (lms_users, orphans, cutoff, qshs) <- runDB $ do
    (qid, cutoff) <- getQidCutoff sid qsh
    qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] []
    let qids = qid : (entityKey <$> qidsReuse)
        qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse)
    lms_users <- selectList [ LmsUserQualification <-. qids
                            , LmsUserEnded ==. Nothing
                            -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
                            ] [Asc LmsUserStarted, Asc LmsUserIdent]
    {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
      Ex.select $ do
        lmsuser <- Ex.from $ Ex.table @LmsUser
        Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid
            Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded)
        pure $ LmsUserTableCsv
          { csvLUTident    = lmsuser Ex.^. LmsUserIdent
          , csvLUTpin      = lmsuser Ex.^. LmsUserPin
          , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
          , csvLUTdelete   = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus)
          , csvLUTstaff    = LmsBool False
          }
      -}
    now <- liftIO getCurrentTime
    orphans <- selectOrphans qid now
    updateWhere [LmsOrphanId <-. map fst orphans] [LmsOrphanDeletedLast =. Just now]
    return (lms_users, orphans, cutoff, qshs)

  LmsConf{..} <- getsYesod $ view _appLmsConf
  let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
      --csvRenderedHeader = lmsUserTableCsvHeader
      --cvsRendered = CsvRendered {..}
      csvRendered = toCsvRendered lmsUserTableCsvHeader $ (lmsUser2csv cutoff . entityVal <$> lms_users) <> (lmsUserDelete2csv . snd <$> orphans)
      fmtOpts = (review csvPreset CsvPresetRFC)
                    { csvIncludeHeader  = lmsDownloadHeader
                    , csvDelimiter      = lmsDownloadDelimiter
                    , csvUseCrLf        = lmsDownloadCrLf
                    }
      csvOpts = def { csvFormat = fmtOpts }
  csvSheetName <- csvFilenameLmsUser qsh
  let nr      = length lms_users
      orv_nr  = length orphans
      msg0 = "Success. LMS learners direct download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs)
      msg1 = ". Orphaned LMS idents marked for deletion: " <> tshow orv_nr
      msg  = if orv_nr > 0 then msg0 <> msg1 else msg1
  $logInfoS "LMS" msg
  addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
    <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "")
-- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod


getLmsOrphansR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsOrphansR sid qsh = do
  orvTable <- runDB $ do
    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
    let
      orvDBTable = DBTable{..}
        where
          queryOrphan  = id
          -- resultOrphan = _dbrOutput . _entityVal -- would need explicit type to work
          dbtSQLQuery orv = do
            E.where_ $ orv E.^. LmsOrphanQualification E.==. E.val qid
            return orv
          dbtRowKey = (E.^. LmsOrphanId)
          dbtProj = dbtProjId
          dbtColonnade = dbColonnade $ mconcat
            [ sortable (Just "ident")         (i18nCell MsgTableLmsIdent)        $ \(view $ _dbrOutput . _entityVal . _lmsOrphanIdent . _getLmsIdent -> lid) ->            textCell lid
            , sortable (Just "seen-first")    (i18nCell MsgLmsOrphanSeenFirst)   $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenFirst    -> d)           ->            dateTimeCell d
            , sortable (Just "seen-last")     (i18nCell MsgLmsOrphanSeenLast)    $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenLast     -> d)           ->            dateTimeCell d
            , sortable (Just "deleted-last")  (i18nCell MsgLmsOrphanDeletedLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanDeletedLast  -> d)           -> cellMaybe  dateTimeCell d
            , sortable (Just "status")        (i18nCell MsgTableLmsStatus)       $ \(view $ _dbrOutput . _entityVal . _lmsOrphanResultLast   -> s)           ->            lmsStateCell s
            , sortable (Just "reason")        (i18nCell MsgLmsOrphanReason)      $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason       -> t)           -> cellMaybe  textCell t
            ]
          dbtSorting  = Map.fromList
            [ ("ident"        , SortColumn (E.^. LmsOrphanIdent))
            , ("seen-first"   , SortColumn (E.^. LmsOrphanSeenFirst))
            , ("seen-last"    , SortColumn (E.^. LmsOrphanSeenLast))
            , ("deleted-last" , SortColumn (E.^. LmsOrphanDeletedLast))
            , ("status"       , SortColumn (E.^. LmsOrphanResultLast))
            , ("reason"       , SortColumn (E.^. LmsOrphanReason))
            ]
          cachedNextOrphans = $(memcachedByHere) (Just $ Right $ 1 * diffMinute) ("cache-next-orphans" <> tshow qid) $ do
            now <- liftIO getCurrentTime
            next_orphans <- runDBRead $ selectOrphans qid now   -- only query next orphans when really needed; not sure how to formulate a proper sub-query here
            -- addMessageI Info $ MsgLmsOrphanNr $ length next_orphans    -- debug
            return $ map fst next_orphans
          dbtFilter   = Map.fromList
            [ ("ident"        , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsOrphanIdent))
            , ("reason"       , FilterColumn $ E.mkContainsFilterWith          Just     (E.^. LmsOrphanReason))
            , ("preview"      , FilterColumnHandler $ \case
                (x:_)
                  | x == tshow True -> do
                      next_orphans <- cachedNextOrphans
                      return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.in_`   E.valList next_orphans
                  | x == tshow False -> do
                      next_orphans <- cachedNextOrphans
                      return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.notIn` E.valList next_orphans
                _ -> return (const E.true)
              )
            ]
          -- checkBoxTextField = convertField show (\case { t | t == show True -> True; _ -> False }) checkBoxField    -- UNNECESSARY hack to use FilterColumnHandler, which only works on [Text] criteria
          dbtFilterUI mPrev = mconcat
            [ -- prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr) -- NOTE: anticipated checkBoxTextField-hack not needed here
              prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt boolField'  (fslI MsgLmsOrphanPreviewFltr)
            , prismAForm (singletonFilter "reason"  . maybePrism _PathPiece) mPrev $ aopt textField   (fslI MsgLmsOrphanReason)
            , prismAForm (singletonFilter "ident"   . maybePrism _PathPiece) mPrev $ aopt textField   (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
            ]
          dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
          dbtParams = def
          dbtIdent :: Text
          dbtIdent = "lms-orphans"
          dbtCsvEncode = noCsvEncode
          dbtCsvDecode = Nothing
          dbtExtraReps = []
      orvDBTableValidator = def & defaultSorting [SortAscBy "seen-first", SortDescBy "deleted-last"]
    snd <$> (dbTable orvDBTableValidator orvDBTable :: DB (Any, Widget))

  LmsConf{..} <- getsYesod $ view _appLmsConf
  siteLayoutMsg MsgLmsOrphans $ do
    setTitleI MsgLmsOrphans
    $(i18nWidgetFile "lms-orphans")
