{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# OPTIONS -Wno-unused-imports #-} -- TODO: remove me, for debugging only {-# OPTIONS -Wno-redundant-constraints #-} -- TODO: remove me, for debugging only module Handler.LMS ( getLmsAllR , getLmsSchoolR , getLmsR , postLmsR , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR , getLmsResultR , postLmsResultR , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR ) where import Import import Handler.Utils import Handler.Utils.Csv import Handler.Utils.LMS import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Conduit.List as C import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import 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 getLmsAllR :: Handler Html getLmsAllR = error "TODO" getLmsSchoolR :: SchoolId -> Handler Html getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-school", toPathPiece ssh)]) {- --redirect with filering getLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR ssh qsh = redirect (LmsAllR, [("qualification-school" , toPathPiece ssh) ,("qualification-shorthand", toPathPiece qsh) ]) -} {- data LmsUserTableCsv = LmsUserTableCsv -- for csv export only { csvLmsUserIdent :: LmsIdent , csvLmsUserPin :: Text , csvLmsUserReset, cvsLmsUserRemove, cvsLmsUserIntern :: Int } data LmsCsvExportData = LmsCsvExportData type LmsUserTableExpr = E.SqlExpr (Entity LmsUser) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type LmsUserTableData = DBRow ( Entity LmsUser , Maybe (Entity User) ) queryLmsUser :: Getter LmsUserTableExpr (E.SqlExpr (Entity LmsUser)) queryLmsUser = to $(E.sqlLOJproj 2 1) queryUser :: Getter LmsUserTableExpr (E.SqlExpr (Maybe (Entity User))) queryUser = to $(E.sqlLOJproj 2 2) resultLmsUser :: Lens' LmsUserTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _1 resultUser :: Lens' LmsUserTableData (Maybe (Entity User)) resultUser = _dbrOutput . _2 getLmsR, postLmsR:: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do _qid <- runDB . getKeyBy404 $ SchoolQualificationShort sid qsh -- TODO !!! filter table by qid !!! dbtCsvName <- csvLmsUserFilename let dbtIdent = "lmsUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtSQLQuery = runReaderT $ do lmsUser <- view queryLmsUser user <- view queryUser lift $ do E.on $ E.just (lmsUser E.^. LmsUserUser) E.==. user E.?. UserId -- TODO where? return (lmsUser, user) dbtRowKey = queryLmsUser >>> (E.^. LmsUserId) dbtProj = dbtProjSimple $ \(lmsUser, user) -> do -- return ("abcdefgh", "12345678", False, False, True) return ( lmsUser E.^. LmsUserIdent , lmsUser E.^. LmsUserPin , lmsUser E.^. LmsUserResetPin , lmsUser E.^. LmsUserResetPin -- , True) -- works, so we need a simple type here indeed , isJust $ E.unValue (user E.?. UserCompanyPersonalNumber)) dbtColonnade = mempty --TODO dbtSorting = mempty dbtFilter = mempty dbtFilterUI = mempty dbtParams = def -- TODO: wip, for reference, see e.g. Handler.Course.Users or Handler.Exam. dbtCsvEncode = do return $ DBTCsvEncode { dbtCsvExportForm = def , dbtCsvDoEncode = \LmsCsvExportData{} -> C.mapM $ \(_lmsUserTableId, row) -> do mitarbeiter <- return 1 return $ LmsUserTableCsv (row ^. resultUser . _entityVal . _lmsUserIdent) (row ^. resultUser . _entityVal . _lmsUserPin) (row ^. resultUser . _entityVal . _lmsUserResetPin . to fromEnum) (row ^. resultUser . _entityVal . _lmsUserDelete . to fromEnum) mitarbeiter , dbtCsvName , dbtCsvNoExportData = Nothing , dbtCsvHeader = def -- return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def , dbtCsvExampleData = Nothing } -- TODO wip, for reference see e.g. Handler.Exam.Users dbtCsvDecode = Nothing -- Just DBTCsvDecode -- { dbtCsvRowKey = _1 -- , dbtCsvComputeActions = _2 -- , dbtCsvClassifyAction = _3 -- , dbtCsvCoarsenActionClass = _4 -- , dbtCsvValidateActions = _5 -- , dbtCsvExecuteActions = _6 -- <- actions based on sent data here -- , dbtCsvRenderKey = _7 -- , dbtCsvRenderActionClass = _8 -- , dbtCsvRenderException = _9 -- } psValidator = def lmsTable = dbTable psValidator DBTable{..} let lmsTable = [whamlet|TODO|] -- TODO: remove me, just for debugging siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms $(widgetFile "lms") -} --- old above, new below type LmsResultTableExpr = ( E.SqlExpr (Entity Qualification) `E.InnerJoin` E.SqlExpr (Entity LmsResult) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) queryQualification :: LmsResultTableExpr -> E.SqlExpr (Entity Qualification) queryQualification = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryLmsResult :: LmsResultTableExpr -> E.SqlExpr (Entity LmsResult) queryLmsResult = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryLmsUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) queryLmsUser = $(sqlLOJproj 3 2) queryUser :: LmsResultTableExpr -> E.SqlExpr (Maybe (Entity User)) queryUser = $(sqlLOJproj 3 3) type LmsResultTableData = DBRow (Entity Qualification, Entity LmsResult, Maybe (Entity LmsUser), Maybe (Entity User)) instance HasEntity LmsResultTableData LmsResult where hasEntity = _dbrOutput . _2 {- MaybeHasUser only! instance HasUser LmsResultTableData where hasUser = _dbrOutput . _4 . _entityVal -} resultQualification :: Lens' LmsResultTableData (Entity Qualification) resultQualification = _dbrOutput . _1 resultLmsResult :: Lens' LmsResultTableData (Entity LmsResult) resultLmsResult = _dbrOutput . _2 resultLmsUser :: Traversal' LmsResultTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just resultUser :: Traversal' LmsResultTableData (Entity User) resultUser = _dbrOutput . _4 . _Just mkLmsTable :: QualificationId -> DB (Any, Widget) mkLmsTable qid = do let resultDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do qualification <- asks queryQualification lmsResult <- asks queryLmsResult lmsUser <- asks queryLmsUser user <- asks queryUser lift $ do E.on $ qualification E.^. QualificationId E.==. lmsResult E.^. LmsResultQualification E.on $ lmsUser E.?. LmsUserIdent E.==. E.just (lmsResult E.^. LmsResultIdent) E.on $ lmsUser E.?. LmsUserUser E.==. user E.?. UserId E.where_ $ qualification E.^. QualificationId E.==. E.val qid return (qualification, lmsResult, lmsUser, user) dbtRowKey = queryLmsResult >>> (E.^. LmsResultId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtColonnade = dbColonnade $ mconcat [ sortable (Just "school") (i18nCell MsgTableSchool) $ \(view $ resultQualification . _entityVal . _qualificationSchool -> schoolShorthand) -> wgtCell $ toWgt schoolShorthand , sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsResult . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ resultLmsResult . _entityVal . _lmsResultSuccess -> success) -> dayCell success ] -- TODO: add more columns for manual debugging view !!! dbtSorting = Map.fromList [ ("school" , SortColumn $ queryQualification >>> (E.^. QualificationSchool)) , (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) -- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) , (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilter = Map.fromList [ ("school" , FilterColumn . E.mkExactFilter $ views (to queryQualification) (E.^. QualificationSchool)) , (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) , (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter "school" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool) , prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsSuccess) ] 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 <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh view _2 <$> mkLmsTable qid siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult $(widgetFile "lms")