{-# 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 -- TODO not yet supported
--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, Typeable, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id

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

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, Typeable)

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
      runDBJobs $ do 
        qid <- getKeyBy404 $ SchoolQualificationShort sid qsh 
        enr <- try $ runConduit $ fileSource file
                .| decodeCsv
                .| 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 header " <> fhead
            $logWarnS "LMS" msg -- TODO: change to Info Level in the future
            queueDBJob $ JobLmsResults 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
  