fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
SJost 2018-07-18 12:27:07 +02:00
commit e9c8da1b85
9 changed files with 100 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
config/keter.yml
View File

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

6
messages/de.msg
View File

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

18
src/Foundation.hs
View File

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

5
src/Handler/Corrections.hs
View File

@ -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 )
=> _ -> Colonnade h r' (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
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
@ -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
)

1
src/Handler/Course.hs
View File

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

22
src/Handler/Home.hs
View File

@ -32,16 +32,13 @@ import Text.Shakespeare.Text
-- import qualified Data.UUID.Cryptographic as UUID
-- Some constants:
-- nrSheetDeadlines :: Int64
-- nrSheetDeadlines = 10
-- CONSTANTS: TODO: make configurable elsewhere
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

94
src/Handler/Sheet.hs
View File

@ -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 course, sheets) <- runDB $ do
entCourse <- getBy404 $ CourseTermShort tid csh
rawSheets <- selectList [SheetCourse ==. entityKey entCourse] [Desc SheetActiveFrom]
sheets <- forM rawSheets $ \(Entity sid sheet) -> do
let sheetsub = [SubmissionSheet ==. sid]
submissions <- count sheetsub
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
return (sid, sheet, (submissions, rated))
return (entCourse, sheets)
let csh = courseShorthand course
let tid = courseTerm course
let colBase = mconcat
[ headed "Blatt" $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR
, headed "Abgabe ab" $ \(_,Sheet{..},_) -> formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
, headed "Abgabe bis" $ \(_,Sheet{..},_) -> formatTime SelFormatDateTime sheetActiveTo >>= toWidget
, headed "Bewertung" $ toWgt . display . sheetType . snd3
]
let colAdmin = mconcat -- only show edit button for allowed course assistants
[ headed "Korrigiert" $ toWgt . snd . trd3
, headed "Eingereicht" $ toWgt . fst . trd3
, headed "" $ \s -> simpleLink "Edit" $ CSheetR tid csh (sheetName $ snd3 s) SEditR
, headed "" $ \s -> simpleLink "Delete" $ CSheetR tid csh (sheetName $ snd3 s) SDelR
]
showAdmin <- case sheets of
((_,firstSheet,_):_) -> do
setUltDestCurrent
(Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False
_otherwise -> return False
let colSheets = if showAdmin
then colBase `mappend` colAdmin
else colBase
Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh
let
sheetData :: E.SqlExpr (E.Entity Sheet) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)))
sheetData sheet = do
let sheetEdit = E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
return $ sheetEdit E.?. SheetEditTime
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet, sheetEdit)
sheetCol = widgetColonnade . mconcat $
[ sortable (Just "name") (i18nCell MsgSheet)
$ \(Entity _ Sheet{..}, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName)
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
$ \(_, E.Value mEditTime) -> case mEditTime of
Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
Nothing -> mempty
, sortable (Just "submission-since") (i18nCell MsgSubmissionSince)
$ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
, sortable (Just "submission-until") (i18nCell MsgSubmissionTo)
$ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget
, sortable Nothing (i18nCell MsgSheetType)
$ \(Entity _ Sheet{..}, _) -> textCell $ display sheetType
]
psValidator = def
& defaultSorting [("submission-since", SortAsc)]
table <- dbTable psValidator $ DBTable
{ dbtSQLQuery = sheetData
, dbtColonnade = sheetCol
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False)
, dbtSorting = Map.fromList
[ ( "name"
, 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"
if null sheets
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
else Yesod.encodeWidgetTable tableDefault colSheets sheets
$(widgetFile "sheetList")
-- 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

24
src/Handler/Utils/Table/Pagination.hs
View File

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

1
templates/sheetList.hamlet Normal file
View File

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