{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
{-# LANGUAGE TypeApplications #-}

module Handler.LMS
  ( getLmsAllR            , postLmsAllR
  , getLmsSchoolR
  , getLmsR               , postLmsR
  , getLmsEditR           , postLmsEditR
  , getLmsUsersR                                  , getLmsUsersDirectR
  , getLmsUserlistR       , postLmsUserlistR
  , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
  , getLmsResultR         , postLmsResultR
  , getLmsResultUploadR   , postLmsResultUploadR  , postLmsResultDirectR
  )
  where

import Import

import Jobs
import Handler.Utils
-- import Handler.Utils.Csv
import Handler.Utils.LMS


import qualified Data.Set as Set
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
import Database.Esqueleto.Utils.TH

import Handler.LMS.Users    as Handler.LMS
import Handler.LMS.Userlist as Handler.LMS
import Handler.LMS.Result   as Handler.LMS

-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton

-- Button only needed here
data ButtonManualLms = LmsEnqueue | LmsDequeue
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonManualLms
instance Finite   ButtonManualLms

nullaryPathPiece ''ButtonManualLms camelToPathPiece

instance Button UniWorX ButtonManualLms where
  btnLabel LmsEnqueue = "Enqeue"
  btnLabel LmsDequeue = "Deqeue"

  btnClasses LmsEnqueue = [BCIsButton, BCPrimary]
  btnClasses LmsDequeue = [BCIsButton, BCDefault]


getLmsSchoolR :: SchoolId -> Handler Html
getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)])

getLmsAllR, postLmsAllR :: Handler Html
getLmsAllR = postLmsAllR
postLmsAllR = do
  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
  let btnForm = wrapForm btnWdgt def
        { formAction   = Just $ SomeRoute LmsAllR
        , formEncoding = btnEnctype
        , formSubmit   = FormNoSubmit
        }
  case btnResult of
    (FormSuccess LmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue
    (FormSuccess LmsDequeue) -> queueJob' JobLmsQualificationsDequeue
    FormMissing -> return ()
    _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"

  lmsTable <- runDB $ do
    view _2 <$> mkLmsAllTable
  siteLayoutMsg MsgMenuQualifications $ do
    setTitleI MsgMenuQualifications
    $(widgetFile "lms-all")

type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
resultAllQualification :: Lens' AllQualificationTableData Qualification
resultAllQualification = _dbrOutput . _1 . _entityVal

resultAllQualificationActive :: Lens' AllQualificationTableData Word64
resultAllQualificationActive = _dbrOutput . _2 . _unValue

resultAllQualificationTotal  :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal  = _dbrOutput . _3 . _unValue


mkLmsAllTable :: DB (Any, Widget)
mkLmsAllTable = do
  now <- liftIO getCurrentTime
  let
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery quali = do
          cusers <- pure . Ex.subSelectCount $ do
            quser <- Ex.from $ Ex.table @QualificationUser
            Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
          cactive <- pure . Ex.subSelectCount $ do
            quser <- Ex.from $ Ex.table @QualificationUser
            Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
                  E.&&. quser Ex.^. QualificationUserValidUntil    Ex.>=. E.val (utctDay now)
          -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
          return (quali, cactive, cusers)
        dbtRowKey = (E.^. QualificationId)
        dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
        dbtColonnade = dbColonnade $ mconcat
          [ colSchool $ resultAllQualification . _qualificationSchool
          , sortable (Just "qshort")        (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
              let qsh = qualificationShorthand quali in
              anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
          , sortable (Just "qname")         (i18nCell MsgQualificationName)  $ \(view resultAllQualification -> quali) ->
              let qsh = qualificationShorthand quali
                  qnm = qualificationName quali
              in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm
          , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
              maybeCell (qualificationDescription quali) markupCellLargeModal
          , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
              foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
          , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $
              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
          -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
          , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
                                                                        $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
          , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
                                                                       -- \(view resultAllQualificationTotal  -> n) -> wgtCell $ word2widget n
          ]
        dbtSorting = mconcat
          [
            sortSchool $ to (E.^. QualificationSchool)
          , singletonMap "qshort"       $ SortColumn (E.^. QualificationShorthand)
          , singletonMap "qname"        $ SortColumn (E.^. QualificationName)
          , singletonMap "qelearning"   $ SortColumn (E.^. QualificationElearningStart)
          ]
        dbtFilter = mconcat
          [
            fltrSchool $ to (E.^. QualificationSchool)
          , singletonMap "qelearning"   . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart)
          ]
        dbtFilterUI = mconcat
          [
            fltrSchoolUI
          , \mPrev -> prismAForm (singletonFilter "qelearning"   . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning)
          ]
        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "qualification-overview"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
        dbtExtraReps = []

    resultDBTableValidator = def
      & defaultSorting [SortAscBy "school", SortAscBy "qshort"]
  dbTable resultDBTableValidator resultDBTable



getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsEditR = postLmsEditR
postLmsEditR = error "TODO"


type LmsTableExpr = (                   E.SqlExpr (Entity QualificationUser)
                      `E.InnerJoin`     E.SqlExpr (Entity User)
                    ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))

queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)

queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)

queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 2 2)

type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser))

resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1

resultUser :: Lens' LmsTableData (Entity User)
resultUser = _dbrOutput . _2

resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just

instance HasEntity LmsTableData User where
  hasEntity = resultUser

instance HasUser LmsTableData where
  hasUser = resultUser . _entityVal

data LmsTableAction = LmsActNotify
                    | LmsActRenewNotify
                    | LmsActRenewPin
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe LmsTableAction
instance Finite LmsTableAction
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id

-- Not yet needed, since there is no additional data for now:
data LmsTableActionData = LmsActNotifyData
                        | LmsActRenewNotifyData
                        | LmsActRenewPinData                        
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

isNotifyAct :: LmsTableActionData -> Bool
isNotifyAct LmsActNotifyData      = True
isNotifyAct LmsActRenewNotifyData = True 
isNotifyAct LmsActRenewPinData    = False 

isRenewPinAct :: LmsTableActionData -> Bool
isRenewPinAct LmsActNotifyData      = False
isRenewPinAct LmsActRenewNotifyData = True 
isRenewPinAct LmsActRenewPinData    = True 

lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
                                                               , E.SqlExpr (Entity User)
                                                               , E.SqlExpr (Maybe (Entity LmsUser))
                                                               )
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
  E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
  E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
          E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause
  E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification
  return (qualUser, user, lmsUser)


mkLmsTable :: forall h p cols act act'.
              ( Functor h, ToSortable h
              , Ord act, PathPiece act, RenderMessage UniWorX act
              , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool                                        LmsTableData))) cols
              )
           => Entity Qualification
           -> Map act (AForm Handler act')
           -> (LmsTableExpr -> E.SqlExpr (E.Value Bool))
           -> cols
           -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
           -> DB (FormResult (act', Set UserId), Widget)
mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
  now <- liftIO getCurrentTime
  -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route precisely heres
  let
    currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali)
    nowaday = utctDay now
    mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
    dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q)
    dbtRowKey = queryUser >>> (E.^. UserId)
    dbtProj = dbtProjFilteredPostId 
    dbtColonnade = cols
    dbtSorting = mconcat
      [ single $ sortUserNameLink queryUser
      , single $ sortUserEmail    queryUser
      , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
      , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
      , single ("first-held"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
      , single ("lms-ident"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserIdent))
      , single ("lms-status"  , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
      , single ("lms-started" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
      , single ("lms-datepin" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserDatePin))
      , single ("lms-received", SortColumn $ queryLmsUser  >>> (E.?. LmsUserReceived))
      , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
      ]
    dbtFilter = mconcat
      [ single $ fltrUserNameEmail   queryUser
      , single ("lms-ident"   , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
      -- , single ("lms-status"  , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
      , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
      , single ("renewal-due" , FilterColumn $ \(view (to queryQualUser) -> quser) criterion ->
          if | Just renewal <- mbRenewal
             , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
                                          E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
             | otherwise -> E.true
        )
      ]
    dbtFilterUI mPrev = mconcat
      [ fltrUserNameEmailHdrUI MsgTableLmsUser mPrev
      , prismAForm (singletonFilter "lms-ident"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
      -- , prismAForm (singletonFilter "lms-status"  . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
      , prismAForm (singletonFilter "validity"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
      , if isNothing mbRenewal then mempty
        else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
      ]
    dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
    dbtIdent :: Text
    dbtIdent = "qualification"
    dbtCsvEncode = noCsvEncode
    dbtCsvDecode = Nothing
    dbtExtraReps = []
    dbtParams = DBParamsForm
      { dbParamsFormMethod = POST
      , dbParamsFormAction = Just $ SomeRoute currentRoute
      , dbParamsFormAttrs  = []
      , dbParamsFormSubmit = FormSubmit
      , dbParamsFormAdditional
          = renderAForm FormStandard
               $  (, mempty) . First . Just
              <$> multiActionA acts (fslI MsgTableAction) Nothing
      , dbParamsFormEvaluate = liftHandler . runFormPost
      , dbParamsFormResult   = id
      , dbParamsFormIdent    = def
      }

    -- acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
    -- acts = mconcat
    --   [ singletonMap LmsActNotify    $ pure LmsActNotifyData
    --   , singletonMap LmsActRenewPin  $ pure LmsActRenewPinData
    --   ]
    postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData)
                -> FormResult (      act', Set UserId)
    postprocess inp = do
        (First (Just act), usrMap) <- inp
        let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
        return (act, usrSet)

    -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableActionData))
    -- resultDBTableValidator = def
      -- & defaultSorting [SortAscBy csvLmsIdent]
  over _1 postprocess <$> dbTable psValidator DBTable{..}

getLmsR,  postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsR = postLmsR
postLmsR sid qsh = do
  currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
  ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do
    qent <- getBy404 $ SchoolQualificationShort sid qsh
    let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
        acts = mconcat
          [ singletonMap LmsActNotify       $ pure LmsActNotifyData
          , singletonMap LmsActRenewNotify  $ pure LmsActRenewNotifyData
          , singletonMap LmsActRenewPin     $ pure LmsActRenewPinData
          ]
        colChoices = mconcat
          [ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using  function "is"
          , colUserNameLinkHdr MsgTableLmsUser AdminUserR
          , colUserEmail
          , sortable (Just "valid-until")   (i18nCell MsgTableQualificationValidUntil) $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
          , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
          , sortable (Just "lms-ident")     (i18nLms MsgTableLmsIdent)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
          , sortable (Just "lms-status")    (i18nLms MsgTableLmsStatus)   $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStatus -> status)            -> foldMap lmsStatusCell $ join status
          , sortable (Just "lms-started")   (i18nLms MsgTableLmsStarted)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStarted  -> d) -> foldMap dateTimeCell        d
          , sortable (Just "lms-datepin")   (i18nLms MsgTableLmsDatePin)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserDatePin  -> d) -> foldMap dateTimeCell        d
          , sortable (Just "lms-received")  (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
          , sortable (Just "lms-ended")     (i18nLms MsgTableLmsEnded)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserEnded    -> d) -> foldMap dateTimeCell $ join d
          ]
          where
            -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
            i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
        psValidator = def
    tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator
    return (tbl, qent)

  formResult lmsRes $ \case
    (action, selectedUsers) -> do --   | isRenewPinAct action || isNotifyAct action -> do
      now <- liftIO getCurrentTime
      numExaminees <- runDBJobs $ do
        okUsers <- selectList [LmsUserUser <-. Set.toList selectedUsers, LmsUserQualification ==. qid] []
        forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
          when (isRenewPinAct action) $ do
            newPin <- liftIO randomLMSpw
            update lid [LmsUserPin =. newPin, LmsUserDatePin =. now] -- must be within its own runDB
          when (isNotifyAct action) $ 
            queueDBJob $ JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' }
        return $ length okUsers
      let numSelected  = length selectedUsers          
          diffSelected = numSelected - numExaminees
      when (isRenewPinAct action) $ addMessageI Success $ MsgLmsPinRenewal       numExaminees
      when (isNotifyAct action)   $ addMessageI Success $ MsgLmsNotificationSend numExaminees
      when (diffSelected /= 0)    $ addMessageI Warning $ MsgLmsActionFailed     diffSelected
      redirect currentRoute

  let heading = citext2widget $ qualificationName quali
  siteLayout heading $ do
    setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
    $(widgetFile "lms")
