{-# 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 ( getLmsR , postLmsR , getLmsUsersR , postLmsUsersR , 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 {- 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 $ UniqueQualificationSchoolShort 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 -- required for import only data LmsResultTableCsv = LmsResultTableCsv { csvLRTident :: LmsIdent , csvLRTsuccess :: Day } deriving Generic makeLenses_ ''LmsResultTableCsv -- csv without headers instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices -- csv with headers -- TODO not yet supported lmsResultTableCsvHeader :: Csv.Header lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] instance ToNamedRecord LmsResultTableCsv where toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord [ csvLmsIdent Csv..= csvLRTident , csvLmsSuccess Csv..= csvLRTsuccess ] instance FromNamedRecord LmsResultTableCsv where parseNamedRecord (lsfHeaderTranslate -> csv) = LmsResultTableCsv <$> csv Csv..: csvLmsIdent <*> csv Csv..: csvLmsSuccess instance CsvColumnsExplained LmsResultTableCsv where csvColumnsExplanations _ = mconcat [ single csvLmsIdent MsgCsvColumnLmsIdent , single csvLmsSuccess MsgCsvColumnLmsSuccess ] where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single k v = singletonMap k [whamlet|_{v}|] data LmsResultCsvActionClass = LmsResultInsert deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id -- By coincidence the action type is identical to LmsResultTableCsv data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success , sumEncoding = TaggedObject "action" "data" } ''LmsResultCsvAction data LmsResultCsvException = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! deriving (Show, Generic, Typeable) instance Exception LmsResultCsvException embedRenderMessage ''UniWorX ''LmsResultCsvException id mkLmsTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkLmsTable sid qsh qid = do dbtCsvName <- csvFilenameLmsResult qsh let dbtCsvSheetName = dbtCsvName 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 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 [ (csvLmsIdent , SortColumn $ queryLmsResult >>> (E.^. LmsResultIdent)) -- , (csvLmsSuccess, SortColumn $ queryLmsResult >>> (E.^. LmsResultSuccess)) , (csvLmsSuccess, SortColumn $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilter = Map.fromList [ (csvLmsIdent , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsResult) (E.^. LmsResultIdent)) , (csvLmsSuccess, FilterColumn . E.mkExactFilter $ views (to queryLmsResult) (E.^. LmsResultSuccess)) ] dbtFilterUI = \mPrev -> mconcat [ 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 = "lms-result" dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvName , dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return lmsResultTableCsvHeader , dbtCsvExampleData = Nothing } where doEncode' = LmsResultTableCsv <$> view (resultLmsResult . _entityVal . _lmsResultIdent) <*> view (resultLmsResult . _entityVal . _lmsResultSuccess) dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later { dbtCsvRowKey = \LmsResultTableCsv{..} -> fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do yield $ LmsResultInsertData { lmsResultInsertIdent = csvLRTident dbCsvNew , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew } DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffExisting{} -> return () -- no merge TODO!!! ADD MERGE DUE TO Uniqueness! , dbtCsvClassifyAction = \LmsResultInsertData{} -> LmsResultInsert , dbtCsvCoarsenActionClass = \LmsResultInsert -> DBCsvActionNew -- there is only one action: insert into table , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvExecuteActions = do C.mapM_ $ \LmsResultInsertData{..} -> do now <- liftIO getCurrentTime void $ upsert LmsResult { lmsResultQualification = qid , lmsResultIdent = lmsResultInsertIdent , lmsResultSuccess = lmsResultInsertSuccess , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? } [ LmsResultSuccess =. lmsResultInsertSuccess , LmsResultTimestamp =. now ] -- queueDBJob?? -- todo -- audit return $ LmsResultR sid qsh , dbtCsvRenderKey = \_ LmsResultInsertData{..} -> do -- TODO: i18n [whamlet| $newline never Ident #{getLmsIdent lmsResultInsertIdent} # had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} |] , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text } 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 $ UniqueQualificationSchoolShort sid qsh view _2 <$> mkLmsTable sid qsh qid siteLayoutMsg MsgMenuLmsResult $ do setTitleI MsgMenuLmsResult $(widgetFile "lms")