Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
SJost
commit
eb4239b728
@ -159,16 +159,11 @@ 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 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
|
||||
(\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
|
||||
Nothing -> mempty
|
||||
(Just sid) -> anchorCellM (CSubmissionR tid csh shn <$> encrypt sid <*> pure SubShowR)
|
||||
tickmark
|
||||
]
|
||||
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
|
||||
sheetTable <- dbTable validator $ DBTable
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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{..},_) ->
|
||||
|
||||
@ -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', anchorCellM
|
||||
, formCell, DBFormResult, getDBFormResult
|
||||
, dbRow, dbSelect
|
||||
) where
|
||||
@ -192,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 :: *
|
||||
|
||||
@ -224,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
|
||||
@ -246,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
|
||||
|
||||
@ -369,14 +378,23 @@ stringCell = textCell
|
||||
i18nCell = textCell
|
||||
textCell msg = cell [whamlet|_{msg}|]
|
||||
|
||||
anchorCell :: IsDBTable m a
|
||||
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 = cell $(widgetFile "table/cell/link")
|
||||
where
|
||||
route = mkRoute val
|
||||
widget = mkWidget val
|
||||
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
|
||||
|
||||
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
|
||||
|
||||
newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user