From 68bf10f72f4892c44efa79a3bc663f858ca33875 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 5 Jul 2018 11:43:01 +0200 Subject: [PATCH 1/2] Cleanup links in dbTable --- src/Handler/Home.hs | 11 +++-------- src/Handler/Sheet.hs | 4 ++-- src/Handler/Submission.hs | 10 ++++------ src/Handler/Term.hs | 4 ++-- src/Handler/Utils/Table/Pagination.hs | 17 +++++++++++------ 5 files changed, 22 insertions(+), 24 deletions(-) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 681240986..e820dac45 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -153,16 +153,11 @@ homeUser uid = do cell [whamlet|#{display shn}|] , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } -> textCell $ display deadline - , sortable (Just "done") (textCell MsgDone) $ \dbrow@(DBRow{ dbrOutput=(_, _, _, _, E.Value mbsid) }) -> + , sortable (Just "done") (textCell MsgDone) $ \dbrow@(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> case mbsid of Nothing -> textCell (" " :: Text) - (Just sid) -> anchorCell - (\DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _mbsid) } -> - -- CSubmissionR tid csh shn scid SubShowR - CSheetR tid csh shn SubmissionOwnR - ) (\DBRow{ dbrOutput=(_, _, _, _, _mbsid) } -> - toWidget (tickmark :: Text) - ) dbrow + (Just sid) -> anchorCell (CSheetR tid csh shn SubmissionOwnR) + tickmark ] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] sheetTable <- dbTable validator $ DBTable diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index dcc595626..458c95265 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -219,8 +219,8 @@ getSShowR tid csh shn = do return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype - , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) - (\(E.Value fName,_,_) -> str2widget fName) + , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) + (\(E.Value fName,_,_) -> str2widget fName) , sortable Nothing "Freigabe" $ \(_,_, E.Value ftype) -> case ftype of SheetExercise -> textCell $ display $ sheetActiveFrom sheet diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 714f5b617..5a73ced6a 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -246,16 +246,14 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr Just isFile = origIsFile <|> corrIsFile in if - | Just True <- origIsFile -> anchorCell (\() -> CSubmissionR tid csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') - (\() -> [whamlet|#{fileTitle'}|]) - () + | Just True <- origIsFile -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') + ([whamlet|#{fileTitle'}|]) | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of Nothing -> cell mempty Just (_, Entity _ File{..}) - | isJust fileContent -> anchorCell (\() -> CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) - (\() -> [whamlet|_{MsgFileCorrected}|]) - () + | isJust fileContent -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) + ([whamlet|_{MsgFileCorrected}|]) | otherwise -> textCell MsgFileCorrected , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let origTime = fileModified . entityVal . snd <$> mOrig diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 877efce34..b3a6a3f5a 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -43,8 +43,8 @@ getTermShowR = do provideRep $ do let colonnadeTerms = widgetColonnade $ mconcat [ sortable Nothing "Kürzel" $ - anchorCell (\(Entity tid _, _) -> TermCourseListR tid) - (\(Entity tid _, _) -> [whamlet|#{display tid}|]) + anchorCell' (\(Entity tid _, _) -> TermCourseListR tid) + (\(Entity tid _, _) -> [whamlet|#{display tid}|]) , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termLectureStart , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index fad56aa03..62a42ffbd 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -14,6 +14,7 @@ , ScopedTypeVariables , TupleSections , RankNTypes + , MultiWayIf #-} module Handler.Utils.Table.Pagination @@ -28,7 +29,7 @@ module Handler.Utils.Table.Pagination , ToSortable(..), Sortable(..), sortable , dbTable , widgetColonnade, formColonnade - , textCell, stringCell, i18nCell, anchorCell + , textCell, stringCell, i18nCell, anchorCell, anchorCell' , formCell, DBFormResult, getDBFormResult , dbRow, dbSelect ) where @@ -369,14 +370,18 @@ stringCell = textCell i18nCell = textCell textCell msg = cell [whamlet|_{msg}|] -anchorCell :: IsDBTable m a +anchorCell' :: IsDBTable m a => (r -> Route UniWorX) -> (r -> Widget) -> (r -> DBCell m a) -anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link") - where - route = mkRoute val - widget = mkWidget val +anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val) + +anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a +anchorCell route widget = cell $ do + authResult <- liftHandlerT $ isAuthorized route False + if + | Authorized <- authResult -> $(widgetFile "table/cell/link") + | otherwise -> widget newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a)) From cf764665177358019d786ad70c8cbcb12aeff7a9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 5 Jul 2018 11:55:26 +0200 Subject: [PATCH 2/2] Further refine links in dbTable --- src/Handler/Home.hs | 6 +++--- src/Handler/Utils/Table/Pagination.hs | 21 +++++++++++++++++---- 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index e820dac45..7cb91dc30 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -153,10 +153,10 @@ homeUser uid = do cell [whamlet|#{display shn}|] , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } -> textCell $ display deadline - , sortable (Just "done") (textCell MsgDone) $ \dbrow@(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> + , sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> case mbsid of - Nothing -> textCell (" " :: Text) - (Just sid) -> anchorCell (CSheetR tid csh shn SubmissionOwnR) + Nothing -> mempty + (Just sid) -> anchorCellM (CSubmissionR tid csh shn <$> encrypt sid <*> pure SubShowR) tickmark ] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 62a42ffbd..aeedaea1f 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -29,7 +29,7 @@ module Handler.Utils.Table.Pagination , ToSortable(..), Sortable(..), sortable , dbTable , widgetColonnade, formColonnade - , textCell, stringCell, i18nCell, anchorCell, anchorCell' + , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM , formCell, DBFormResult, getDBFormResult , dbRow, dbSelect ) where @@ -193,7 +193,7 @@ restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> ov where restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p } -class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where +class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where type DBResult m x :: * -- type DBResult' m x :: * @@ -225,6 +225,10 @@ instance IsDBTable (WidgetT UniWorX IO) () where dbWidget Proxy Proxy = return runDBTable = return . join . fmap (view _2) +instance Monoid (DBCell (WidgetT UniWorX IO) ()) where + mempty = WidgetCell mempty mempty + (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c') + instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype) type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a @@ -247,6 +251,10 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget)) runDBTable = return . withFragment +instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where + mempty = FormCell mempty (return mempty) + (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c') + instance IsDBTable m a => IsString (DBCell m a) where fromString = cell . fromString @@ -370,15 +378,20 @@ stringCell = textCell i18nCell = textCell textCell msg = cell [whamlet|_{msg}|] +anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a +anchorCell = anchorCellM . return + anchorCell' :: IsDBTable m a => (r -> Route UniWorX) -> (r -> Widget) -> (r -> DBCell m a) anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val) -anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a -anchorCell route widget = cell $ do +anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a +anchorCellM routeM widget = cell $ do + route <- routeM authResult <- liftHandlerT $ isAuthorized route False + if | Authorized <- authResult -> $(widgetFile "table/cell/link") | otherwise -> widget