{-# 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.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 mkLmsTable :: Entity Qualification -> DB (Any, Widget) mkLmsTable (Entity qid quali) = do now <- liftIO getCurrentTime let nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday resultDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do qualUser <- asks queryQualUser user <- asks queryUser lmsUser <- asks queryLmsUser lift $ 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) dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat [ 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-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 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-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 } dbtParams = def dbtIdent :: Text dbtIdent = "qualification" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] resultDBTableValidator = def -- & defaultSorting [SortAscBy csvLmsIdent] dbTable resultDBTableValidator resultDBTable getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do (lmsTable, quali) <- runDB $ do qent@(Entity _qid quali) <- getBy404 $ SchoolQualificationShort sid qsh tbl <- view _2 <$> mkLmsTable qent return (tbl, quali) let heading = citext2widget $ qualificationName quali siteLayout heading $ do setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh $(widgetFile "lms")