-- SPDX-FileCopyrightText: 2022 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.Result
  ( getLmsResultR, postLmsResultR
  , getLmsResultUploadR, postLmsResultUploadR
  , postLmsResultDirectR
  )
  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 LmsResultTableCsv = LmsResultTableCsv
  { csvLRTident   :: LmsIdent
  , csvLRTsuccess :: LmsDay
  }
  deriving Generic
makeLenses_ ''LmsResultTableCsv

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

-- csv with headers
lmsResultTableCsvHeader :: Csv.Header
lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]

instance ToNamedRecord LmsResultTableCsv where
  toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
    [ csvLmsIdent   Csv..= csvLRTident
    , csvLmsSuccess Csv..= csvLRTsuccess
    ]

instance FromNamedRecord LmsResultTableCsv where
  parseNamedRecord (lsfHeaderTranslate -> csv)
    = LmsResultTableCsv
        <$> csv Csv..: csvLmsIdent
        <*> csv Csv..: csvLmsSuccess

instance CsvColumnsExplained LmsResultTableCsv where
  csvColumnsExplanations _ = mconcat
    [ single csvLmsIdent   MsgCsvColumnLmsIdent
    , single csvLmsSuccess MsgCsvColumnLmsSuccess
    ]
    where
      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
      single k v = singletonMap k [whamlet|_{v}|]

data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate
  deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id

-- By coincidence the action type is identical to LmsResultTableCsv
data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
                        | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsResultInsertData -> insert
  , fieldLabelModifier     = camelToPathPiece'  2     -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
  , sumEncoding = TaggedObject "action" "data"
  } ''LmsResultCsvAction

data LmsResultCsvException
  = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
  deriving (Show, Generic, Typeable)

instance Exception LmsResultCsvException
embedRenderMessage ''UniWorX ''LmsResultCsvException id

mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkResultTable sid qsh qid = do
  now_day <- utctDay <$> liftIO getCurrentTime
  dbtCsvName <- csvFilenameLmsResult qsh
  let dbtCsvSheetName = dbtCsvName
  let
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery lmsresult = do
          E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
          return lmsresult
        dbtRowKey = (E.^. LmsResultId)
        dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
          , sortable (Just csvLmsSuccess)   (i18nCell MsgTableLmsSuccess)  $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess            -> success) -> dayCell success
          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp        -> timestamp) -> dateTimeCell timestamp
          ]
        dbtSorting = Map.fromList
          [ (csvLmsIdent    , SortColumn (E.^. LmsResultIdent))
          , (csvLmsSuccess  , SortColumn (E.^. LmsResultSuccess))
          , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp))
          ]
        dbtFilter = Map.fromList
          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
          , (csvLmsSuccess, FilterColumn $ E.mkExactFilter                 (E.^. LmsResultSuccess))
          ]
        dbtFilterUI = \mPrev -> mconcat
          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
          , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField)  (fslI MsgTableLmsSuccess)
          ]
        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "lms-result"
        dbtCsvEncode = Just DBTCsvEncode
          { dbtCsvExportForm   = pure ()
          , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
          , dbtCsvName
          , dbtCsvSheetName
          , dbtCsvNoExportData = Just id
          , dbtCsvHeader       = const $ return lmsResultTableCsvHeader
          , dbtCsvExampleData  = Just
            [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
            | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
            ]
          }
          where
            doEncode' = LmsResultTableCsv
              <$> view (_dbrOutput . _entityVal . _lmsResultIdent)
              <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay)
        dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
          { dbtCsvRowKey = \LmsResultTableCsv{..} ->
              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident
          , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
              DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
                yield $ LmsResultInsertData
                        { lmsResultInsertIdent   = csvLRTident   dbCsvNew
                        , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day
                        }
              DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
              DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do
                let successDay = lms2day csvLRTsuccess
                when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
                  yield $ LmsResultUpdateData
                          { lmsResultInsertIdent   = csvLRTident
                          , lmsResultInsertSuccess = successDay
                          }
              DBCsvDiffMissing{}  -> return () -- no deletion
          , dbtCsvClassifyAction      = \case
              LmsResultInsertData{} -> LmsResultInsert
              LmsResultUpdateData{} -> LmsResultUpdate
          , dbtCsvCoarsenActionClass  = \case
              LmsResultInsert -> DBCsvActionNew
              LmsResultUpdate -> DBCsvActionExisting
          , dbtCsvValidateActions     = return ()  -- no validation, since this is an automatic upload, i.e. no user to review error
          , dbtCsvExecuteActions      = do
            C.mapM_ $ \actionData -> do
                now <- liftIO getCurrentTime
                void $ upsert
                  LmsResult
                    { lmsResultQualification  =  qid
                    , lmsResultIdent          =  lmsResultInsertIdent   actionData
                    , lmsResultSuccess        =  lmsResultInsertSuccess actionData
                    , lmsResultTimestamp      =  now -- lmsResultInsertTimestamp -- does it matter which one to choose?
                    }
                  [ LmsResultSuccess          =. lmsResultInsertSuccess actionData
                  , LmsResultTimestamp        =. now
                  ]
                -- audit $ Transaction.. (add to Audit.Types)
            lift . queueDBJob $ JobLmsResults qid
            return $ LmsResultR sid qsh
          , dbtCsvRenderKey           = const $ \case
              LmsResultInsertData{..} -> do -- TODO: i18n
                [whamlet|
                  $newline never
                  Insert: Ident #{getLmsIdent lmsResultInsertIdent} #
                  had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
                |]
              LmsResultUpdateData{..} -> do -- TODO: i18n
                [whamlet|
                  $newline never
                  Update: Ident #{getLmsIdent lmsResultInsertIdent} #
                  had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
                |]
          , dbtCsvRenderActionClass   = toWidget <=< ap getMessageRender . pure
          , dbtCsvRenderException     = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
          }
        dbtExtraReps = []

    resultDBTableValidator = def
      & defaultSorting [SortAscBy csvLmsIdent]
  dbTable resultDBTableValidator resultDBTable

getLmsResultR,  postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do
  let directUploadLink = LmsResultUploadR sid qsh
  lmsTable <- runDB $ do
    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
    view _2 <$> mkResultTable sid qsh qid
  siteLayoutMsg MsgMenuLmsResult $ do
    setTitleI MsgMenuLmsResult
    $(widgetFile "lms-result")


-- Direct File Upload/Download

saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int
saveResultCsv qid i LmsResultTableCsv{..} = do
    now <- liftIO getCurrentTime
    void $ upsert
      LmsResult
        { lmsResultQualification  =  qid
        , lmsResultIdent          =  csvLRTident
        , lmsResultSuccess        =  csvLRTsuccess & lms2day
        , lmsResultTimestamp      =  now
        }
      [ LmsResultSuccess          =. (csvLRTsuccess & lms2day)
      , LmsResultTimestamp        =. now
      ]
    return $ succ i

makeResultUploadForm :: Form FileInfo
makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV"

getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsResultUploadR = postLmsResultUploadR
postLmsResultUploadR sid qsh = do
  ((result,widget), enctype) <- runFormPost makeResultUploadForm
  case result of
    FormSuccess file -> do
      -- content <- fileSourceByteString file
      -- return $ Just (fileName file, content)
      nr <- runDBJobs $ do
        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
        nr <- runConduit $ fileSource file
                .| decodeCsv
                .| foldMC (saveResultCsv qid) 0
        queueDBJob $ JobLmsResults qid
        return nr
      addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
      redirect $ LmsResultR sid qsh
    FormFailure errs -> do
      forM_ errs $ addMessage Error . toHtml
      redirect $ LmsResultUploadR sid qsh
    FormMissing ->
      siteLayoutMsg MsgMenuLmsResult $ do
        setTitleI MsgMenuLmsUpload
        [whamlet|$newline never
          <form method=post enctype=#{enctype}>
            ^{widget}
            <p>
            <input type=submit>
        |]


postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsResultDirectR sid qsh = do
  (_params, files) <- runRequestBody
  (status, msg) <- case files of
    [(fhead,file)] -> do
      lmsDecoder <- getLmsCsvDecoder
      runDBJobs $ do
        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
        enr <- try $ runConduit $ fileSource file
                .| lmsDecoder
                .| foldMC (saveResultCsv qid) 0
        case enr of
          Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
            $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
            return (badRequest400, "Exception: " <> tshow e)
          Right nr -> do
            let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for file " <> fhead
            $logInfoS "LMS" msg
            when (nr > 0) $ queueDBJob $ JobLmsResults qid
            return (ok200, msg)
    []     -> do
      let msg = "Result upload file missing."
      $logWarnS "LMS" msg
      return (badRequest400, msg)
    _other -> do
      let msg = "Result upload received multiple files; all ignored."
      $logWarnS "LMS" msg
      return (badRequest400, msg)
  sendResponseStatus status msg