diff --git a/messages/de.msg b/messages/de.msg index b61a36e31..db368200b 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -188,6 +188,7 @@ Passed: Bestanden NotPassed: Nicht bestanden RatingTime: Korrigiert RatingComment: Kommentar +SubmissionUsers: Studenten RatingPoints: Punkte RatingFiles: Korrigierte Dateien diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 412d380c5..3d2a61116 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -75,54 +75,60 @@ sheetIs :: Key Sheet -> CorrectionsWhere sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid -type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value CourseName, E.Value CourseShorthand, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User)) +type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User) colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) - $ \DBRow{ dbrOutput=(_, _, course, _) } -> + $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> -- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester - textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel + textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $ - let tid = E.unValue $ course ^. _3 - csh = E.unValue $ course ^. _2 + $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> cell $ + let tid = course ^. _3 + csh = course ^. _2 in [whamlet|#{display csh}|] colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) - $ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $ - let tid = E.unValue $ course ^. _3 - csh = E.unValue $ course ^. _2 + $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> cell $ + let tid = course ^. _3 + csh = course ^. _2 shn = sheetName $ entityVal sheet in [whamlet|#{display shn}|] -- textCell $ sheetName $ entityVal sheet colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case - DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty - DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr + DBRow{ dbrOutput = (_, _, _, Nothing, _) } -> cell mempty + DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) - $ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do - let tid = E.unValue $ course ^. _3 - csh = E.unValue $ course ^. _2 + $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> cell $ do + let tid = course ^. _3 + csh = course ^. _2 shn = sheetName $ entityVal sheet cid <- encrypt (entityKey submission :: SubmissionId) [whamlet|#{display cid}|] colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) -colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId +colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId + +colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let + cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName) + in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) makeCorrectionsTable whereClause colChoices psValidator = do - let tableData :: CorrectionTableExpr -> E.SqlQuery _ - tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do + let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ + dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -133,10 +139,20 @@ makeCorrectionsTable whereClause colChoices psValidator = do , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) ) return (submission, sheet, crse, corrector) + dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData + dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do + submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId + E.orderBy [E.asc $ user E.^. UserId] + return user + let + submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors + return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) dbTable psValidator $ DBTable - { dbtSQLQuery = tableData + { dbtSQLQuery , dbtColonnade = colChoices - , dbtProj = return + , dbtProj , dbtSorting = [ ( "term" , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm ) @@ -319,6 +335,7 @@ postCCorrectionsR tid csh = do , dbRow , colSheet , colCorrector + , colSubmittors , colSubmissionLink ] -- Continue here psValidator = def @@ -336,6 +353,7 @@ postSSubsR tid csh shn = do [ colSelect , dbRow , colCorrector + , colSubmittors , colSubmissionLink ] psValidator = def diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 26acd65dc..a7bda4a73 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -24,6 +24,7 @@ module Handler.Utils.Table.Pagination , DBRow(..) , DBStyle(..), DBEmptyStyle(..) , DBTable(..), IsDBTable(..), DBCell(..) + , cellAttrs, cellContents , PaginationSettings(..), PaginationInput(..), piIsUnset , PSValidator(..) , defaultFilter, defaultSorting @@ -31,10 +32,13 @@ module Handler.Utils.Table.Pagination , ToSortable(..), Sortable(..), sortable , dbTable , widgetColonnade, formColonnade, dbColonnade - , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM + , cell, textCell, stringCell, i18nCell + , anchorCell, anchorCell', anchorCellM + , listCell , formCell, DBFormResult, getDBFormResult , dbRow, dbSelect , (&) + , module Control.Monad.Trans.Maybe ) where import Handler.Utils.Table.Pagination.Types @@ -59,6 +63,8 @@ import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_) import Control.Monad.Reader (ReaderT(..), mapReaderT) import Control.Monad.Trans.Maybe +import Data.Foldable (Foldable(foldMap)) + import Data.Map (Map, (!)) import qualified Data.Map as Map @@ -123,6 +129,15 @@ data DBRow r = DBRow , dbrIndex, dbrCount :: Int64 } deriving (Show, Read, Eq, Ord) +instance Functor DBRow where + fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. } + +instance Foldable DBRow where + foldMap f DBRow{..} = f dbrOutput + +instance Traversable DBRow where + traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount + data DBEmptyStyle = DBESNoHeading | DBESHeading deriving (Enum, Bounded, Ord, Eq, Show, Read) @@ -238,16 +253,19 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) -- type DBResult' m x :: * data DBCell m x :: * - cellAttrs :: Lens' (DBCell m x) [(Text, Text)] - cellContents :: DBCell m x -> WriterT x m Widget - - cell :: Widget -> DBCell m x + dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget) -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x) +cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)] +cellAttrs = dbCell . _1 + +cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget) +cellContents = dbCell . _2 + instance IsDBTable (WidgetT UniWorX IO) () where type DBResult (WidgetT UniWorX IO) () = Widget -- type DBResult' (WidgetT UniWorX IO) () = () @@ -256,10 +274,10 @@ instance IsDBTable (WidgetT UniWorX IO) () where { wgtCellAttrs :: [(Text, Text)] , wgtCellContents :: Widget } - cellAttrs = lens wgtCellAttrs $ \w as -> w { wgtCellAttrs = as } - cellContents = return . wgtCellContents - cell = WidgetCell [] + dbCell = iso + (\WidgetCell{..} -> (wgtCellAttrs, return wgtCellContents)) + (\(attrs, mkWidget) -> WidgetCell attrs . join . fmap fst $ runWriterT mkWidget) -- dbWidget Proxy Proxy = iso (, ()) $ view _1 dbWidget _ = return @@ -278,10 +296,9 @@ instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where , dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget } - cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as } - cellContents = lift . dbCellContents - - cell = DBCell [] . return + dbCell = iso + (\DBCell{..} -> (dbCellAttrs, lift dbCellContents)) + (\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget) dbWidget _ = return dbHandler _ f x = return $ f x @@ -301,10 +318,13 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc { formCellAttrs :: [(Text, Text)] , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) } - cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as } - cellContents = WriterT . fmap swap . formCellContents - cell widget = FormCell [] $ return (mempty, widget) + -- dbCell :: Iso' + -- (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) (FormResult a)) + -- ([(Text, Text)], WriterT (FormResult a) (RWST ... ... ... (HandlerT UniWorX IO)) Widget) + dbCell = iso + (\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents)) + (\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget) -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) @@ -393,7 +413,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do - widget <- cellContents sortableContent + widget <- sortableContent ^. cellContents let directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] isSortable = isJust sortableKey @@ -407,7 +427,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do - widget <- cellContents cell + widget <- cell ^. cellContents let attrs = cell ^. cellAttrs return $(widgetFile "table/cell/body") @@ -444,6 +464,9 @@ dbColonnade :: Headedness h -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) dbColonnade = id +cell :: IsDBTable m a => Widget -> DBCell m a +cell wgt = dbCell # ([], return wgt) + textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a stringCell = textCell i18nCell = textCell @@ -467,6 +490,12 @@ anchorCellM routeM widget = cell $ do | 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 + cells <- forM xs $ + \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget + return $(widgetFile "table/cell/list") + newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a)) instance Ord i => Monoid (DBFormResult r i a) where diff --git a/src/Utils.hs b/src/Utils.hs index 648b5d358..20c395570 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -17,6 +17,9 @@ import Data.List (foldl) import Data.Foldable as Fold import qualified Data.Char as Char +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + import Utils.DB as Utils import Utils.Common as Utils import Utils.DateTime as Utils @@ -123,6 +126,9 @@ instance DisplayAble a => DisplayAble (Maybe a) where instance DisplayAble a => DisplayAble (E.Value a) where display = display . E.unValue +instance DisplayAble a => DisplayAble (CI a) where + display = display . CI.original + -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated) instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where display = pack . show @@ -151,6 +157,22 @@ trd3 (_,_,z) = z -- notNull = not . null +mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)] +mergeAttrs = mergeAttrs' `on` sort + where + special = [ ("class", \v1 v2 -> v1 <> " " <> v2) + ] + + mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2) + | Just merge <- lookup n1 special + , n2 == n1 + = mergeAttrs' ((n1, merge v1 v2) : xs1) xs2 + | Just _ <- lookup n1 special + , n1 < n2 + = x2 : mergeAttrs' (x1:xs1) xs2 + | otherwise = x1 : mergeAttrs' xs1 (x2:xs2) + mergeAttrs' [] xs2 = xs2 + mergeAttrs' xs1 [] = xs1 ---------- -- Maps -- diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 25a12154c..f55073584 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -428,10 +428,10 @@ input[type="button"].btn-info:hover, display: inline-block; } -.list--comma-separated > li { - +.list--comma-separated li { &::after { content: ', '; + white-space: pre; } &:last-of-type::after { diff --git a/templates/table/cell/body.hamlet b/templates/table/cell/body.hamlet index f2892c2a2..46bf50fd1 100644 --- a/templates/table/cell/body.hamlet +++ b/templates/table/cell/body.hamlet @@ -1,3 +1,4 @@ - +$newline never +
^{widget} diff --git a/templates/table/cell/link.hamlet b/templates/table/cell/link.hamlet index 21ce1108a..0ced27282 100644 --- a/templates/table/cell/link.hamlet +++ b/templates/table/cell/link.hamlet @@ -1,2 +1,3 @@ +$newline never ^{widget} diff --git a/templates/table/cell/list.hamlet b/templates/table/cell/list.hamlet new file mode 100644 index 000000000..86a1f0520 --- /dev/null +++ b/templates/table/cell/list.hamlet @@ -0,0 +1,5 @@ +$newline never +