fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Further refine links in dbTable

Browse Source
This commit is contained in:
Gregor Kleen 2018-07-05 11:55:26 +02:00
parent e84339b011
commit cf76466517
2 changed files with 20 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Handler/Home.hs
View File

@ -153,10 +153,10 @@ homeUser uid = do
cell [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{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)]

21
src/Handler/Utils/Table/Pagination.hs
View File

@ -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