diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index dda27d0aa..e9fc4411b 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -477,8 +477,8 @@ mkLicenceTable dbtIdent aLic apids = do return (usrAvs, user, qualUser, qual) dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? -- Not sure what changes here: - -- dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) - dbtProj = dbtProjFilteredPostId + dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali) + -- dbtProj = dbtProjFilteredPostId dbtColonnade = mconcat [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 81395527c..302a59ebe 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -118,11 +118,11 @@ mkLmsAllTable isAdmin = do cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - E.&&. validQualification (utctDay now) quser + E.&&. validQualification (utctDay now) quser -- 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? + dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference? adminable = if isAdmin then sortable else \_ _ _ -> mempty dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool @@ -351,17 +351,9 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do return (qualUser, user, lmsUser, printAcknowledged) -newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } - -instance Default LmsTableFilterProj where - def = LmsTableFilterProj - { ltProjFilterMayAccess = Nothing } - -makeLenses_ ''LmsTableFilterProj - mkLmsTable :: forall h p cols act act'. ( Functor h, ToSortable h - , Ord act, PathPiece act, RenderMessage UniWorX act + --, Ord act, PathPiece act, RenderMessage UniWorX act , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols ) => Bool @@ -370,18 +362,18 @@ mkLmsTable :: forall h p cols act 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 +mkLmsTable _isAdmin (Entity qid quali) _acts cols psValidator = do now <- liftIO getCurrentTime -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here let - currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) + -- currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) nowaday = utctDay now _mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" dbtSQLQuery q = lmsTableQuery qid q - dbtRowKey = queryUser >>> (E.^. UserId) + dbtRowKey = \x -> ((queryUser >>> (E.^. UserId)) x, (queryLmsUser >>> (E.^. LmsUserId)) x) dbtProj = dbtProjId -- dbtProjFilteredPostId -- dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- qusr <- view $ _dbtProjRow . resultQualUser @@ -435,7 +427,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do -- , if isNothing mbRenewal then mempty -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) -- ] - dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) @@ -463,20 +455,21 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) dbtCsvDecode = Nothing dbtExtraReps = [] - dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else - DBParamsForm - { dbParamsFormMethod = POST - , dbParamsFormAction = Just $ SomeRoute currentRoute - , dbParamsFormAttrs = [] - , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional - = renderAForm FormStandard - $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing - , dbParamsFormEvaluate = liftHandler . runFormPost - , dbParamsFormResult = id - , dbParamsFormIdent = def - } + dbtParams = def + -- dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else + -- DBParamsForm + -- { dbParamsFormMethod = POST + -- , dbParamsFormAction = 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 @@ -500,7 +493,7 @@ getLmsR = postLmsR postLmsR sid qsh = do isAdmin <- hasReadAccessTo AdminR currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler - ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do + (mkTbl, Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) acts = mconcat @@ -510,7 +503,7 @@ postLmsR sid qsh = do ] 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" - colUserNameLinkHdr MsgLmsUser AdminUserR + colUserNameLinkHdr MsgLmsUser AdminUserR , colUserEmail , 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 @@ -572,9 +565,11 @@ postLmsR sid qsh = do where -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a _i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg - psValidator = def & defaultPagesize (PagesizeLimit 10) -- & forceFilter "may-access" (Any True) - tbl <- mkLmsTable isAdmin qent acts colChoices psValidator - return (tbl, qent) + psValidator = def -- & defaultPagesize (PagesizeLimit 10) -- & forceFilter "may-access" (Any True) + -- tbl <- mkLmsTable isAdmin qent acts colChoices psValidator + let mkTbl = mkLmsTable isAdmin qent acts colChoices psValidator + return (mkTbl, qent) + (lmsRes, lmsTable) <- runDB mkTbl -- maybe it needs to be within its own runDB? NOPE, that is not the reason. :( formResult lmsRes $ \case _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 9de3b3292..c59d3b68e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -527,6 +527,7 @@ fillDb = do qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466" qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing + insertMany_ [Qualification mi sh ln Nothing Nothing Nothing Nothing False Nothing Nothing | n <- [111..333], let sh = CI.mk $ "T" <> tshow n, let ln = CI.mk $ "Testqualifikation " <> tshow n] void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True -- TODO: better dates! void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True -- TODO: better dates! void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True -- TODO: better dates!