-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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

module Handler.LMS.Learners
  ( getLmsLearnersR
  , getLmsLearnersDirectR
  )
  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.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

-- | 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 _ = mconcat
    [ single csvLmsIdent      MsgCsvColumnLmsIdent
    , single csvLmsPin        MsgCsvColumnLmsPin
    , single csvLmsResetPin   MsgCsvColumnLmsResetPin
    , single csvLmsDelete     MsgCsvColumnLmsDelete
    , single csvLmsStaff      MsgCsvColumnLmsStaff
    , single csvLmsResetTries MsgCsvColumnLmsResetTries
    , single csvLmsLock       MsgCsvColumnLmsLock
    ]
    where
      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
      single k v = singletonMap k [whamlet|_{v}|]



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 . Just $ SomeMessage MsgBoolIrrelevant)) (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
  cutoff <- liftHandler $ lmsDeletionDate auditDur
  return (qid, cutoff)

getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsLearnersR sid qsh = do
  lmsTable <- runDB $ do
    (qid, cutoff) <- getQidCutoff sid qsh    
    view _2 <$> mkUserTable sid qsh qid cutoff
  siteLayoutMsg MsgMenuLmsLearners $ do
    setTitleI MsgMenuLmsLearners
    lmsTable

getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsLearnersDirectR sid qsh = do
  $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid  
  (lms_users,cutoff) <- runDB $ do
    (qid, cutoff) <- getQidCutoff sid qsh    
    lms_users <- selectList [ LmsUserQualification ==. qid
                            , LmsUserEnded ==. Nothing
                            -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
                            ] [Asc LmsUserStarted, Asc LmsUserIdent]    
    return (lms_users, cutoff)

    {- 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
          }
      -}
  LmsConf{..} <- getsYesod $ view _appLmsConf  
  let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
      --csvRenderedHeader = lmsUserTableCsvHeader
      --cvsRendered = CsvRendered {..}
      csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users
      fmtOpts = (review csvPreset CsvPresetRFC)
                    { csvIncludeHeader  = lmsDownloadHeader
                    , csvDelimiter      = lmsDownloadDelimiter
                    , csvUseCrLf        = lmsDownloadCrLf
                    }
      csvOpts = def { csvFormat = fmtOpts }
  csvSheetName <- csvFilenameLmsUser qsh
  let nr  = length lms_users
      msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
  $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