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

config/keter.yml

@@ -1 +1 @@
-keter_uni2work.yml
+keter_testworx.yml

messages/de.msg

@@ -219,3 +219,9 @@ AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC ko
 
 LastEdits: Letzte Änderungen
 EditedBy name@Text time@Text: Durch #{name} um #{time}
+LastEdit: Letzte Änderung
+
+SubmissionSince: Abgabe seit
+SubmissionTo: Abgabe bis
+
+SheetType: Bewertung

src/Foundation.hs

@@ -309,11 +309,25 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
         Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
         Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
         cTime <- liftIO getCurrentTime
+        let
+          visible = NTop sheetVisibleFrom <= NTop (Just cTime)
+          active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+
+        guard visible
+
+        case subRoute of
+          SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
+          SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
+          SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
+          SubmissionNewR         -> guard   active
+          SubmissionR _ _        -> guard   active
+          _                      -> return ()
+
+        return Authorized
+        
         let started = sheetActiveFrom <= cTime  ||  NTop sheetVisibleFrom <= (NTop $ Just cTime)
         case subRoute of
           SFileR SheetExercise _ -> guard started
-          SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
-          SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
           SFileR SheetMarking  _ -> mzero -- only for correctors and lecturers
           SubmissionNewR         -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
           SubmissionR _ _        -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo

src/Handler/Corrections.hs

@@ -117,8 +117,8 @@ colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encry
 
 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, DBOutput CorrectionTableData r', ToSortable h, Functor h )
+makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h r' (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+                     => _ -> 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
@@ -135,6 +135,7 @@ makeCorrectionsTable whereClause colChoices psValidator = do
   dbTable psValidator $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colChoices
+    , dbtProj      = return 
     , dbtSorting   = [ ( "term"
                        , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
                        )

src/Handler/Course.hs

@@ -68,6 +68,7 @@ getTermCourseListR tid = do
             Nothing -> MsgCourseMembersCount num
             Just max -> MsgCourseMembersCountLimited num max
         ]
+    , dbtProj = return . dbrOutput
     , dbtSorting = Map.fromList
         [ ( "shorthand"
           , SortColumn $ \course -> course E.^. CourseShorthand

src/Handler/Home.hs

@@ -32,16 +32,13 @@ import Text.Shakespeare.Text
 -- import qualified Data.UUID.Cryptographic as UUID
 
 
--- Some constants:
+-- CONSTANTS: TODO: make configurable elsewhere
--- nrSheetDeadlines :: Int64
--- nrSheetDeadlines   = 10
 offSheetDeadlines :: NominalDiffTime
 offSheetDeadlines   = 15
---nrExamDeadlines    = 10
+offCourseDeadlines :: NominalDiffTime
+offCourseDeadlines  = 15
+--offExamDeadlines :: NominalDiffTime
 --offExamDeadlines    = 15
--- nrCourseDeadlines :: Int64
--- nrCourseDeadlines  = 12
---offCourseDeadlines  = 15
 
 
 
@@ -56,15 +53,14 @@ getHomeR = do
 homeAnonymous :: Handler Html
 homeAnonymous = do
   cTime <- liftIO getCurrentTime
-  let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime
+  let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime
   let tableData :: E.SqlExpr (Entity Course)
                   -> E.SqlQuery (E.SqlExpr (Entity Course))
       tableData course = do
-            E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom)
+            E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) -- TODO: do this with isAuthorized in dbtProj
                 E.&&.  (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
                 E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
                         E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
---             E.limit nrCourseDeadlines
             return course
 
       colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ())
@@ -82,6 +78,7 @@ homeAnonymous = do
   courseTable <- dbTable def $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
+    , dbtProj      = return
     , dbtSorting   = Map.fromList
                       [ ( "term"
                         , SortColumn $ \(course) -> course E.^. CourseTerm
@@ -126,10 +123,10 @@ homeUser uid = do
         E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
         E.on $ course     E.^. CourseId        E.==. sheet        E.^. SheetCourse
         E.on $ course     E.^. CourseId        E.==. participant  E.^. CourseParticipantCourse
-        E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
+        E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid -- TODO: do this with isAuthorized in dbtProj
             E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
             E.&&. sheet E.^. SheetActiveTo E.<=. E.val fTime
-        -- E.limit nrSheetDeadlines
+        -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive
         return
           ( course  E.^. CourseTerm
           , course  E.^. CourseShorthand
@@ -165,6 +162,7 @@ homeUser uid = do
   sheetTable <- dbTable validator $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
+    , dbtProj      = return
     , dbtSorting   = Map.fromList
                       [ ( "term"
                         , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm

src/Handler/Sheet.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -11,7 +12,6 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE MultiWayIf, LambdaCase #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -145,50 +145,59 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
         , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo)   , render MsgSheetErrSolutionEarly)
       ] ]
 
--- List Sheets
--- getSheetListCID :: CourseId -> Handler Html
--- getSheetListCID cid = getSheetList =<<
---   (Entity cid) <$> (runDB $ get404 cid)
-
 getSheetListR :: TermId -> Text -> Handler Html
 getSheetListR tid csh = do
-  -- mbAid <- maybeAuthId
+  Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh
-  (Entity cid course, sheets) <- runDB $ do
+  let
-    entCourse <- getBy404 $ CourseTermShort tid csh
+    sheetData :: E.SqlExpr (E.Entity Sheet) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)))
-    rawSheets <- selectList [SheetCourse ==. entityKey entCourse] [Desc SheetActiveFrom]
+    sheetData sheet = do
-    sheets <- forM rawSheets $ \(Entity sid sheet) -> do
+      let sheetEdit = E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
-        let sheetsub = [SubmissionSheet ==. sid]
+            return $ sheetEdit E.?. SheetEditTime
-        submissions <- count sheetsub
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
-        rated       <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
+      return (sheet, sheetEdit)
-        return (sid, sheet, (submissions, rated))
+    sheetCol = widgetColonnade . mconcat $
-    return (entCourse, sheets)
+      [ sortable (Just "name") (i18nCell MsgSheet)
-  let csh = courseShorthand course
+        $ \(Entity _ Sheet{..}, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName)
-  let tid = courseTerm course
+      , sortable (Just "last-edit") (i18nCell MsgLastEdit)
-  let colBase = mconcat
+        $ \(_, E.Value mEditTime) -> case mEditTime of
-        [ headed "Blatt"       $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR
+          Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
-        , headed "Abgabe ab"   $ \(_,Sheet{..},_) -> formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
+          Nothing -> mempty
-        , headed "Abgabe bis"  $ \(_,Sheet{..},_) -> formatTime SelFormatDateTime sheetActiveTo >>= toWidget
+      , sortable (Just "submission-since") (i18nCell MsgSubmissionSince)
-        , headed "Bewertung"   $ toWgt . display . sheetType . snd3
+        $ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
-        ]
+      , sortable (Just "submission-until") (i18nCell MsgSubmissionTo)
-  let colAdmin = mconcat -- only show edit button for allowed course assistants
+        $ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo   >>= toWidget
-        [ headed "Korrigiert"  $ toWgt . snd . trd3
+      , sortable Nothing (i18nCell MsgSheetType)
-        , headed "Eingereicht" $ toWgt . fst . trd3
+        $ \(Entity _ Sheet{..}, _) -> textCell $ display sheetType
-        , headed ""            $ \s -> simpleLink "Edit"   $ CSheetR tid csh (sheetName $ snd3 s) SEditR
+      ]          
-        , headed ""            $ \s -> simpleLink "Delete" $ CSheetR tid csh (sheetName $ snd3 s) SDelR
+    psValidator = def
-        ]
+      & defaultSorting [("submission-since", SortAsc)]
-  showAdmin <- case sheets of
+  table <- dbTable psValidator $ DBTable
-    ((_,firstSheet,_):_) -> do
+    { dbtSQLQuery  = sheetData
-      setUltDestCurrent
+    , dbtColonnade = sheetCol
-      (Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False
+    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _) }
-    _otherwise   -> return False
+                   -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False)
-  let colSheets = if showAdmin
+    , dbtSorting   = Map.fromList
-        then colBase `mappend` colAdmin
+      [ ( "name"
-        else colBase
+        , SortColumn $ \sheet -> sheet E.^. SheetName
+        )
+      , ( "last-edit"
+        , SortColumn $ \sheet -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
+            return $ sheetEdit E.?. SheetEditTime
+        )
+      , ( "submission-since"
+        , SortColumn $ \sheet -> sheet E.^. SheetActiveFrom
+        )
+      , ( "submission-until"
+        , SortColumn $ \sheet -> sheet E.^. SheetActiveTo
+        )
+      ]
+    , dbtFilter    = Map.fromList
+      []
+    , dbtStyle     = def
+    , dbtIdent     = "sheets" :: Text
+    }
   defaultLayout $ do
-    setTitle $ toHtml $ csh <> " Übungsblätter"
+    $(widgetFile "sheetList")
-    if null sheets
-      then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
-      else Yesod.encodeWidgetTable tableDefault colSheets sheets
 
 
 -- Show single sheet
@@ -233,6 +242,7 @@ getSShowR tid csh shn = do
   fileTable <- dbTable def $ DBTable
     { dbtSQLQuery = fileData
     , dbtColonnade = colonnadeFiles
+    , dbtProj = return . dbrOutput
     , dbtStyle = def
     , dbtFilter = Map.empty
     , dbtIdent = "files" :: Text

src/Handler/Utils/Table/Pagination.hs

@@ -15,12 +15,13 @@
            , TupleSections
            , RankNTypes
            , MultiWayIf
+           , FunctionalDependencies
   #-}
 
 module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
   , FilterColumn(..), IsFilterColumn
-  , DBRow(..), DBOutput
+  , DBRow(..)
   , DBStyle(..), DBEmptyStyle(..)
   , DBTable(..), IsDBTable(..), DBCell(..)
   , PaginationSettings(..), PaginationInput(..), piIsUnset
@@ -56,6 +57,7 @@ import qualified Data.CaseInsensitive as CI
 import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
 import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
 import Control.Monad.Reader (ReaderT(..), mapReaderT)
+import Control.Monad.Trans.Maybe
 
 import Data.Map (Map, (!))
 import qualified Data.Map as Map
@@ -121,16 +123,6 @@ data DBRow r = DBRow
   , dbrIndex, dbrCount :: Int64
   } deriving (Show, Read, Eq, Ord)
 
-class DBOutput r r' where
-  dbProj :: r -> r'
-
-instance DBOutput (DBRow r) (DBRow r) where
-  dbProj = id
-instance DBOutput (DBRow r) r where
-  dbProj = dbrOutput
-instance DBOutput (DBRow r) (Int64, r) where
-  dbProj = (,) <$> dbrIndex <*> dbrOutput
-
 data DBEmptyStyle = DBESNoHeading | DBESHeading
   deriving (Enum, Bounded, Ord, Eq, Show, Read)
 
@@ -152,11 +144,12 @@ instance Default DBStyle where
 
 data DBTable m x = forall a r r' h i t.
   ( ToSortable h, Functor h
-  , E.SqlSelect a r, DBOutput (DBRow r) r'
+  , E.SqlSelect a r
   , PathPiece i
   , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
+  , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
   , dbtColonnade :: Colonnade h r' (DBCell m x)
   , dbtSorting :: Map (CI Text) (SortColumn t)
   , dbtFilter :: Map (CI Text) (FilterColumn t)
@@ -328,7 +321,7 @@ instance IsDBTable m a => IsString (DBCell m a) where
       
 
 dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
-dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), dbtStyle = DBStyle{..}, .. }) = do
+dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. }) = do
   let
     sortingOptions = mkOptionList
       [ Option t' (t, d) t'
@@ -380,11 +373,14 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
   runDB $ do
     rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
 
+    let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
+  
+    rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
+
     let
       rowCount
         | (E.Value n, _):_ <- rows' = n
         | otherwise = 0
-      rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
 
       table' :: WriterT x m Widget
       table' = do

templates/sheetList.hamlet

@@ -0,0 +1 @@
+^{table}