From 39270bd7887f31c125c051caaf80f032c087bd9b Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 6 Sep 2018 17:06:36 +0200 Subject: [PATCH 01/28] First try for #174, needs more thinking though, see issue. --- src/Utils.hs | 10 ++++++++++ templates/default-layout.hamlet | 2 ++ templates/widgets/pageactionprime.hamlet | 3 --- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Utils.hs b/src/Utils.hs index e472e72ca..7bef82270 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -27,6 +27,7 @@ import Utils.PathPiece as Utils import Text.Blaze (Markup, ToMarkup) +import Control.Lens import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) @@ -174,6 +175,15 @@ trd3 (_,_,z) = z -- notNull = not . null +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe [h] = Just h +lastMaybe (_:t) = lastMaybe t + +lastMaybe' :: [a] -> Maybe a +lastMaybe' l = fmap snd $ l ^? _Snoc + + mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)] mergeAttrs = mergeAttrs' `on` sort where diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 87827d44f..4d4b024ac 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -15,6 +15,8 @@

+ $maybe back <- lastMaybe parents + #{snd back} $maybe headline <- contentHeadline ^{headline} $nothing diff --git a/templates/widgets/pageactionprime.hamlet b/templates/widgets/pageactionprime.hamlet index b12d7ae24..cce7e13e3 100644 --- a/templates/widgets/pageactionprime.hamlet +++ b/templates/widgets/pageactionprime.hamlet @@ -7,9 +7,6 @@ $if hasPageActions $of PageActionPrime (MenuItem label _mIcon route _callback)
  • #{label} - $of _ - $forall menuType <- menuTypes - $case menuType $of PageActionSecondary (MenuItem label _mIcon route _callback)
  • #{label} From 93a29d0ec9a23112df8fc1da0b088e904da3d73f Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 7 Sep 2018 17:39:36 +0200 Subject: [PATCH 02/28] SJ uses Lenses for great good or for havoc? Discuss! --- src/Handler/Course.hs | 33 +++++++++++++++++++---------- src/Handler/Profile.hs | 48 +++++++++++++++++++++++++++++++++++------- src/Utils/Lens.hs | 8 +++++++ src/Utils/TH.hs | 2 -- src/index.md | 5 ++++- 5 files changed, 74 insertions(+), 22 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index f8bddf741..9dd373ce9 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -16,7 +16,12 @@ module Handler.Course where import Import + +import Control.Lens +import Utils.Lens +import Utils.TH import Handler.Utils +import Handler.Utils.Table.Convenience -- import Data.Time import qualified Data.Text as T @@ -42,16 +47,21 @@ colCourse = sortable (Just "course") (i18nCell MsgCourse) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] -colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) -colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend - ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] ) - ( case courseDescription of - Nothing -> mempty - (Just descr) -> cell [whamlet| ^{modalStatic descr} |] - ) +-- colCourseDescr1 :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) +-- colCourseDescr1 = sortable (Just "course") (i18nCell MsgCourse) +-- $ \DBRow{ dbrOutput=(Entity _cid course, _, _, _) } -> +-- courseCell course -colDescription :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +-- colCourseDescr1 :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) +-- colCourseDescr1 = sortable (Just "course") (i18nCell MsgCourse) $ do +-- course <- view $ _dbrOutput . _1 . _entityVal +-- return $ courseCell course + +-- colCourseDescr1 :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) +-- colCourseDescr1 = colCourseDescr _1 + + +colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colDescription = sortable Nothing (i18nCell MsgCourseDescription) $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> case courseDescription of @@ -91,7 +101,8 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> - cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget + maybe mempty timeCell courseRegisterFrom + -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) @@ -178,7 +189,7 @@ getCourseListR :: Handler Html getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat - [ colCourseDescr + [ colCourseDescr _1 , colCShort , colTerm , maybe mempty (const colRegistered) muid diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 4bb62d344..6e4c640de 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -14,6 +14,8 @@ module Handler.Profile where import Import import Handler.Utils +import Handler.Utils.Table.Convenience + import Utils.Lens -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade @@ -142,6 +144,29 @@ postProfileR = do -- TODO getProfileR +---------------------------------------- +-- TODO: Are these really a good idea? +-- If yes: Move to appropriate Place: Utils.Lens and Utils.Table.Convenience + +-- instance HasCourse (DBRow (Entity Course, a)) where +-- course = _dbrOutput . _1 . _entityVal + +instance HasCourse a => HasCourse (Entity a) where + course = _entityVal . course + +instance HasCourse a => HasCourse (a,b) where + course = _1 . course + +-- instance {-# OVERLAPPABLE #-} HasCourse b => HasCourse (a,b) where +-- course = _2 . course + +instance HasCourse a => HasCourse (a,b,c,d) where + course = _1 . course + +instance HasCourse a => HasCourse (DBRow a) where + course = _dbrOutput . course + +-- getProfileDataR :: Handler Html @@ -153,23 +178,30 @@ getProfileDataR = do -- Tabelle mit allen Teilnehmer: Kurs (link), Datum courseTable <- do let -- should be inlined - -- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a) + courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a) courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad - Course{..} <- view $ _dbrOutput . _1 . _entityVal -- view == ^. + course <- view $ _dbrOutput . _1 . _entityVal -- view == ^. -- "preview _left" in order to match Either (result is Maybe) - return $ anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) - (citext2widget courseName) - --courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) - -- -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity CourseParticipant)) + return $ courseCell course + +-- termCol = sortable (Just "school") (i18nCell MsgCourseSchool) $ do +-- Course{..} <- view $ _dbrOutput . _1 . _entityVal +-- return $ anchorCell (TermsSchoolCourseListR + + courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) + -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value UTCTime)) courseData = \(course `E.InnerJoin` participant) -> do E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid - return (course, participant) + return (course, participant E.^. CourseParticipantRegistration) dbTableWidget' def $ DBTable { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = courseData , dbtColonnade = mconcat - [ courseCol + [ colCourseDescrG + , sortable (Just "time") (i18nCell MsgRegistered) $ do + regTime <- view $ _dbrOutput . _2 . _unValue + return $ timeCell regTime ] , dbtProj = return , dbtSorting = Map.fromList diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index f198e9a6b..e998bc1ca 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -7,9 +7,17 @@ module Utils.Lens ( module Utils.Lens ) where import Import.NoFoundation import Control.Lens as Utils.Lens +import qualified Database.Esqueleto as E (Value(..)) + +_unValue :: Lens' (E.Value a) a +_unValue f (E.Value a) = E.Value <$> f a makeClassy_ ''Entity makeClassy_ ''SheetCorrector +makeClassy_ ''Course + -- makeClassy_ ''Load + + diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 04eebdfa2..45bc84c7e 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -17,14 +17,12 @@ import Language.Haskell.TH ------------ -- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens -{- projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n) projNI n i = lamE [pat] rhs where pat = tupP (map varP xs) rhs = varE (xs !! (i - 1)) xs = [ mkName $ "x" ++ show j | j <- [1..n] ] --} --------------- -- Functions -- diff --git a/src/index.md b/src/index.md index fee16d2ba..bfac4bea2 100644 --- a/src/index.md +++ b/src/index.md @@ -74,7 +74,10 @@ Handler.Utils.Table.Pagination Handler.Utils.Table.Pagination.Types : `Sortable`-Headedness for colonnade - + +Handler.Utils.Table.Convenience + : extends dbTable with UniWorX specific functions, such as special courseCell + Handler.Utils.Templates : Modals From bf3a12d09d608d40c64735777d094ed3341b2c5f Mon Sep 17 00:00:00 2001 From: SJost Date: Sun, 9 Sep 2018 11:31:59 +0200 Subject: [PATCH 03/28] Sorting/Filter refactro Profile Data --- src/Handler/Course.hs | 9 ++-- src/Handler/Profile.hs | 51 ++++++++++++++++++----- src/Handler/Utils/Table/Convenience.hs | 57 ++++++++++++++++++++++++++ src/Utils/DB.hs | 11 ++++- 4 files changed, 113 insertions(+), 15 deletions(-) create mode 100644 src/Handler/Utils/Table/Convenience.hs diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 9dd373ce9..112f87361 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -172,9 +172,12 @@ makeCourseTable whereClause colChoices psValidator = do | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias) ) - , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias) +-- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if +-- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) +-- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias) +-- ) + , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) -> + emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?! ) , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 6e4c640de..6033da345 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PartialTypeSignatures #-} @@ -7,6 +8,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} module Handler.Profile where @@ -20,6 +22,7 @@ import Utils.Lens -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) @@ -147,6 +150,21 @@ postProfileR = do ---------------------------------------- -- TODO: Are these really a good idea? -- If yes: Move to appropriate Place: Utils.Lens and Utils.Table.Convenience +-- +-- Or Maybe make Course an instance of Data.Data and use biplate instead? +-- λ> ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [String] +-- ["a","b","c","d","e","f"] +-- it :: [String] +-- *Main Control.Lens Data.Data.Lens +-- λ> ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [Int] +-- [] +-- it :: [Int] +-- *Main Control.Lens Data.Data.Lens +-- λ> ("a",7,"b",["c","d"],(9,"e",8),"f",True) ^.. biplate :: [Integer] +-- [7,9,8] +-- it :: [Integer] + + -- instance HasCourse (DBRow (Entity Course, a)) where -- course = _dbrOutput . _1 . _entityVal @@ -168,6 +186,8 @@ instance HasCourse a => HasCourse (DBRow a) where -- +-- type CourseTableData = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) +-- NOTE: use procData instead as a flexible inlines Type signature getProfileDataR :: Handler Html getProfileDataR = do @@ -177,19 +197,24 @@ getProfileDataR = do -- Tabelle mit eigenen Kursen -- Tabelle mit allen Teilnehmer: Kurs (link), Datum courseTable <- do - let -- should be inlined - courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a) - courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad - course <- view $ _dbrOutput . _1 . _entityVal -- view == ^. - -- "preview _left" in order to match Either (result is Maybe) - return $ courseCell course + let + procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + procData = id + + -- should be inlined +-- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a) +-- courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad +-- course <- view $ _dbrOutput . _1 . _entityVal -- view == ^. +-- -- "preview _left" in order to match Either (result is Maybe) +-- return $ courseCell course -- termCol = sortable (Just "school") (i18nCell MsgCourseSchool) $ do -- Course{..} <- view $ _dbrOutput . _1 . _entityVal -- return $ anchorCell (TermsSchoolCourseListR - courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) - -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value UTCTime)) +-- courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) +-- -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value UTCTime)) courseData = \(course `E.InnerJoin` participant) -> do E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid @@ -205,10 +230,14 @@ getProfileDataR = do ] , dbtProj = return , dbtSorting = Map.fromList - [ ( "course" - , SortColumn $ \(course `E.InnerJoin` _) -> course E.^. CourseName ) + [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) + , ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration) + ] + , dbtFilter = Map.fromList + [ + ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand ) +-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) ] - , dbtFilter = mempty , dbtStyle = def } diff --git a/src/Handler/Utils/Table/Convenience.hs b/src/Handler/Utils/Table/Convenience.hs new file mode 100644 index 000000000..0aea84073 --- /dev/null +++ b/src/Handler/Utils/Table/Convenience.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +module Handler.Utils.Table.Convenience where + +import Import + +import Utils.Lens +import Handler.Utils +-- import Handler.Utils.Table.Pagination + + +-- Special cells + +timeCell :: IsDBTable m a => UTCTime -> DBCell m a +timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget + +-- Just for documentation purposes; inline the code instead: +maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a +maybeTimeCell = maybe mempty timeCell + +courseCell :: IsDBTable m a => Course -> DBCell m a +courseCell (Course {..}) = anchorCell link name `mappend` desc + where + link = CourseR courseTerm courseSchool courseShorthand CShowR + name = citext2widget courseName + desc = case courseDescription of + Nothing -> mempty + (Just descr) -> cell [whamlet| ^{modalStatic descr} |] + + +-- Generic Columns + +colCourseDescr :: (HasEntity c Course, HasDBRow s r, IsDBTable m a) => + ((c -> Const Course c) -> r -> Const Course r) -> Colonnade Sortable s (DBCell m a) +colCourseDescr courseLens = sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view $ _dbrOutput . courseLens . _entityVal + return $ courseCell crs + +colCourseDescr_ :: IsDBTable m a => Getting Course s Course -> Colonnade Sortable s (DBCell m a) +colCourseDescr_ getter = + sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view getter + return $ courseCell crs + +colCourseDescrG :: (HasCourse s, IsDBTable m a) => Colonnade Sortable s (DBCell m a) +colCourseDescrG = + sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view course + return $ courseCell crs + + + diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 084adf0e1..269b3b9bc 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -10,9 +10,18 @@ import ClassyPrelude.Yesod import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map - +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here +-- TODO: is this the right place? +emptyOrIn :: PersistField typ => + E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) +emptyOrIn criterion testSet + | Set.null testSet = E.val True + | otherwise = criterion `E.in_` E.valList (Set.toList testSet) + entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty From 45563750acf0f27a7418cb6924a8668b49425564 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 10 Sep 2018 14:38:19 +0200 Subject: [PATCH 04/28] School Handler Stub; Profile shows own courses with lean dbTable --- routes | 14 +++-- src/Application.hs | 1 + src/Handler/Profile.hs | 43 +++++++++++++-- src/Handler/School.hs | 53 ++++++++++++++++++ src/Handler/Utils/Table/Convenience.hs | 76 +++++++++++++++++++++++++- templates/profileData.hamlet | 5 ++ 6 files changed, 181 insertions(+), 11 deletions(-) create mode 100644 src/Handler/School.hs diff --git a/routes b/routes index d58947041..9604556ad 100644 --- a/routes +++ b/routes @@ -41,13 +41,15 @@ /profile ProfileR GET POST !free !free /profile/data ProfileDataR GET !free !free -/terms TermShowR GET !free -/terms/current TermCurrentR GET !free -/terms/edit TermEditR GET POST -/terms/#TermId/edit TermEditExistR GET -!/terms/#TermId TermCourseListR GET !free -!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free +/term TermShowR GET !free +/term/current TermCurrentR GET !free +/term/edit TermEditR GET POST +/term/#TermId/edit TermEditExistR GET +!/term/#TermId TermCourseListR GET !free +!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free +/school SchoolListR GET +/school/#SchoolId SchoolShowR GET -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free diff --git a/src/Application.hs b/src/Application.hs index 93bd35d76..c5b69f55f 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -52,6 +52,7 @@ import Handler.Profile import Handler.Users import Handler.Admin import Handler.Term +import Handler.School import Handler.Course import Handler.Sheet import Handler.Submission diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 6033da345..8c6d40a49 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -195,6 +195,38 @@ getProfileDataR = do -- mr <- getMessageRender -- Tabelle mit eigenen Kursen + ownCourseTable <- do + let procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) + procData = id + dbTableWidget' def $ DBTable + { dbtIdent = "courseOwnership" :: Text + , dbtStyle = def + , dbtSQLQuery = \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + return ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseId + , course E.^. CourseShorthand + ) + , dbtColonnade = mconcat + [ colsCourseLink' $ _dbrOutput +-- [ colsCourseLink $ (over each _unValue) . o_dbrOutput + ] + , dbtProj = return + , dbtSorting = Map.fromList + [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) + ] + , dbtFilter = Map.fromList + [ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + ] + } + -- Tabelle mit allen Teilnehmer: Kurs (link), Datum courseTable <- do let @@ -223,19 +255,22 @@ getProfileDataR = do { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = courseData , dbtColonnade = mconcat - [ colCourseDescrG + [ colsCourseCompleteG , sortable (Just "time") (i18nCell MsgRegistered) $ do regTime <- view $ _dbrOutput . _2 . _unValue return $ timeCell regTime ] , dbtProj = return , dbtSorting = Map.fromList - [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) + [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) + , ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) , ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration) ] , dbtFilter = Map.fromList - [ - ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand ) + [ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) + , ( "term" , FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) -- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) ] , dbtStyle = def diff --git a/src/Handler/School.hs b/src/Handler/School.hs new file mode 100644 index 000000000..fcd328996 --- /dev/null +++ b/src/Handler/School.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +module Handler.School where + +import Import + +-- import Control.Lens +-- import Utils.Lens +-- import Utils.TH +-- import Handler.Utils +-- import Handler.Utils.Table.Convenience +-- +-- -- import Data.Time +-- import qualified Data.Text as T +-- import Data.Function ((&)) +-- -- import Yesod.Form.Bootstrap3 +-- +-- import qualified Data.Set as Set +-- import qualified Data.Map as Map +-- +-- import Colonnade hiding (fromMaybe,bool) +-- +-- import qualified Database.Esqueleto as E +-- +-- import qualified Data.UUID.Cryptographic as UUID + + +getSchoolListR :: Handler Html +getSchoolListR = do + -- muid <- maybeAuthId + defaultLayout $ do + [whamlet|TODO: Liste aller Institute |] -- TODO + + +getSchoolShowR :: SchoolId -> Handler Html +getSchoolShowR ssh = do -- TODO + -- muid <- maybeAuthId + defaultLayout $ do + [whamlet|TODO: Informationen zu einem Institut |] -- TODO + diff --git a/src/Handler/Utils/Table/Convenience.hs b/src/Handler/Utils/Table/Convenience.hs index 0aea84073..de0169257 100644 --- a/src/Handler/Utils/Table/Convenience.hs +++ b/src/Handler/Utils/Table/Convenience.hs @@ -13,16 +13,51 @@ import Utils.Lens import Handler.Utils -- import Handler.Utils.Table.Pagination +import qualified Database.Esqueleto as E (Value(..)) + +-- newtype CourseLink = CourseLink (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId +type CourseLink = (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId +type CourseLink' = (E.Value TermId, E.Value SchoolId, E.Value CourseId, E.Value CourseShorthand) -- cannot be in Types due to CourseId + + -- Special cells timeCell :: IsDBTable m a => UTCTime -> DBCell m a timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget --- Just for documentation purposes; inline the code instead: +-- Just for documentation purposes; inline this code instead: maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a maybeTimeCell = maybe mempty timeCell +termCell :: IsDBTable m a => TermId -> DBCell m a +termCell tid = anchorCell link name + where + link = TermCourseListR tid + name = text2widget $ display tid + +schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a +schoolCell (Just tid) ssh = anchorCell link name + where + link = TermSchoolCourseListR tid ssh + name = text2widget $ display ssh +schoolCell Nothing ssh = anchorCell link name + where + link = SchoolShowR ssh + name = text2widget $ display ssh + +courseLinkCell :: IsDBTable m a => CourseLink -> DBCell m a +courseLinkCell (tid,ssh,_cid,csh) = anchorCell link name + where + link = CourseR tid ssh csh CShowR + name = citext2widget csh + +courseLinkCell' :: IsDBTable m a => CourseLink' -> DBCell m a +courseLinkCell' (E.Value tid, E.Value ssh,_cid,E.Value csh) = anchorCell link name + where + link = CourseR tid ssh csh CShowR + name = citext2widget csh + courseCell :: IsDBTable m a => Course -> DBCell m a courseCell (Course {..}) = anchorCell link name `mappend` desc where @@ -33,6 +68,7 @@ courseCell (Course {..}) = anchorCell link name `mappend` desc (Just descr) -> cell [whamlet| ^{modalStatic descr} |] + -- Generic Columns colCourseDescr :: (HasEntity c Course, HasDBRow s r, IsDBTable m a) => @@ -53,5 +89,43 @@ colCourseDescrG = crs <- view course return $ courseCell crs +colsCourseCompleteG :: (HasCourse s, IsDBTable m a) => Colonnade Sortable s (DBCell m a) +colsCourseCompleteG = mconcat + [ sortable (Just "term") (i18nCell MsgTerm) $ do + crs <- view course + return $ termCell $ courseTerm crs + , sortable (Just "school") (i18nCell MsgCourseSchool) $ do + crs <- view course + return $ schoolCell (Just $ courseTerm crs) (courseSchool crs) + , sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view course + return $ courseCell crs + ] + +colsCourseLink :: (IsDBTable m a) => Getting CourseLink s CourseLink -> Colonnade Sortable s (DBCell m a) +colsCourseLink getter = mconcat + [ sortable (Just "term") (i18nCell MsgTerm) $ do + crs <- view getter + return $ termCell $ crs ^. _1 + , sortable (Just "school") (i18nCell MsgCourseSchool) $ do + crs <- view getter + return $ schoolCell (Just $ crs ^. _1) (crs ^. _2) + , sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view getter + return $ courseLinkCell crs + ] + +colsCourseLink' :: (IsDBTable m a) => Getting CourseLink' s CourseLink' -> Colonnade Sortable s (DBCell m a) +colsCourseLink' getter = mconcat + [ sortable (Just "term") (i18nCell MsgTerm) $ do + crs <- view getter + return $ termCell $ crs ^. _1 . _unValue + , sortable (Just "school") (i18nCell MsgCourseSchool) $ do + crs <- view getter + return $ schoolCell (Just $ crs ^. _1 . _unValue) (crs ^. _2 . _unValue) + , sortable (Just "course") (i18nCell MsgCourse) $ do + crs <- view getter + return $ courseLinkCell' crs + ] diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 163063188..091daee66 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -8,6 +8,11 @@ TODO: Hier alle Daten in Tabellen anzeigen! +
    +

    Eigene Kurse +
    + ^{ownCourseTable} +

    Kursanmeldungen
    From f42673986859ea35f73069decce765b19d608beb Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 10 Sep 2018 15:12:48 +0200 Subject: [PATCH 05/28] Minor: missing headings added for school pages --- messages/uniworx/de.msg | 3 +++ src/Foundation.hs | 7 +++++++ src/Handler/Profile.hs | 13 ++++++++++--- src/Handler/Utils/Table/Convenience.hs | 1 + templates/profileData.hamlet | 15 +++++++++++++++ 5 files changed, 36 insertions(+), 3 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f68710517..e3576c5e4 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -27,6 +27,9 @@ InvalidInput: Eingaben bitte korrigieren. Term: Semester TermPlaceholder: W/S + vierstellige Jahreszahl +SchoolListHeading: Übersicht über verwaltete Institute +SchoolHeading school@SchoolName: Übersicht #{display school} + LectureStart: Beginn Vorlesungen Course: Kurs diff --git a/src/Foundation.hs b/src/Foundation.hs index 90371f955..88a4cad75 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -995,6 +995,13 @@ pageHeading (TermSchoolCourseListR tid ssh) School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh i18nHeading $ MsgTermSchoolCourseListHeading tid school +pageHeading (SchoolListR) + = Just $ i18nHeading MsgSchoolListHeading +pageHeading (SchoolShowR ssh) + = Just $ do + School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh + i18nHeading $ MsgSchoolHeading school + pageHeading (CourseListR) = Just $ i18nHeading $ MsgCourseListTitle pageHeading CourseNewR diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 8c6d40a49..20fd64af5 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -195,7 +195,7 @@ getProfileDataR = do -- mr <- getMessageRender -- Tabelle mit eigenen Kursen - ownCourseTable <- do + ownCourseTable <- do -- TODO: only display when non-empty let procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) procData = id @@ -277,10 +277,17 @@ getProfileDataR = do } -- Tabelle mit allen Abgaben und Abgabe-Gruppen - -- Tabelle mit allen Korrektor-Aufgaben + submissionTable <- do + let procData :: ((_)->a) + -> ((_)->a) + procData = id + return () -- Tabelle mit allen Tutorials + tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO + -- Tabelle mit allen Korrektor-Aufgaben + correctorTable <- return [whamlet| TOOD: Korrekturen anzeigen |] -- TODO -- Tabelle mit allen Klausuren und Noten - + examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO defaultLayout $ do $(widgetFile "profileData") $(widgetFile "dsgvDisclaimer") diff --git a/src/Handler/Utils/Table/Convenience.hs b/src/Handler/Utils/Table/Convenience.hs index de0169257..f3c6627d5 100644 --- a/src/Handler/Utils/Table/Convenience.hs +++ b/src/Handler/Utils/Table/Convenience.hs @@ -17,6 +17,7 @@ import qualified Database.Esqueleto as E (Value(..)) -- newtype CourseLink = CourseLink (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId type CourseLink = (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId +-- TODO: can we get rid of this type through lenses? type CourseLink' = (E.Value TermId, E.Value SchoolId, E.Value CourseId, E.Value CourseShorthand) -- cannot be in Types due to CourseId diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 091daee66..6b74fb278 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -18,6 +18,21 @@
    ^{courseTable} +
    +

    Übungsgruppen +
    + ^{tutorialTable} + +
    +

    Korrekturen +
    + ^{correctorTable} + +
    +

    Klausuren +
    + ^{examTable} +

    TODO: Knopf zum Löschen aller Daten erstellen From c4c5a6b05c07686158afb8da6d7741ad6bab5c7f Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 10 Sep 2018 17:24:43 +0200 Subject: [PATCH 06/28] Profile-Data: Submissions shown --- messages/uniworx/de.msg | 1 + src/Handler/Corrections.hs | 8 +-- src/Handler/Profile.hs | 110 ++++++++++++++++++++++++++++------- src/Utils.hs | 10 +++- templates/profileData.hamlet | 10 +++- 5 files changed, 110 insertions(+), 29 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e3576c5e4..ab2333d6d 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -127,6 +127,7 @@ SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt. +SubmissionEditUser: Ihre letzte Bearbeitung CorrectionsTitle: Zugewiesene Korrekturen CourseCorrectionsTitle: Korrekturen für diesen Kurs diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 5e587c624..cf548a8df 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -86,17 +86,17 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> - let csh = course ^. _2 - tid = course ^. _3 + let tid = course ^. _3 ssh = course ^. _4 + csh = course ^. _2 in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|] colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> - let csh = course ^. _2 - tid = course ^. _3 + let tid = course ^. _3 ssh = course ^. _4 + csh = course ^. _2 shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 20fd64af5..4312f138c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -187,7 +187,7 @@ instance HasCourse a => HasCourse (DBRow a) where -- -- type CourseTableData = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) --- NOTE: use procData instead as a flexible inlines Type signature +-- NOTE: use withType instead as a flexible inlines Type signature getProfileDataR :: Handler Html getProfileDataR = do @@ -196,9 +196,9 @@ getProfileDataR = do -- Tabelle mit eigenen Kursen ownCourseTable <- do -- TODO: only display when non-empty - let procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) + let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) - procData = id + withType = id dbTableWidget' def $ DBTable { dbtIdent = "courseOwnership" :: Text , dbtStyle = def @@ -212,27 +212,27 @@ getProfileDataR = do ) , dbtColonnade = mconcat [ colsCourseLink' $ _dbrOutput --- [ colsCourseLink $ (over each _unValue) . o_dbrOutput +-- [ colsCourseLink $ (over each _unValue) . _dbrOutput -- different types in Tupel prevents "over each" ] , dbtProj = return , dbtSorting = Map.fromList - [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) - , ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) - , ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) ] , dbtFilter = Map.fromList - [ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) - , ( "term", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) - , ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) ] } -- Tabelle mit allen Teilnehmer: Kurs (link), Datum courseTable <- do let - procData :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) - procData = id + withType = id -- should be inlined -- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a) @@ -262,15 +262,15 @@ getProfileDataR = do ] , dbtProj = return , dbtSorting = Map.fromList - [ ( "course", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) - , ( "term" , SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) - , ( "school", SortColumn $ procData $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) , ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration) ] , dbtFilter = Map.fromList - [ ( "course", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) - , ( "term" , FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) - , ( "school", FilterColumn $ procData $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) + , ( "term" , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) -- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) ] , dbtStyle = def @@ -278,10 +278,76 @@ getProfileDataR = do -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionTable <- do - let procData :: ((_)->a) - -> ((_)->a) - procData = id - return () + let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) + withType = id + let validator = def -- DUPLICATED CODE: Handler.Corrections + & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + & restrictSorting (\name _ -> name /= "corrector") + dbTableWidget' validator $ DBTable + { dbtIdent = "submissions" :: Text + , dbtStyle = def + , dbtSQLQuery = \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) -> do + E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid + let subEdit = E.sub_select . E.from $ \subEdit -> do + E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId + E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid + return . E.max_ $ subEdit E.^. SubmissionEditTime + let crse = ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseId + , course E.^. CourseShorthand + ) + let sht = ( sheet E.^. SheetName + ) + return (crse, sht, submission, subEdit) + , dbtColonnade = mconcat + [ colsCourseLink' $ _dbrOutput . _1 + , sortable (Just "sheet") (i18nCell MsgSheet) $ do + shn <- view $ _dbrOutput . _2 . _unValue + crse <- view $ _dbrOutput . _1 + let tid = crse ^. _1 . _unValue + ssh = crse ^. _2 . _unValue + csh = crse ^. _4 . _unValue + link= CSheetR tid ssh csh shn SShowR + return $ anchorCell link $ display2widget shn + + , sortable (toNothing "submission") (i18nCell MsgSubmission) $ do + shn <- view $ _dbrOutput . _2 . _unValue + sid <- view $ _dbrOutput . _3 . _entityKey + crse <- view $ _dbrOutput . _1 + let tid = crse ^. _1 . _unValue + ssh = crse ^. _2 . _unValue + csh = crse ^. _4 . _unValue + mkCid = encrypt (sid :: SubmissionId) -- TODO: executed twice + mkRoute = do + cid <- mkCid + return $ CSubmissionR tid ssh csh shn cid SubShowR + return $ anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) + , sortable (const Nothing $ Just "edit") (i18nCell MsgSubmissionEditUser) $ do + regTime <- view $ _dbrOutput . _4 . _unValue + return $ maybe mempty timeCell regTime + ] + , dbtProj = return + , dbtSorting = Map.fromList + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool ) +-- , ( "time" , error "Time Sorting not yet supported") -- TODO + , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName ) + ] + , dbtFilter = Map.fromList + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + ] + } + + -- Tabelle mit allen Abgabegruppen + --TODO -- Tabelle mit allen Tutorials tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO -- Tabelle mit allen Korrektor-Aufgaben diff --git a/src/Utils.hs b/src/Utils.hs index 7bef82270..d1beb0f31 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -113,6 +113,9 @@ str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => String -> WidgetT site m () str2widget s = [whamlet|#{s}|] +display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) => + a -> WidgetT site m () +display2widget = text2widget . display withFragment :: ( Monad m ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) @@ -228,6 +231,9 @@ toMaybe :: Bool -> a -> Maybe a toMaybe True = Just toMaybe False = const Nothing +toNothing :: a -> Maybe b +toNothing = const Nothing + maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd Nothing y = y @@ -296,11 +302,11 @@ catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err) ------------ shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a -shortCircuitM sc mx my op = do +shortCircuitM sc mx my bop = do x <- mx case sc x of True -> return x - False -> op <$> pure x <*> my + False -> bop <$> pure x <*> my guardM :: MonadPlus m => m Bool -> m () diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 6b74fb278..a74a762a3 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -24,7 +24,15 @@ ^{tutorialTable}
    -

    Korrekturen +

    Abgaben +
    + ^{submissionTable} + Hinweis: + Bei Gruppenabgaben wird kein Datum angezeigt, + falls Sie die Gruppenabgabe nie selbst hochgeladen haben. + +
    +

    _{MsgCorrector}
    ^{correctorTable} From 3523549d0e5d07fad863a19488ec298d76800623 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 11 Sep 2018 09:00:25 +0200 Subject: [PATCH 07/28] Sort submissions by time, show lecturers in course --- messages/uniworx/de.msg | 1 + src/Handler/Course.hs | 8 ++++++-- src/Handler/Profile.hs | 20 +++++++++++--------- templates/course.hamlet | 11 +++++++++++ 4 files changed, 29 insertions(+), 11 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ab2333d6d..98b6e5592 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -250,6 +250,7 @@ NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter AdminFor: Administrator LecturerFor: Dozent +LecturersFor: Dozenten UserListTitle: Komprehensive Benutzerliste DateTimeFormat: Datums- und Uhrzeitformat diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 112f87361..e63a8f012 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -263,7 +263,7 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (courseEnt,(schoolMB,participants,registered)) <- runDB $ do + (courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh dependent <- (,,) <$> get (courseSchool course) -- join -- just fetch full school name here @@ -273,7 +273,11 @@ getCShowR tid ssh csh = do (Just aid) -> do regL <- getBy (UniqueParticipant aid cid) return $ isJust regL) - return $ (courseEnt,dependent) + lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do + E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId + E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid + return $ user E.^. UserDisplayName + return $ (courseEnt,dependent,E.unValue <$> lecturers) let course = entityVal courseEnt (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 4312f138c..b54490242 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} @@ -212,11 +213,11 @@ getProfileDataR = do ) , dbtColonnade = mconcat [ colsCourseLink' $ _dbrOutput --- [ colsCourseLink $ (over each _unValue) . _dbrOutput -- different types in Tupel prevents "over each" +-- [ colsCourseLink $ (over each _unValue) . _dbrOutput -- different types in Tuple prevents "over each" ] , dbtProj = return , dbtSorting = Map.fromList - [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) -- consider PatternSynonyms. Drawback: not enclosed with table, since they must be at Top-Level. Maybe make Lenses for InnerJoins then? , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) ] @@ -284,6 +285,11 @@ getProfileDataR = do let validator = def -- DUPLICATED CODE: Handler.Corrections & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") + lastSubEdit submission = -- latest Edit-Time of this user for submission + E.sub_select . E.from $ \subEdit -> do + E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId + E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid + return . E.max_ $ subEdit E.^. SubmissionEditTime dbTableWidget' validator $ DBTable { dbtIdent = "submissions" :: Text , dbtStyle = def @@ -292,10 +298,6 @@ getProfileDataR = do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid - let subEdit = E.sub_select . E.from $ \subEdit -> do - E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId - E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid - return . E.max_ $ subEdit E.^. SubmissionEditTime let crse = ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseId @@ -303,7 +305,7 @@ getProfileDataR = do ) let sht = ( sheet E.^. SheetName ) - return (crse, sht, submission, subEdit) + return (crse, sht, submission, lastSubEdit submission) , dbtColonnade = mconcat [ colsCourseLink' $ _dbrOutput . _1 , sortable (Just "sheet") (i18nCell MsgSheet) $ do @@ -327,7 +329,7 @@ getProfileDataR = do cid <- mkCid return $ CSubmissionR tid ssh csh shn cid SubShowR return $ anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) - , sortable (const Nothing $ Just "edit") (i18nCell MsgSubmissionEditUser) $ do + , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do regTime <- view $ _dbrOutput . _4 . _unValue return $ maybe mempty timeCell regTime ] @@ -336,8 +338,8 @@ getProfileDataR = do [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand) , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm ) , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool ) --- , ( "time" , error "Time Sorting not yet supported") -- TODO , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName ) + , ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) -> lastSubEdit submission ) ] , dbtFilter = Map.fromList [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) diff --git a/templates/course.hamlet b/templates/course.hamlet index f63629fee..76bd9ba2a 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -5,11 +5,22 @@
    #{schoolName school} + $maybe descr <- courseDescription course
    _{MsgCourseDescription}
    #{descr} + + $with numlecs <- length lecturers + $if numlecs > 1 +
    _{MsgLecturersFor} + $else +
    _{MsgLecturerFor} +
    +
    + #{T.intercalate ", " lecturers} + $maybe link <- courseLinkExternal course
    Website
    From ee8990f2442e592730019e38196d22b0dc6b975f Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 11 Sep 2018 10:51:51 +0200 Subject: [PATCH 08/28] Discuss: Convenience.submissionCell --- messages/uniworx/de.msg | 5 ++++- src/Handler/Course.hs | 5 ++--- src/Handler/Profile.hs | 8 +++----- src/Handler/Submission.hs | 20 ++++++++++++++------ src/Handler/Utils/Table/Convenience.hs | 17 +++++++++++++++++ src/Handler/Utils/Table/Pagination.hs | 19 ++++++++++++------- templates/submission.hamlet | 8 ++++++++ 7 files changed, 60 insertions(+), 22 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 98b6e5592..757d54da7 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -128,6 +128,7 @@ SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt. SubmissionEditUser: Ihre letzte Bearbeitung +SubmissionNoEditUser: Nicht von Ihnen bearbeitet CorrectionsTitle: Zugewiesene Korrekturen CourseCorrectionsTitle: Korrekturen für diesen Kurs @@ -239,7 +240,9 @@ RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist FileTitle: Dateiname FileModified: Letzte Änderung -FileCorrected: Korrigiert + +Corrected: Korrigiert +FileCorrected: Korrigiert (Dateien) FileCorrectedDeleted: Korrigiert (gelöscht) RatingUpdated: Korrektur gespeichert RatingDeleted: Korrektur zurückgesetzt diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e63a8f012..287266462 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -270,9 +270,8 @@ getCShowR tid ssh csh = do <*> count [CourseParticipantCourse ==. cid] -- join <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! Nothing -> return False - (Just aid) -> do - regL <- getBy (UniqueParticipant aid cid) - return $ isJust regL) + (Just aid) -> do regL <- getBy (UniqueParticipant aid cid) + return $ isJust regL) lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index b54490242..106c35c54 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -317,7 +317,7 @@ getProfileDataR = do link= CSheetR tid ssh csh shn SShowR return $ anchorCell link $ display2widget shn - , sortable (toNothing "submission") (i18nCell MsgSubmission) $ do + , sortable (toNothing "submission") (i18nCell MsgSubmission) $ do -- TODO: use submissionCell?! shn <- view $ _dbrOutput . _2 . _unValue sid <- view $ _dbrOutput . _3 . _entityKey crse <- view $ _dbrOutput . _1 @@ -325,10 +325,8 @@ getProfileDataR = do ssh = crse ^. _2 . _unValue csh = crse ^. _4 . _unValue mkCid = encrypt (sid :: SubmissionId) -- TODO: executed twice - mkRoute = do - cid <- mkCid - return $ CSubmissionR tid ssh csh shn cid SubShowR - return $ anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) + mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR + return $ anchorCellM' mkCid mkRoute display2widget , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do regTime <- view $ _dbrOutput . _4 . _unValue return $ maybe mempty timeCell regTime diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index e55a8a25f..c45c061da 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -23,6 +23,7 @@ import Import hiding (joinPath) -- import Yesod.Form.Bootstrap3 import Handler.Utils +import Handler.Utils.Table.Convenience import Network.Mime @@ -107,7 +108,7 @@ submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Submis submissionHelper tid ssh csh shn (SubmissionMode mcid) = do uid <- requireAuthId msmid <- traverse decrypt mcid - (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do + (Entity shid Sheet{..}, buddies, lastEdits, lastEditsUser) <- runDB $ do sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn case msmid of Nothing -> do @@ -135,7 +136,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserEmail - return (sheet,buddies,[]) + return (sheet,buddies,[],[]) (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists @@ -159,7 +160,14 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do E.limit numberOfSubmissionEditDates return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime) lastEdits <- forM lastEditValues $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time - return (sheet,buddies,lastEdits) + lastEditUserValues <- E.select . E.from $ \(submissionEdit) -> do + E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid + E.&&. submissionEdit E.^. SubmissionEditUser E.==. E.val uid + E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] + E.limit numberOfSubmissionEditDates + return $ submissionEdit E.^. SubmissionEditTime + lastEditsUser <- forM lastEditUserValues $ \(E.Value time) -> formatTime SelFormatDateTime time + return (sheet,buddies,lastEdits,lastEditsUser) let unpackZips = True -- undefined -- TODO ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies mCID <- runDB $ do @@ -257,17 +265,17 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') ([whamlet|#{fileTitle'}|]) | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' - , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of + , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of Nothing -> cell mempty Just (_, Entity _ File{..}) | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) ([whamlet|_{MsgFileCorrected}|]) - | otherwise -> textCell MsgFileCorrected + | otherwise -> textCell MsgCorrected , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let origTime = fileModified . entityVal . snd <$> mOrig corrTime = fileModified . entityVal . snd <$> mCorr Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime - in textCell $ display fileTime + in timeCell fileTime ] coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md) diff --git a/src/Handler/Utils/Table/Convenience.hs b/src/Handler/Utils/Table/Convenience.hs index f3c6627d5..5ff8b12a4 100644 --- a/src/Handler/Utils/Table/Convenience.hs +++ b/src/Handler/Utils/Table/Convenience.hs @@ -68,6 +68,23 @@ courseCell (Course {..}) = anchorCell link name `mappend` desc Nothing -> mempty (Just descr) -> cell [whamlet| ^{modalStatic descr} |] +sheetCell :: IsDBTable m a => (CourseLink', E.Value SheetName) -> DBCell m a +sheetCell (crse, E.Value shn) = + let tid = crse ^. _1 . _unValue + ssh = crse ^. _2 . _unValue + csh = crse ^. _4 . _unValue + link= CSheetR tid ssh csh shn SShowR + in anchorCell link $ display2widget shn + +submissionCell :: IsDBTable m a => (CourseLink', E.Value SheetName, SubmissionId) -> DBCell m a +submissionCell (crse, E.Value shn, sid) = + let tid = crse ^. _1 . _unValue + ssh = crse ^. _2 . _unValue + csh = crse ^. _4 . _unValue + mkCid = encrypt (sid :: SubmissionId) -- TODO: executed twice -- FIXED! + mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR + mkText cid = display2widget cid + in anchorCellM' mkCid mkRoute mkText -- Generic Columns diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c550356d1..a4bd71657 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -34,7 +34,7 @@ module Handler.Utils.Table.Pagination , dbTableWidget, dbTableWidget' , widgetColonnade, formColonnade, dbColonnade , cell, textCell, stringCell, i18nCell - , anchorCell, anchorCell', anchorCellM + , anchorCell, anchorCell', anchorCellM, anchorCellM' , tickmarkCell , listCell , formCell, DBFormResult, getDBFormResult @@ -505,13 +505,18 @@ anchorCell' :: IsDBTable m a 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 +anchorCellM routeM widget = anchorCellM' routeM id (const widget) + +anchorCellM' :: IsDBTable m a => (WidgetT UniWorX IO x) -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a +anchorCellM' xM x2route x2widget = cell $ do + x <- xM + let route = x2route x + widget = x2widget x + authResult <- liftHandlerT $ isAuthorized route False + case authResult of + Authorized -> $(widgetFile "table/cell/link") -- show allowed link + _otherwise -> widget -- don't show prohibited link - if - | Authorized <- authResult -> $(widgetFile "table/cell/link") - | otherwise -> widget listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a listCell xs mkCell = review dbCell . ([], ) $ do diff --git a/templates/submission.hamlet b/templates/submission.hamlet index d22ae8ec0..5c62e7f8a 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -8,6 +8,14 @@ $maybe cID <- mcid