-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.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
{-# LANGUAGE TypeApplications #-}

module Handler.LMS
  ( getLmsAllR            , postLmsAllR
  , getLmsSchoolR
  , getLmsR               , postLmsR
  , getLmsIdentR
  , getLmsEditR           , postLmsEditR
  -- V2
  , getLmsLearnersR       , getLmsLearnersDirectR
  , getLmsReportR         , postLmsReportR
  , getLmsReportUploadR   , postLmsReportUploadR  , postLmsReportDirectR
  --
  , getLmsFakeR           , postLmsFakeR
  , getLmsUserR
  , getLmsUserSchoolR
  , getLmsUserAllR     
  )
  where

import Import

import Jobs
import Handler.Utils
import Handler.Utils.Users
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 Database.Persist.Sql (deleteWhereCount, updateWhereCount)
-- V2
import Handler.LMS.Learners as Handler.LMS
import Handler.LMS.Report   as Handler.LMS
import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!


-- 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, BCPrimary]


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

getLmsAllR, postLmsAllR :: Handler Html
getLmsAllR = postLmsAllR
postLmsAllR = do
  isAdmin <- hasReadAccessTo AdminR
  mbJLQenqueue <- getsYesod $ view _appJobLmsQualificationsEnqueueHour
  mbJLQdequeue <- getsYesod $ view _appJobLmsQualificationsDequeueHour
  -- 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 
        >> addMessage Info "Einreihung ablaufender Qualifikationen zum LMS wird nun im Hintergund durchgeführt."
      (FormSuccess BtnLmsDequeue) -> 
        queueJob' JobLmsQualificationsDequeue 
        >> addMessage Info "Benachrichtigung abgelaufener Qualifikationen und Aufräumen beendeter LMS Nutzer wird im Hintergund ausgeführt."
      FormMissing -> return ()
      _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
    return $ Just $ wrapForm btnWdgt def
              { formAction   = Just $ SomeRoute LmsAllR
              , formEncoding = btnEnctype
              , formSubmit   = FormNoSubmit
              }

  LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
  lmsTable <- runDB $ do
    view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays
  siteLayoutMsg MsgMenuLms $ do
    setTitleI   MsgMenuLms
    $(i18nWidgetFile "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 -> Int -> DB (Any, Widget)
mkLmsAllTable isAdmin lmsDeletionDays = do
  svs <- getSupervisees   
  let
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery quali = do
          let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId                  
                         Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs)
              cusers = Ex.subSelectCount $ do 
                luser <- Ex.from $ Ex.table @LmsUser
                Ex.where_ $ filterSvs luser 
              cactive = Ex.subSelectCount $ do 
                luser <- Ex.from $ Ex.table @LmsUser
                Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
          -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
          return (quali, cactive, cusers)
        dbtRowKey = (Ex.^. QualificationId)
        dbtProj = dbtProjId
        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    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage 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 Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)
          , sortable Nothing (i18nCell MsgQualificationAuditDuration    & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
              foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
          , 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
  , ltcCompany        :: Maybe Text
  , ltcCompanyNumbers :: CsvSemicolonList Int
  , ltcValidUntil     :: Day
  , ltcLastRefresh    :: Day
  , ltcFirstHeld      :: Day
  , ltcBlockStatus    :: Maybe Bool
  , ltcBlockFrom      :: Maybe UTCTime
  , ltcLmsIdent       :: LmsIdent
  , ltcLmsStatus      :: Maybe LmsStatus
  , ltcLmsStatusDay   :: Maybe UTCTime
  , ltcLmsStarted     :: UTCTime
  , ltcLmsDatePin     :: 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"
    , ltcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
    , ltcCompanyNumbers = CsvSemicolonList [27,69]
    , ltcValidUntil     = succ compDay
    , ltcLastRefresh    = compDay
    , ltcFirstHeld      = pred $ pred compDay
    , ltcBlockStatus    = Nothing
    , ltcBlockFrom      = Nothing
    , ltcLmsIdent       = LmsIdent "abcdefgh"
    , ltcLmsStatus      = Just LmsSuccess
    , ltcLmsStatusDay   = Just compTime
    , ltcLmsStarted     = compTime
    , ltcLmsDatePin     = compTime
    , 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    , SomeMessage MsgLmsUser)
    , ('ltcEmail          , SomeMessage MsgTableLmsEmail)
    , ('ltcCompany        , SomeMessage MsgTableCompanies)
    , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
    , ('ltcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
    , ('ltcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
    , ('ltcFirstHeld      , SomeMessage MsgTableQualificationFirstHeld)
    , ('ltcBlockStatus    , SomeMessage MsgInfoQualificationBlockStatus)
    , ('ltcBlockFrom      , SomeMessage MsgInfoQualificationBlockFrom)
    , ('ltcLmsIdent       , SomeMessage MsgTableLmsIdent)
    , ('ltcLmsStatus      , SomeMessage MsgTableLmsStatus)
    , ('ltcLmsStatusDay   , SomeMessage MsgTableLmsStatusDay)
    , ('ltcLmsStarted     , SomeMessage MsgTableLmsStarted)
    , ('ltcLmsDatePin     , SomeMessage MsgTableLmsDatePin)
    , ('ltcLmsReceived    , SomeMessage MsgTableLmsReceived)
    , ('ltcLmsEnded       , SomeMessage MsgTableLmsEnded)
    ]


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

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

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

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

queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(sqlLOJproj 2 2)


type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool)

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

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

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

resultQualBlock :: Traversal' LmsTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _4 . _Just

resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _5 . _unValue . _Just

resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _6

resultValidQualification :: Lens' LmsTableData Bool
resultValidQualification = _dbrOutput . _7 . _unValue

instance HasEntity LmsTableData User where
  hasEntity = resultUser

instance HasUser LmsTableData where
  hasUser = resultUser . _entityVal

instance HasEntity LmsTableData QualificationUser where
  hasEntity = resultQualUser

instance HasQualificationUser LmsTableData where
  hasQualificationUser = resultQualUser . _entityVal  

data LmsTableAction = LmsActNotify
                    | LmsActRenewNotify
                    | LmsActRenewPin
                    | LmsActReset
                    | LmsActRestart
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)
  
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id

data LmsTableActionData = LmsActNotifyData
                        | LmsActRenewNotifyData
                        | LmsActRenewPinData            -- no longer used
                        | LmsActResetData
                            { lmsActRestartExtend  :: Maybe Integer
                            , lmsActRestartUnblock :: Maybe Bool 
                            , lmsActRestartNotify  :: Maybe Bool
                            }
                        | LmsActRestartData  
                            { lmsActRestartExtend  :: Maybe Integer
                            , lmsActRestartUnblock :: Maybe Bool 
                            , lmsActRestartNotify  :: Maybe Bool
                            }
  deriving (Eq, Ord, Read, Show, Generic)

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

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

isResetAct :: LmsTableActionData -> Bool
isResetAct LmsActResetData{}    = True
isResetAct _                    = False

isResetRestartAct :: LmsTableActionData -> Bool
isResetRestartAct LmsActRestartData{}  = True
isResetRestartAct other                = isResetAct other


lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
  -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
                , E.SqlExpr (Entity User)
                , E.SqlExpr (Entity LmsUser)
                , E.SqlExpr (Maybe (Entity QualificationUserBlock))
                , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
                , E.SqlExpr (E.Value Bool)
                )
lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = 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 notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all;
    --  experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest
    E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
      E.&&. qualBlock `isLatestBlockBefore` E.now_
    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        
    -- 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 type of subSelect does not seem to support this!
                           E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder                                                        
    return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)


mkLmsTable :: ( Functor h, ToSortable h
              , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))) cols
              )
           => Bool
           -> Entity Qualification
           -> Map LmsTableAction (AForm Handler LmsTableActionData)           
           -> (Map CompanyId Company -> cols)
           -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
           -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
  now <- liftIO getCurrentTime
  -- lookup all companies 
  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do 
    cmps <- selectList [] [] -- [Asc CompanyShorthand]
    return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
  let            
    csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
    dbtIdent :: Text
    dbtIdent = "lms"
    dbtSQLQuery = lmsTableQuery now qid
    dbtRowKey = queryUser >>> (E.^. UserId)
    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do
      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
      return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ)
    dbtColonnade = cols cmpMap
    dbtSorting = mconcat
      [ single $ sortUserNameLink   queryUser
      , single $ sortUserEmail      queryUser
      , single $ sortUserMatriclenr queryUser
      , single ("valid-until"   , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserValidUntil))
      -- , single ("validity"      , SortColumn         $ queryQualUser  >>> validQualification nowaday)
      , single ("last-refresh"  , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserLastRefresh))
      , single ("first-held"    , SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserFirstHeld))
      , single ("blocked"       , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
      , single ("schedule-renew", SortColumnNullsInv $ queryQualUser  >>> (E.^. QualificationUserScheduleRenewal))
      , single ("ident"     , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserIdent))
      , single ("pin"       , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserPin))
      -- , single ("status"    , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
      , single ("status"    , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
                                                                              , queryLmsUser row E.^. LmsUserNotified
                                                                              ](queryLmsUser row E.^. LmsUserStarted))

      , single ("started"   , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserStarted))
      , single ("datepin"   , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserDatePin))
      , single ("received"  , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserReceived))
      , single ("notified"  , SortColumnNullsInv $ queryLmsUser  >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
      , single ("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 ("ident"   , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
      , single ("status"  , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
      -- , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
      , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
      -- , 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 ("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 $ ciOriginal criterion
                E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
        )        
      , single ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
            Nothing -> E.false
            Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
                E.on     $ usrAvs E.^. UserAvsPersonId  E.==. avsCard E.^. UserAvsCardPersonId  
                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user    E.^. UserId
                    E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
          )
      , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
          | Set.null criteria -> E.true
          | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
        )
      ]
    dbtFilterUI mPrev = mconcat
      [ fltrUserNameEmailHdrUI MsgLmsUser mPrev    
      , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
      , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
      , prismAForm (singletonFilter "avs-card" )        mPrev $ aopt textField (fslI MsgAvsCardNo)
      , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
      , prismAForm (singletonFilter "ident"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
      , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
      , prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
      , prismAForm (singletonFilter "status"  . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
      -- , 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     resultCompanyUser >>= getCompanies)
          <*> (view     resultCompanyUser >>= getCompanyNos)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
          <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
          <*>  preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
          <*>  view    (resultLmsUser  . _entityVal . _lmsUserIdent)
          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatus)
          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStatusDay)
          <*>  view    (resultLmsUser  . _entityVal . _lmsUserStarted)
          <*>  view    (resultLmsUser  . _entityVal . _lmsUserDatePin)
          <*>  view    (resultLmsUser  . _entityVal . _lmsUserReceived)
          <*>  view    (resultLmsUser  . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
          <*>  view    (resultLmsUser  . _entityVal . _lmsUserEnded)
        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of 
          []        -> pure   Nothing
          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
        
    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
  now <- liftIO getCurrentTime
  let nowaday = utctDay now
  msgResetInfo      <- messageIconI Info    IconNotificationNonactive MsgLmsActResetInfo
  msgRestartWarning <- messageIconI Warning IconWarning               MsgLmsActRestartWarning

  ((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
          , singletonMap LmsActReset $ LmsActResetData 
              <$> aopt      intField (fslI MsgLmsActRestartExtend)  Nothing  
              <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
              <*> aopt checkBoxField (fslI MsgLmsActNotify)         Nothing              
              <*  aformMessage msgResetInfo
          , singletonMap LmsActRestart $ LmsActRestartData 
              <$> aopt      intField (fslI MsgLmsActRestartExtend)  Nothing  
              <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
              <*> aopt checkBoxField (fslI MsgLmsActNotify)         Nothing
              -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
              <*  aformMessage msgRestartWarning              
          ]        
        colChoices cmpMap = mconcat
          [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
          , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
          , colUserEmail
          , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
                        ]
              in intercalate spacerCell cs
          , colUserMatriclenr isAdmin
          -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)          
          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
          , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
          , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
          , sortable (Just "blocked")       (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
              qualificationValidReasonCell'' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row (row ^. resultValidQualification) -- TODO: resultValidQualification for debugging only
          -- DEBUG
          -- , sortable Nothing (i18nCell MsgQualificationValidIndicator) $ \(view resultValidQualification -> b) -> iconBoolCell b -- TODO: just for debugging
          -- DEBUG
          , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal  & cellTooltip MsgTableQualificationNoRenewalTooltip
                                                                                    )  $ \(   view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
          , sortable (Just "ident")     (i18nCell MsgTableLmsIdent)    $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
          , sortable (Just "pin")       (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
                                                                         ) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin                  -> pin) -> textCell pin
          , sortable (Just "status")    (i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin $ qent ^. _entityVal . _qualificationAuditDuration))
                                                                       $ \(view $ resultLmsUser . _entityVal -> lmsUserVal) -> lmsStatusCell isAdmin Nothing lmsUserVal
          , sortable (Just "started")   (i18nLms  MsgTableLmsStarted)  $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted  -> d) ->         dateTimeCell d
          , sortable (Just "datepin")   (i18nLms  MsgTableLmsDatePin)  $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin  -> d) ->         dateTimeCell d
          , sortable (Just "received")  (i18nLms  MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d
          --, sortable (Just "notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser  . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
          , sortable (Just "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      = 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 :: 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}                          
                          <p>
                            <a href=@{lprLink}>
                              _{MsgPrintJobs}
                        |]
                        -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
                    _ -> mempty

              in if notNotified
                  then mempty
                  else cIcon <> spacerCell <> cDate <> cAckDates
          -- , sortable (Just "notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
          , sortable (Just "ended")     (i18nLms MsgTableLmsEnded)    $ \(view $ resultLmsUser  . _entityVal . _lmsUserEnded    -> d) -> foldMap dateTimeCell d
          ]
          where
            -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
            i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
        psValidator = def & defaultSorting [SortDescBy "started", SortDescBy "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) | isResetRestartAct action -> do
      let usersList = Set.toList selectedUsers      
          numUsers  = Set.size   selectedUsers
          isReset   = isResetAct action
          actRestartExtend  = action & lmsActRestartExtend  
          actRestartUnblock = action & lmsActRestartUnblock 
          actRestartNotify  = action & lmsActRestartNotify  

      chgUsers <- runDB $ do 
        when (actRestartUnblock == Just True) $ do
          oks <- qualificationUserBlocking qid usersList True Nothing (Left $ bool "Manueller LMS Neustart" "Manuelle LMS Zurücksetzung" isReset) (fromMaybe True actRestartNotify)
          addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers

        whenIsJust actRestartExtend $ \extDays -> do
          let cutoff    = addDays extDays nowaday
          shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList 
            [ QualificationUserQualification ==. qid
            , QualificationUserUser <-. usersList            
            , QualificationUserValidUntil <. cutoff
            ] []          
          forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"

        fromIntegral <$> (if isReset
            then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
                                    ++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired]))     [LmsUserResetTries =. True]
            else deleteWhereCount  [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
          )

      unless isReset $ 
        forM_ selectedUsers $ \uid ->
          queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }

      runDB $ forM_ selectedUsers $ \uid -> 
        audit $ TransactionLmsReset   
          { transactionQualification   = qid          
          , transactionLmsUser         = uid
          , transactionLmsReset        = isReset
          , transactionLmsResetExtend  = actRestartExtend 
          , transactionLmsResetUnblock = actRestartUnblock
          , transactionLmsResetNotify  = actRestartNotify 
          }

      let mStatus  = bool Success Warning $ chgUsers < numUsers
      addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers
      reloadKeepGetParams $ LmsR sid qsh

    (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do      
      numExaminees <- runDB $ do
        okUsers <- selectList [ LmsUserQualification  ==. qid                       -- matching qualification
                              , LmsUserEnded          ==. Nothing                   -- not yet deleted
                              , LmsUserStatus         ==. Nothing                   -- not yet decided
                              , LmsUserUser           <-. Set.toList selectedUsers  -- selected
                              ] []
        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) $
            queueJob' $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False }
        return $ length okUsers
      let numSelected  = length selectedUsers
          diffSelected = numSelected - numExaminees
          mstat        = bool Success Warning $ diffSelected /= 0 
      when (isRenewPinAct action) $ addMessageI mstat   $ MsgLmsPinRenewal       numExaminees
      when (isNotifyAct action)   $ addMessageI mstat   $ MsgLmsNotificationSend numExaminees
      when (diffSelected /= 0)    $ addMessageI Warning $ MsgLmsActionFailed     diffSelected
      reloadKeepGetParams $ LmsR sid qsh
    _ -> addMessageI Error MsgUnauthorized -- should not happen

  let heading = citext2widget $ "LMS " <> qualificationName quali
  siteLayout heading $ do
    setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh
    LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
    $(widgetFile "lms")

-- redirect to a specific lms user
getLmsIdentR :: SchoolId -> QualificationShorthand -> LmsIdent -> Handler Html
getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)])

-- intended to be viewed primarily in a modal, wie lmsStatusCell
getLmsUserAllR :: CryptoUUIDUser -> Handler Html
getLmsUserAllR = viewLmsUserR Nothing Nothing

getLmsUserSchoolR :: CryptoUUIDUser -> SchoolId -> Handler Html
getLmsUserSchoolR uuid sid = viewLmsUserR (Just sid) Nothing uuid

getLmsUserR :: SchoolId -> QualificationShorthand -> CryptoUUIDUser -> Handler Html
getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh)

viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html
viewLmsUserR msid mqsh uuid = do
  uid <- decrypt uuid
  now <- liftIO getCurrentTime   
  (user@User{userDisplayName}, quals, qblocks) <- 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.and $
            (E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes 
              [ (qual E.^. QualificationSchool     E.==.) . E.val <$> msid
              , (qual E.^. QualificationShorthand  E.==.) . E.val <$> mqsh
              ]
          Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
          pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr)
    bs :: Map.Map QualificationUserId [(Entity QualificationUserBlock, Ex.Value (Maybe UserDisplayName))]
        <- foldMapM (\(_, mbqu, _, _) -> case mbqu of
              Nothing -> pure mempty
              Just (Entity quid _) -> do
                blocks <- Ex.select $ do 
                  (qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock
                    `Ex.leftJoin` Ex.table @User
                    `Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId)
                  Ex.where_ $ qBlock Ex.^. QualificationUserBlockQualificationUser Ex.==. Ex.val quid
                  Ex.orderBy [Ex.desc (qBlock Ex.^. QualificationUserBlockFrom)]
                  pure (qBlock, qbUsr Ex.?. UserDisplayName)
                return $ Map.singleton quid blocks
            ) qs
    return (usr, qs, Map.filter notNull bs)
  let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]  
  siteLayout heading $ do
    setTitle $ toHtml userDisplayName
    $(widgetFile "lms-user")    
