-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@cip.ifi.lmu.de>,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.Report
  ( getLmsReportR, postLmsReportR
  , getLmsReportUploadR, postLmsReportUploadR
  , postLmsReportDirectR
  )
  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.Legacy as E
import qualified Database.Esqueleto.Utils as E

import Jobs.Queue


data LmsReportTableCsv = LmsReportTableCsv
  { csvLRident  :: LmsIdent
  , csvLRdate   :: Maybe LmsTimestamp
  , csvLRresult :: LmsState
  , csvLRlock   :: LmsBool
  }
  deriving Generic
makeLenses_ ''LmsReportTableCsv

-- csv without headers
instance Csv.ToRecord   LmsReportTableCsv -- default suffices
instance Csv.FromRecord LmsReportTableCsv -- default suffices

-- csv with headers
lmsReportTableCsvHeader :: Csv.Header
lmsReportTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsDate, csvLmsResult, csvLmsLock ]

instance ToNamedRecord LmsReportTableCsv where
  toNamedRecord LmsReportTableCsv{..} = Csv.namedRecord
    [ csvLmsIdent   Csv..= csvLRident
    , csvLmsDate    Csv..= csvLRdate
    , csvLmsResult  Csv..= csvLRresult
    , csvLmsLock    Csv..= csvLRlock
    ]

instance FromNamedRecord LmsReportTableCsv where
  parseNamedRecord (lsfHeaderTranslate -> csv)
    = LmsReportTableCsv
        <$> csv Csv..: csvLmsIdent
        <*> csv Csv..: csvLmsDate
        <*> csv Csv..: csvLmsResult
        <*> csv Csv..: csvLmsLock

instance CsvColumnsExplained LmsReportTableCsv where
  csvColumnsExplanations _ = mconcat
    [ single csvLmsIdent    MsgCsvColumnLmsIdent
    , single csvLmsDate     MsgCsvColumnLmsDate
    , single csvLmsResult   MsgCsvColumnLmsResult
    , single csvLmsLock     MsgCsvColumnLmsLock
    ]
    where
      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
      single k v = singletonMap k [whamlet|_{v}|]

data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate
  deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsReportCsvActionClass id

-- By coincidence the action type is identical to LmsReportTableCsv
data LmsReportCsvAction = LmsReportInsertData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe UTCTime, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool }
                        | LmsReportUpdateData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe UTCTime, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool }
  deriving (Eq, Ord, Read, Show, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsReportInsertData -> insert
  , fieldLabelModifier     = camelToPathPiece'  2     -- lmsReportCsvIdent -> csv-ident
  , sumEncoding = TaggedObject "action" "data"
  } ''LmsReportCsvAction

data LmsReportCsvException
  = LmsReportCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
  deriving (Show, Generic)

instance Exception LmsReportCsvException
embedRenderMessage ''UniWorX ''LmsReportCsvException id

mkReportTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkReportTable sid qsh qid = do
  now <- liftIO getCurrentTime
  dbtCsvName <- csvFilenameLmsReport qsh
  let dbtCsvSheetName = dbtCsvName
  let
    reportDBTable = DBTable{..}
      where
        dbtSQLQuery lmsReport = do
          E.where_ $ lmsReport E.^. LmsReportQualification E.==. E.val qid
          return lmsReport
        dbtRowKey = (E.^. LmsReportId)
        dbtProj = dbtProjId
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)   $ \(view $ _dbrOutput . _entityVal . _lmsReportIdent . _getLmsIdent -> ident) -> textCell ident
          , sortable (Just csvLmsDate)      (i18nCell MsgTableLmsDate)    $ \(view $ _dbrOutput . _entityVal . _lmsReportDate                 -> d)     -> cellMaybe dateTimeCell d
          , sortable (Just csvLmsResult)    (i18nCell MsgTableLmsStatus)  $ \(view $ _dbrOutput . _entityVal . _lmsReportResult               -> s)     -> lmsStateCell s
          , sortable (Just csvLmsLock)      (i18nCell MsgTableLmsLock)    $ \(view $ _dbrOutput . _entityVal . _lmsReportLock                 -> b)     -> ifIconCell b IconLocked
          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived)$ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp            -> t)     -> dateTimeCell t
          ]
        dbtSorting = Map.fromList
          [ (csvLmsIdent    , SortColumn (E.^. LmsReportIdent))
          , (csvLmsDate     , SortColumn (E.^. LmsReportDate))
          , (csvLmsResult   , SortColumn (E.^. LmsReportResult))
          , (csvLmsLock     , SortColumn (E.^. LmsReportLock))
          , (csvLmsTimestamp, SortColumn (E.^. LmsReportTimestamp))
          ]
        dbtFilter = Map.fromList
          [ (csvLmsIdent    , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsReportIdent))
          , (csvLmsDate     , FilterColumn $ E.mkExactFilter                          (E.^. LmsReportDate))          
          ]
        dbtFilterUI = \mPrev -> mconcat
          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
          , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField)  (fslI MsgTableLmsDate)
          ]
        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "lms-report"
        dbtCsvEncode = Just DBTCsvEncode
          { dbtCsvExportForm   = pure ()
          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
          , dbtCsvName
          , dbtCsvSheetName
          , dbtCsvNoExportData = Just id
          , dbtCsvHeader       = const $ return lmsReportTableCsvHeader
          , dbtCsvExampleData  = Just
            [ LmsReportTableCsv
              { csvLRident  = LmsIdent lid
              , csvLRdate   = Just $ LmsTimestamp $ addLocalDays (fromIntegral $ -dos) now
              , csvLRresult = toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState))
              , csvLRlock   = LmsBool $ even dos
              }
            | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [(1::Int)..]
            ]
          }
          where
            doEncode' = LmsReportTableCsv
              <$> view    (_dbrOutput . _entityVal . _lmsReportIdent)
              <*> preview (_dbrOutput . _entityVal . _lmsReportDate . _Just . _lmsTimestamp)
              <*> view    (_dbrOutput . _entityVal . _lmsReportResult)
              <*> view    (_dbrOutput . _entityVal . _lmsReportLock . _lmsBool)
        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
          { dbtCsvRowKey = \LmsReportTableCsv{..} ->
              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRident
          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew = LmsReportTableCsv{..}} -> do
                  yield $ LmsReportInsertData
                          { lmsReportCsvIdent  = csvLRident
                          , lmsReportCsvDate   = csvLRdate <&> lms2timestamp
                          , lmsReportCsvResult = csvLRresult
                          , lmsReportCsvLock   = csvLRlock  &  lms2bool
                          }
              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsReport was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
              DBCsvDiffExisting{dbCsvNew = LmsReportTableCsv{..}, dbCsvOld} -> do
                let resultTime = csvLRdate <&> lms2timestamp
                when (resultTime > dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportDate) $
                  yield $ LmsReportUpdateData
                          { lmsReportCsvIdent   = csvLRident
                          , lmsReportCsvDate    = resultTime
                          , lmsReportCsvResult  = csvLRresult
                          , lmsReportCsvLock    = csvLRlock & lms2bool
                          }
              DBCsvDiffMissing{}  -> return () -- no deletion
          , dbtCsvClassifyAction      = \case
              LmsReportInsertData{} -> LmsReportInsert
              LmsReportUpdateData{} -> LmsReportUpdate
          , dbtCsvCoarsenActionClass  = \case
              LmsReportInsert -> DBCsvActionNew
              LmsReportUpdate -> DBCsvActionExisting
          , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
          , dbtCsvExecuteActions      = do
            C.mapM_ $ \actionData -> do
                eanow <- liftIO getCurrentTime
                void $ upsert
                  LmsReport
                    { lmsReportQualification  =  qid
                    , lmsReportIdent          =  lmsReportCsvIdent  actionData
                    , lmsReportDate           =  lmsReportCsvDate   actionData
                    , lmsReportResult         =  lmsReportCsvResult actionData
                    , lmsReportLock           =  lmsReportCsvLock   actionData
                    , lmsReportTimestamp      =  eanow
                    }
                  [ LmsReportDate             =. lmsReportCsvDate   actionData
                  , LmsReportResult           =. lmsReportCsvResult actionData
                  , LmsReportLock             =. lmsReportCsvLock   actionData
                  , LmsReportTimestamp        =. eanow
                  ]                
            lift . queueDBJob $ JobLmsReports qid
            return $ LmsReportR sid qsh
          , dbtCsvRenderKey           = const $ \case
              LmsReportInsertData{..} -> do -- TODO: i18n
                [whamlet|
                  $newline never
                  Insert: Ident #{getLmsIdent lmsReportCsvIdent} #
                  has status #{show lmsReportCsvResult} #
                  $if lmsReportCsvLock
                    and is locked #
                  $maybe d <- lmsReportCsvDate
                    on ^{formatTimeW SelFormatDateTime d}
                |]
              LmsReportUpdateData{..} -> do -- TODO: i18n
                [whamlet|
                  $newline never
                  Update: Ident #{getLmsIdent lmsReportCsvIdent} #
                  has status #{show lmsReportCsvResult} #
                  $if lmsReportCsvLock
                    and is locked #
                  $maybe d <- lmsReportCsvDate
                    on ^{formatTimeW SelFormatDateTime d}
                |]
          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsReportCsvException -> DB Text
          }
        dbtExtraReps = []

    reportDBTableValidator = def
      & defaultSorting [SortAscBy csvLmsIdent]
  dbTable reportDBTableValidator reportDBTable

getLmsReportR,  postLmsReportR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsReportR = postLmsReportR
postLmsReportR sid qsh = do
  let directUploadLink = LmsReportUploadR sid qsh
  lmsTable <- runDB $ do
    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
    view _2 <$> mkReportTable sid qsh qid
  siteLayoutMsg MsgMenuLmsReport $ do
    setTitleI MsgMenuLmsReport
    $(widgetFile "lms-report")


-- Direct File Upload/Download

saveReportCsv :: UTCTime -> QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
saveReportCsv now qid i LmsReportTableCsv{..} = do    
    void $ upsert
      LmsReport
        { lmsReportQualification  =  qid
        , lmsReportIdent          =  csvLRident
        , lmsReportDate           =  csvLRdate <&> lms2timestamp
        , lmsReportResult         =  csvLRresult
        , lmsReportLock           =  csvLRlock  & lms2bool
        , lmsReportTimestamp      =  now
        }
      [ LmsReportDate             =. (csvLRdate <&> lms2timestamp)
      , LmsReportResult           =. csvLRresult
      , LmsReportLock             =. (csvLRlock  & lms2bool)
      , LmsReportTimestamp        =. now
      ]
    return $ succ i

makeReportUploadForm :: Form FileInfo
makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV"

getLmsReportUploadR, postLmsReportUploadR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsReportUploadR = postLmsReportUploadR
postLmsReportUploadR sid qsh = do
  now <- liftIO getCurrentTime
  ((report,widget), enctype) <- runFormPost makeReportUploadForm
  case report of
    FormSuccess file -> do
      -- content <- fileSourceByteString file
      -- return $ Just (fileName file, content)
      (nr, qid) <- runDBJobs $ do
        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
        nr <- runConduit $ fileSource file
                .| decodeCsv
                .| foldMC (saveReportCsv now qid) 0        
        return (nr, qid)
      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
      -- redirect $ LmsReportR sid qsh
      getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing

    FormFailure errs -> do
      forM_ errs $ addMessage Error . toHtml
      redirect $ LmsReportUploadR sid qsh
    FormMissing ->
      siteLayoutMsg MsgMenuLmsReport $ do
        setTitleI MsgMenuLmsUpload
        [whamlet|$newline never
          <form method=post enctype=#{enctype}>
            ^{widget}            
            <input type=submit>
        |]


postLmsReportDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsReportDirectR sid qsh = do
  (_params, files) <- runRequestBody
  (status, msg) <- case files of
    [(fhead,file)] -> do
      now   <- liftIO getCurrentTime
      lmsDecoder <- getLmsCsvDecoder
      runDBJobs $ do
        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
        enr <- try $ runConduit $ fileSource file
                .| lmsDecoder
                .| foldMC (saveReportCsv now qid) 0
        case enr of
          Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
            $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
            logInterface "LMS" (ciOriginal qsh) False Nothing ""
            return (badRequest400, "Exception: " <> tshow e)
          Right nr -> do
            let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
            $logInfoS "LMS" msg
            when (nr > 0) $ queueDBJob $ JobLmsReports qid
            logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
            return (ok200, msg)
    []     -> do
      let msg = "Report upload file missing."
      $logWarnS "LMS" msg
      return (badRequest400, msg)
    _other -> do
      let msg = "Report upload received multiple files; all ignored."
      $logWarnS "LMS" msg
      return (badRequest400, msg)
  sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back

