Display submission users
This commit is contained in:
Gregor Kleen
parent
2ddc0a03cb
commit
6a53fb1401
@ -188,6 +188,7 @@ Passed: Bestanden
|
||||
NotPassed: Nicht bestanden
|
||||
RatingTime: Korrigiert
|
||||
RatingComment: Kommentar
|
||||
SubmissionUsers: Studenten
|
||||
|
||||
RatingPoints: Punkte
|
||||
RatingFiles: Korrigierte Dateien
|
||||
|
||||
@ -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|<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 $
|
||||
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|<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 = (_, _, _, 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|<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 _
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
22
src/Utils.hs
22
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 --
|
||||
|
||||
@ -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 {
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
<td .table__td *{attrs}>
|
||||
$newline never
|
||||
<td *{mergeAttrs attrs [("class", "table__td")]}>
|
||||
<div .table__td-content>
|
||||
^{widget}
|
||||
|
||||
@ -1,2 +1,3 @@
|
||||
$newline never
|
||||
<a href=@{route}>
|
||||
^{widget}
|
||||
|
||||
5
templates/table/cell/list.hamlet
Normal file
5
templates/table/cell/list.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
<ul>
|
||||
$forall (attrs, widget) <- cells
|
||||
<li *{attrs}>
|
||||
^{widget}
|
||||
Loading…
Reference in New Issue
Block a user