-- SPDX-FileCopyrightText: 2022 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.Userlist
  ( getLmsUserlistR, postLmsUserlistR
  , getLmsUserlistUploadR, postLmsUserlistUploadR
  , postLmsUserlistDirectR
  )
  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 LmsUserlistTableCsv = LmsUserlistTableCsv
  { csvLULident  :: LmsIdent
  , csvLULfailed :: LmsBool
  }
  deriving Generic
makeLenses_ ''LmsUserlistTableCsv

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

-- csv with headers
instance DefaultOrdered LmsUserlistTableCsv where
   headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ]

instance ToNamedRecord LmsUserlistTableCsv where
  toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
    [ csvLmsIdent   Csv..= csvLULident
    , csvLmsBlocked Csv..= csvLULfailed
    ]
instance FromNamedRecord LmsUserlistTableCsv where
  parseNamedRecord (lsfHeaderTranslate -> csv)
    = LmsUserlistTableCsv
        <$> csv Csv..: csvLmsIdent
        <*> csv Csv..: csvLmsBlocked

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


data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
  deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id

data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
                          | LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
  deriving (Eq, Ord, Read, Show, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece'' 2 1   -- LmsUserlistInsertData -> insert
  , fieldLabelModifier = camelToPathPiece' 2          -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed
  , sumEncoding = TaggedObject "action" "data"
  } ''LmsUserlistCsvAction


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

instance Exception LmsUserlistCsvException
embedRenderMessage ''UniWorX ''LmsUserlistCsvException id

mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserlistTable sid qsh qid = do
  dbtCsvName <- csvFilenameLmsUserlist qsh
  let dbtCsvSheetName = dbtCsvName
  let
    userlistTable = DBTable{..}
      where
        dbtSQLQuery lmslist = do
          E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
          return lmslist
        dbtRowKey = (E.^. LmsUserlistId)
        dbtProj   = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just csvLmsIdent)     (i18nCell MsgTableLmsIdent)    $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell    $ lmsUserlistIdent & getLmsIdent
          , sortable (Just csvLmsBlocked)   (i18nCell MsgTableLmsFailed)   $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell    lmsUserlistFailed IconBlocked
          , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell  lmsUserlistTimestamp
          ]
        dbtSorting = Map.fromList
          [ (csvLmsIdent    , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
          , (csvLmsBlocked  , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
          , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
          ]
        dbtFilter = Map.fromList
          [ (csvLmsIdent  , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
          , (csvLmsBlocked, FilterColumn $ E.mkExactFilter                 (E.^. LmsUserlistFailed))
          ]
        dbtFilterUI =  \mPrev -> mconcat
          [ prismAForm (singletonFilter csvLmsIdent   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)     (fslI MsgTableLmsIdent)
          , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
          ]
        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "lms-userlist"
        dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample
          where
            addExample dce = dce{ dbtCsvExampleData = csvExample }
            csvExample = Just
              [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl}
              | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False]
              ]
            doEncode' = LmsUserlistTableCsv
              <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent)
              <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
        dbtCsvDecode = Just DBTCsvDecode {..}
          where
            dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
              fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident
            dbtCsvComputeActions = \case -- shows a diff first
              DBCsvDiffNew{dbCsvNew} -> do
                yield $ LmsUserlistInsertData
                          { lmsUserlistInsertIdent  =            csvLULident   dbCsvNew
                          , lmsUserlistInsertFailed = lms2bool $ csvLULfailed  dbCsvNew
                          }
              DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
                let failedBool = lms2bool csvLULfailed
                when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $
                  yield $ LmsUserlistUpdateData
                            { lmsUserlistInsertIdent  = csvLULident
                            , lmsUserlistInsertFailed = csvLULfailed & lms2bool
                            }
              DBCsvDiffMissing{} -> return () -- no deletion
            dbtCsvClassifyAction = \case
               LmsUserlistInsertData{} -> LmsUserlistInsert
               LmsUserlistUpdateData{} -> LmsUserlistUpdate
            dbtCsvCoarsenActionClass = \case
               LmsUserlistInsert -> DBCsvActionNew
               LmsUserlistUpdate -> 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 LmsUserlist
                  {
                    lmsUserlistQualification  =  qid
                  , lmsUserlistIdent          =  lmsUserlistInsertIdent   actionData
                  , lmsUserlistFailed         =  lmsUserlistInsertFailed  actionData
                  , lmsUserlistTimestamp      =  now
                  }
                  [
                    LmsUserlistFailed         =. lmsUserlistInsertFailed  actionData -- TODO: should we allow a reset from failed: True to False?
                  , LmsUserlistTimestamp      =. now
                  ]
                -- audit
              lift . queueDBJob $ JobLmsUserlist qid
              return $ LmsUserlistR sid qsh
            dbtCsvRenderKey = const $ \case
              LmsUserlistInsertData{..} -> do -- TODO: i18n
                [whamlet|
                  $newline never
                  Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
                  $if lmsUserlistInsertFailed
                    is closed due to failure.
                  $else
                    is open.
                |]
              LmsUserlistUpdateData{..} -> do -- TODO: i18n
                [whamlet|
                  $newline never
                  Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
                  $if lmsUserlistInsertFailed
                    is now closed due to failure.
                  $else
                    is still open.
                |]
            dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
            dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text
        dbtExtraReps = []

    userlistDBTableValidator = def
      & defaultSorting [SortAscBy csvLmsIdent]

  dbTable userlistDBTableValidator userlistTable


getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUserlistR = postLmsUserlistR
postLmsUserlistR sid qsh = do
  lmsTable <- runDB $ do
    qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
    view _2 <$> mkUserlistTable sid qsh qid
  siteLayoutMsg MsgMenuLmsUserlist $ do
    setTitleI MsgMenuLmsUserlist
    $(widgetFile "lms-userlist")


-- Direct File Upload/Download
--  saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) =>
--                      Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int
saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
    now <- liftIO getCurrentTime
    void $ upsert
      LmsUserlist
        { lmsUserlistQualification  =  qid
        , lmsUserlistIdent          =  csvLULident
        , lmsUserlistFailed         =  csvLULfailed & lms2bool
        , lmsUserlistTimestamp      =  now
        }
      [ LmsUserlistFailed           =. (csvLULfailed & lms2bool)
      , LmsUserlistTimestamp        =. now
      ]
    return $ succ i

makeUserlistUploadForm :: Form FileInfo
makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV"

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


postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsUserlistDirectR 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 (saveUserlistCsv qid) 0
        case enr of
          Left (e :: SomeException) -> do
            $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
            return (badRequest400, "Exception: " <> tshow e)
          Right nr -> do
            let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
            $logInfoS "LMS" msg 
            when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
            return (ok200, msg)
    []     -> do
      let msg = "Userlist upload file missing."
      $logWarnS "LMS" msg
      return (badRequest400, msg)
    _other -> do
      let msg = "Userlist upload received multiple files; all ignored."
      $logWarnS "LMS" msg
      return (badRequest400, msg)
  sendResponseStatus status msg