-- SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,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
{-# 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
  , getLmsFakeR           , postLmsFakeR
  , getLmsUserR
  )
  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.Text as T
import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as C
import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.PostgreSQL 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
import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!

-- import Handler.Utils.Qualification (validQualification)

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

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

nullaryPathPiece ''ButtonManualLms camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonManualLms id

instance Button UniWorX ButtonManualLms where
  btnClasses BtnLmsEnqueue = [BCIsButton, BCPrimary]
  btnClasses BtnLmsDequeue = [BCIsButton, BCDefault]


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

getLmsAllR, postLmsAllR :: Handler Html
getLmsAllR = postLmsAllR
postLmsAllR = do
  isAdmin <- hasReadAccessTo AdminR
  mbQcheck <- getsYesod $ view _appQualificationCheckHour
  -- TODO: Move this functionality elsewhere without the need for `isAdmin`
  mbBtnForm <- if not isAdmin then return Nothing else do
    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
    case btnResult of
      (FormSuccess BtnLmsEnqueue) -> queueJob' JobLmsQualificationsEnqueue
      (FormSuccess BtnLmsDequeue) -> queueJob' JobLmsQualificationsDequeue
      FormMissing -> return ()
      _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
    return $ Just $ wrapForm btnWdgt def
              { formAction   = Just $ SomeRoute LmsAllR
              , formEncoding = btnEnctype
              , formSubmit   = FormNoSubmit
              }
  
  lmsTable <- runDB $ do
    view _2 <$> mkLmsAllTable isAdmin
  siteLayoutMsg MsgMenuLms $ do
    setTitleI   MsgMenuLms
    $(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 :: Bool -> DB (Any, Widget)
mkLmsAllTable isAdmin = do
  now <- liftIO getCurrentTime
  
  let
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery quali = do
          let cusers = Ex.subSelectCount $ do
                quser <- Ex.from $ Ex.table @QualificationUser
                Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
              cactive = Ex.subSelectCount $ do
                quser <- Ex.from $ Ex.table @QualificationUser
                Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
                      Ex.&&. validQualification (utctDay now) quser
          -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
          return (quali, cactive, cusers)
        dbtRowKey = (Ex.^. QualificationId)
        dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference?
        adminable = if isAdmin then sortable else \_ _ _ -> mempty
        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 MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) 
                  $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
          , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)  
                  $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
                      let icn = IconOK -- change icon here, if desired
                      in case mbSapId of 
                        Nothing               -> mempty
                        Just sapId | isAdmin  -> cellTooltipIcon (Just icn) (text2message sapId) mempty
                        Just _                -> iconCell icn 
          , adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
                  $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
          , adminable 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 = "lms-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: STUB"


data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
  { ltcDisplayName :: UserDisplayName
  , ltcEmail       :: UserEmail
  , ltcValidUntil  :: Day
  , ltcLastRefresh :: Day
  , ltcFirstHeld   :: Day
  , ltcBlockedDue  :: Maybe QualificationBlocked
  , ltcLmsIdent    :: Maybe LmsIdent
  , ltcLmsStatus   :: Maybe LmsStatus
  , ltcLmsStarted  :: Maybe UTCTime
  , ltcLmsDatePin  :: Maybe UTCTime
  , ltcLmsReceived :: Maybe UTCTime
  , ltcLmsNotified :: Maybe UTCTime
  , ltcLmsEnded    :: Maybe UTCTime
  }
  deriving Generic
makeLenses_ ''LmsTableCsv

ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv
    { ltcDisplayName = "Max Mustermann"
    , ltcEmail       = "m.mustermann@example.com"
    , ltcValidUntil  = compDay
    , ltcLastRefresh = compDay
    , ltcFirstHeld   = compDay
    , ltcBlockedDue  = Nothing
    , ltcLmsIdent    = Nothing
    , ltcLmsStatus   = Nothing
    , ltcLmsStarted  = Just compTime
    , ltcLmsDatePin  = Nothing
    , ltcLmsReceived = Nothing
    , ltcLmsNotified = Nothing
    , ltcLmsEnded    = Nothing
    }
  where
    compTime :: UTCTime
    compTime = $compileTime
    compDay :: Day
    compDay = utctDay compTime

ltcOptions :: Csv.Options
ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
  where
    renameLtc "ltcDisplayName" = "licensee"
    renameLtc "ltcLmsDatePin"  = prefixLms "pin-created"
    renameLtc "ltcLmsReceived" = prefixLms "last-update"
    renameLtc other = replaceLtc $ camelToPathPiece' 1 other
    replaceLtc ('l':'m':'s':'-':t) = prefixLms t
    replaceLtc other = other
    prefixLms = ("e-learn-" <>)

instance Csv.ToNamedRecord LmsTableCsv where
  toNamedRecord = Csv.genericToNamedRecord ltcOptions

instance Csv.DefaultOrdered LmsTableCsv where
  headerOrder = Csv.genericHeaderOrder ltcOptions

instance CsvColumnsExplained LmsTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
    [ ('ltcDisplayName, MsgLmsUser)
    , ('ltcEmail      , MsgTableLmsEmail)
    , ('ltcValidUntil , MsgLmsQualificationValidUntil)
    , ('ltcLastRefresh, MsgTableQualificationLastRefresh)
    , ('ltcFirstHeld  , MsgTableQualificationFirstHeld)
    , ('ltcLmsIdent   , MsgTableLmsIdent)
    , ('ltcLmsStatus  , MsgTableLmsStatus)
    , ('ltcLmsStarted , MsgTableLmsStarted)
    , ('ltcLmsDatePin , MsgTableLmsDatePin)
    , ('ltcLmsReceived, MsgTableLmsReceived)
    , ('ltcLmsEnded   , MsgTableLmsEnded)
    ]


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), E.Value (Maybe [Maybe UTCTime]))

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

resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _4 . _unValue . _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)

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          -- no longer used
  deriving (Eq, Ord, Read, Show, Generic)

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))
                , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
                )
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
    -- RECALL: another outer join on PrintJob did not work out well, since
    --   - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
    --   - using noExsists on printJob join condition works, but only deliver single value;
    --  experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest
    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, which does not work
    E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
    E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification
    -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
    -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
    let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
                    E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
                        E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser))
                    let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
                    pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated     ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
                           E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder                           
    return (qualUser, user, lmsUser, printAcknowledged)


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
              )
           => Bool
           -> Entity Qualification
           -> Map act (AForm Handler act')           
           -> cols
           -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))
           -> DB (FormResult (act', Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
  now <- liftIO getCurrentTime  
  let    
    nowaday = utctDay now
    mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
    csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
    dbtIdent :: Text
    dbtIdent = "qualification"
    dbtSQLQuery = lmsTableQuery qid
    dbtRowKey = queryUser >>> (E.^. UserId)
    dbtProj = dbtProjId

    dbtColonnade = cols
    dbtSorting = mconcat
      [ single $ sortUserNameLink queryUser
      , single $ sortUserEmail    queryUser      
      , single ("valid-until"   , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
      , single ("last-refresh"  , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
      , single ("first-held"    , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
      , single ("blocked-due"   , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
      , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))      
      , single ("lms-ident"     , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserIdent))
      , single ("lms-pin"       , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserPin))
      , single ("lms-status"    , SortColumnNullsInv $ views (to queryLmsUser) (E.?. LmsUserStatus))
      , single ("lms-started"   , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserStarted))
      , single ("lms-datepin"   , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserDatePin))
      , single ("lms-received"  , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserReceived))
      , single ("lms-notified"  , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
      , single ("lms-ended"     , SortColumnNullsInv $ queryLmsUser  >>> (E.?. LmsUserEnded))
      , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
                E.orderBy [E.asc (comp E.^. CompanyName)]
                return (comp E.^. CompanyName)
              )
      ]
    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 ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
      , single ("renewal-due" , FilterColumn $ \(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
        )
      , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
      , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
              E.from $ \usrAvs -> -- do 
                E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
                    E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
                          (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
      , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
              E.from $ \(usrComp `E.InnerJoin` comp) -> do 
                let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
                    testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
                    testcrit = maybe testname testnumber $ readMay $ CI.original criterion
                E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
        )                          
      ]
    dbtFilterUI mPrev = mconcat
      [ fltrUserNameEmailHdrUI MsgLmsUser 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 "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
      , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
      , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
      , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
      , if isNothing mbRenewal then mempty
        else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)      
      ]
    dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
    dbtCsvEncode = Just DBTCsvEncode
      { dbtCsvExportForm   = pure ()
      , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
      , dbtCsvName         = csvName
      , dbtCsvSheetName    = csvName
      , dbtCsvNoExportData = Just id
      , dbtCsvHeader       = const $ return $ Csv.headerOrder ltcExample
      , dbtCsvExampleData  = Just [ltcExample]
      }
      where
        doEncode' :: LmsTableData -> LmsTableCsv
        doEncode' = LmsTableCsv
          <$>  view    (resultUser     . _entityVal . _userDisplayName)
          <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserBlockedDue)
          <*>  preview (resultLmsUser  . _entityVal . _lmsUserIdent)
          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus))
          <*>  preview (resultLmsUser  . _entityVal . _lmsUserStarted)
          <*>  preview (resultLmsUser  . _entityVal . _lmsUserDatePin)
          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserReceived))
          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge
          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserEnded))
    dbtCsvDecode = Nothing
    dbtExtraReps = []
    dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else 
      DBParamsForm
      { dbParamsFormMethod = POST
      , dbParamsFormAction = Nothing -- 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
  isAdmin <- hasReadAccessTo AdminR    
  ((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
          ]
        -- lmsStatusLink = toMaybe isAdmin LmsUserR
        colChoices = mconcat
          [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using  function "is"
          , colUserNameModalHdr MsgLmsUser AdminUserR
          , colUserEmail
          , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
            companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
              E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
              E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
              E.orderBy [E.asc (comp E.^. CompanyName)]
              return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
            let companies = intersperse (text2markup ", ") $
                  (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
                icnSuper = text2markup " " <> icon IconSupervisor
            pure $ toWgt $ mconcat companies
          , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(   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 "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
                                                                                    )  $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> qualificationBlockedCell b
          , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal  & cellTooltip MsgTableQualificationNoRenewalTooltip
                                                                                    )  $ \(   view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
          , sortable (Just "lms-ident")     (i18nCell MsgTableLmsIdent)    $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
          , sortable (Just "lms-pin")       (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
                                                                         ) $ \(preview $ resultLmsUser . _entityVal . _lmsUserPin                  -> pin) -> foldMap textCell pin
          , sortable (Just "lms-status")    (i18nCell 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-notified")  (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
          , sortable (Just "lms-notified")  (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
              -- 4 Cases:
              --   - No notification: LmsUserNotified == Nothing
              --   - Email sent     : LmsUserNotified == Just _  && PrintJobId == Nothing
              --   - Letter printed : LmsUserNotified == Just _  && PrintJobId == Just _
              --   - Letter sent    : LmsUserNotified == Just _  && PrintJobId == Just _ && PrintJobAcknowledged == Just _
              let notifyDate      = join $ row ^? resultLmsUser  . _entityVal . _lmsUserNotified
                  lmsident        = row ^? resultLmsUser . _entityVal . _lmsUserIdent                  
                  recipient       = row ^. hasUser                  
                  letterDates     = row ^? resultPrintAck
                  lastLetterDate  = headDef Nothing =<< letterDates
                  letterSent      = isJust letterDates  && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
                  notNotified     = isNothing notifyDate
                  cIcon           = iconFixedCell $ iconLetterOrEmail letterSent
                  cDate           = if | not letterSent  ->  foldMap dateTimeCell notifyDate
                                       | Just d <- lastLetterDate -> dateTimeCell d
                                       | otherwise -> i18nCell MsgPrintJobUnacknowledged
                  lprLink :: Maybe (Route UniWorX)  = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
                  cAckDates = case letterDates of
                    Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
                          <h1>
                            _{MsgPrintJobAcknowledgements} ^{userWidget recipient}
                          <ul>
                            $forall mbackdate <- ackDates
                              <li>
                                #{iconLetter} #
                                  $maybe ackdate <- mbackdate
                                    ^{formatTimeW SelFormatDateTime ackdate}
                                  $nothing
                                    _{MsgPrintJobUnacknowledged}
                          $maybe lu <- lprLink
                            <p>
                              <a href=@{lu}>
                                _{MsgPrintJobs}
                        |]
                        -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
                    _ -> mempty

              in if notNotified
                  then mempty
                  else cIcon <> spacerCell <> cDate <> cAckDates
          -- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show 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 & defaultSorting [SortDescBy "lms-started", SortDescBy "lms-status"]
    tbl <- mkLmsTable isAdmin qent acts colChoices psValidator
    return (tbl, qent)

  formResult lmsRes $ \case
    _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
    (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, LmsUserResetPin =. True]
          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
      reloadKeepGetParams $ LmsR sid qsh

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


-- intended to be viewed primarily in a modal, wie lmsStatusPlusCell
getLmsUserR :: CryptoUUIDUser -> Handler Html
getLmsUserR uuid = do  
  uid <- decrypt uuid
  now <- liftIO getCurrentTime 
  let nowaday = utctDay now
  (user@User{userDisplayName}, quals) <- runDB $ do 
    usr <- get404 uid
    qs  <- Ex.select $ do 
          (qual :& qualUsr :& lmsUsr) <- 
            Ex.from $ Ex.table @Qualification
            `Ex.leftJoin` Ex.table @QualificationUser
            `Ex.on` (\(qual :& qualUsr)     -> qualUsr  E.?. QualificationUserUser          E.?=. Ex.val uid
                                        E.&&.  qualUsr  E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId
                    ) 
            `Ex.leftJoin` Ex.table @LmsUser
            `Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr   E.?. LmsUserUser                    E.?=. Ex.val uid
                                        E.&&.  lmsUsr   E.?. LmsUserQualification           E.?=. qual Ex.^. QualificationId 
                    )
          Ex.where_ $ E.isJust (qualUsr E.?. QualificationUserUser) 
                E.||. E.isJust ( lmsUsr E.?. LmsUserUser)
          Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
          pure (qual, qualUsr, lmsUsr, validQualification' nowaday qualUsr)
    return (usr,qs)

  let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]  
  siteLayout heading $ do
    setTitle $ toHtml userDisplayName
    $(widgetFile "lms-user")
    -- $(i18nWidgetFile "lms-user")
