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

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
SJost 2018-07-05 16:00:53 +02:00
commit eb4239b728
5 changed files with 37 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Handler/Home.hs
View File

@ -159,16 +159,11 @@ homeUser uid = do
cell [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|] cell [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } -> , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } ->
textCell $ display 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 case mbsid of
Nothing -> textCell (" " :: Text) Nothing -> mempty
(Just sid) -> anchorCell (Just sid) -> anchorCellM (CSubmissionR tid csh shn <$> encrypt sid <*> pure SubShowR)
(\DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _mbsid) } -> tickmark
-- CSubmissionR tid csh shn scid SubShowR
CSheetR tid csh shn SubmissionOwnR
) (\DBRow{ dbrOutput=(_, _, _, _, _mbsid) } ->
toWidget (tickmark :: Text)
) dbrow
] ]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
sheetTable <- dbTable validator $ DBTable sheetTable <- dbTable validator $ DBTable

4
src/Handler/Sheet.hs
View File

@ -219,8 +219,8 @@ getSShowR tid csh shn = do
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = widgetColonnade $ mconcat let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype [ 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)) , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
(\(E.Value fName,_,_) -> str2widget fName) (\(E.Value fName,_,_) -> str2widget fName)
, sortable Nothing "Freigabe" $ \(_,_, E.Value ftype) -> , sortable Nothing "Freigabe" $ \(_,_, E.Value ftype) ->
case ftype of case ftype of
SheetExercise -> textCell $ display $ sheetActiveFrom sheet SheetExercise -> textCell $ display $ sheetActiveFrom sheet

10
src/Handler/Submission.hs
View File

@ -246,16 +246,14 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
Just isFile = origIsFile <|> corrIsFile Just isFile = origIsFile <|> corrIsFile
in if in if
| Just True <- origIsFile -> anchorCell (\() -> CSubmissionR tid csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') | Just True <- origIsFile -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
(\() -> [whamlet|#{fileTitle'}|]) ([whamlet|#{fileTitle'}|])
()
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle' | otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
, sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of
Nothing -> cell mempty Nothing -> cell mempty
Just (_, Entity _ File{..}) Just (_, Entity _ File{..})
| isJust fileContent -> anchorCell (\() -> CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) | isJust fileContent -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
(\() -> [whamlet|_{MsgFileCorrected}|]) ([whamlet|_{MsgFileCorrected}|])
()
| otherwise -> textCell MsgFileCorrected | otherwise -> textCell MsgFileCorrected
, sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
origTime = fileModified . entityVal . snd <$> mOrig origTime = fileModified . entityVal . snd <$> mOrig

4
src/Handler/Term.hs
View File

@ -43,8 +43,8 @@ getTermShowR = do
provideRep $ do provideRep $ do
let colonnadeTerms = widgetColonnade $ mconcat let colonnadeTerms = widgetColonnade $ mconcat
[ sortable Nothing "Kürzel" $ [ sortable Nothing "Kürzel" $
anchorCell (\(Entity tid _, _) -> TermCourseListR tid) anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
(\(Entity tid _, _) -> [whamlet|#{display tid}|]) (\(Entity tid _, _) -> [whamlet|#{display tid}|])
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
stringCell $ formatTimeGerWD termLectureStart stringCell $ formatTimeGerWD termLectureStart
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->

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

@ -14,6 +14,7 @@
, ScopedTypeVariables , ScopedTypeVariables
, TupleSections , TupleSections
, RankNTypes , RankNTypes
, MultiWayIf
#-} #-}
module Handler.Utils.Table.Pagination module Handler.Utils.Table.Pagination
@ -28,7 +29,7 @@ module Handler.Utils.Table.Pagination
, ToSortable(..), Sortable(..), sortable , ToSortable(..), Sortable(..), sortable
, dbTable , dbTable
, widgetColonnade, formColonnade , widgetColonnade, formColonnade
, textCell, stringCell, i18nCell, anchorCell , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
, formCell, DBFormResult, getDBFormResult , formCell, DBFormResult, getDBFormResult
, dbRow, dbSelect , dbRow, dbSelect
) where ) where
@ -192,7 +193,7 @@ restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> ov
where where
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p } 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 :: *
-- type DBResult' m x :: * -- type DBResult' m x :: *
@ -224,6 +225,10 @@ instance IsDBTable (WidgetT UniWorX IO) () where
dbWidget Proxy Proxy = return dbWidget Proxy Proxy = return
runDBTable = return . join . fmap (view _2) 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 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) = ((FormResult a, Widget), Enctype)
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a 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 :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
runDBTable = return . withFragment 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 instance IsDBTable m a => IsString (DBCell m a) where
fromString = cell . fromString fromString = cell . fromString
@ -369,14 +378,23 @@ stringCell = textCell
i18nCell = textCell i18nCell = textCell
textCell msg = cell [whamlet|_{msg}|] 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 -> Route UniWorX)
-> (r -> Widget) -> (r -> Widget)
-> (r -> DBCell m a) -> (r -> DBCell m a)
anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link") anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
where
route = mkRoute val anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a
widget = mkWidget val 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)) newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))