Display submission users

messages/de.msg

@@ -188,6 +188,7 @@ Passed: Bestanden
 NotPassed: Nicht bestanden
 RatingTime: Korrigiert
 RatingComment: Kommentar
+SubmissionUsers: Studenten
 
 RatingPoints: Punkte
 RatingFiles: Korrigierte Dateien

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 $
+        $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> cell $
-          let tid = E.unValue $ course ^. _3
+          let tid = course ^. _3
-              csh = E.unValue $ course ^. _2
+              csh = course ^. _2
           in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
 
 colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
-        $ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $
+        $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> cell $
-          let tid = E.unValue $ course ^. _3
+          let tid = course ^. _3
-              csh = E.unValue $ course ^. _2
+              csh = course ^. _2
               shn = sheetName $ entityVal sheet
           in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{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 = (_, _, _, Nothing, _) } -> cell mempty
-  DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr
+  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
+        $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> cell $ do
-          let tid = E.unValue $ course ^. _3
+          let tid = course ^. _3
-              csh = E.unValue $ course ^. _2
+              csh = course ^. _2
               shn = sheetName $ entityVal sheet
           cid <- encrypt (entityKey submission :: SubmissionId)
           [whamlet|<a href=@{CSubmissionR tid csh shn cid SubShowR}>#{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 _
+  let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
-      tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
+      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

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)]
+  dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
-  cellContents :: DBCell m x -> WriterT x m Widget
-
-  cell :: Widget -> DBCell m x
     
   -- 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 }
+  dbCell = iso
-  cellContents = lift . dbCellContents
+    (\DBCell{..} -> (dbCellAttrs, lift dbCellContents))
-
+    (\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget)
-  cell = DBCell [] . return
 
   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

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

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 {

templates/table/cell/body.hamlet

@@ -1,3 +1,4 @@
-<td .table__td *{attrs}>
+$newline never
+<td *{mergeAttrs attrs [("class", "table__td")]}>
   <div .table__td-content>
     ^{widget}

templates/table/cell/link.hamlet

@@ -1,2 +1,3 @@
+$newline never
 <a href=@{route}>
   ^{widget}

templates/table/cell/list.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<ul>
+  $forall (attrs, widget) <- cells
+    <li *{attrs}>
+      ^{widget}