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

Fixes #179

Browse Source
This commit is contained in:
SJost 2018-09-14 17:54:13 +02:00
parent 918141da4c
commit cc4c8a897e
5 changed files with 122 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de.msg
View File

@ -267,7 +267,7 @@ AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC ko
IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren
LastEdits: Letzte Änderungen LastEdits: Letzte Änderungen
EditedBy name@Text time@Text: Durch #{name} um #{time} EditedBy name@Text time@Text: #{time} durch #{name}
LastEdit: Letzte Änderung LastEdit: Letzte Änderung
LastEditByUser: Ihre letzte Bearbeitung LastEditByUser: Ihre letzte Bearbeitung
NoEditByUser: Nicht von Ihnen bearbeitet NoEditByUser: Nicht von Ihnen bearbeitet

82
src/Handler/Profile.hs
View File

@ -160,16 +160,16 @@ getProfileDataR = do
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
enrolledCoursesTable <- mkEnrolledCoursesTable uid enrolledCoursesTable <- mkEnrolledCoursesTable uid
-- Tabelle mit allen Klausuren und Noten
examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO
-- Tabelle mit allen Abgaben und Abgabe-Gruppen -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionTable <- mkSubmissionTable uid submissionTable <- mkSubmissionTable uid
-- Tabelle mit allen Abgabegruppen -- Tabelle mit allen Abgabegruppen
submissionGroupTable <- mkSubmissionGroupTable uid submissionGroupTable <- mkSubmissionGroupTable uid
-- Tabelle mit allen Korrektor-Aufgaben
correctionsTable <- mkCorrectionsTable uid
-- Tabelle mit allen Tutorials -- Tabelle mit allen Tutorials
tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO
-- Tabelle mit allen Korrektor-Aufgaben
correctorTable <- return [whamlet| TOOD: Korrekturen anzeigen |] -- TODO
-- Tabelle mit allen Klausuren und Noten
examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO
defaultLayout $ do defaultLayout $ do
$(widgetFile "profileData") $(widgetFile "profileData")
$(widgetFile "dsgvDisclaimer") $(widgetFile "dsgvDisclaimer")
@ -346,6 +346,10 @@ mkSubmissionTable =
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid dbtSorting = dbtSorting' uid
in dbTableWidget' validator $ DBTable {..} in dbTableWidget' validator $ DBTable {..}
-- in do dbtSQLQuery <- dbtSQLQuery'
-- dbtSorting <- dbtSorting'
-- return $ dbTableWidget' validator $ DBTable {..}
mkSubmissionGroupTable :: UserId -> Handler Widget mkSubmissionGroupTable :: UserId -> Handler Widget
@ -353,7 +357,6 @@ mkSubmissionGroupTable :: UserId -> Handler Widget
mkSubmissionGroupTable = mkSubmissionGroupTable =
let dbtIdent = "subGroups" :: Text let dbtIdent = "subGroups" :: Text
dbtStyle = def dbtStyle = def
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
withType = id withType = id
@ -411,8 +414,71 @@ mkSubmissionGroupTable =
] ]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..} in dbTableWidget' validator $ DBTable {..}
-- in do dbtSQLQuery <- dbtSQLQuery'
-- dbtSorting <- dbtSorting'
-- return $ dbTableWidget' validator $ DBTable {..}
mkCorrectionsTable :: UserId -> Handler Widget
-- Table listing all corrections made by the given user
mkCorrectionsTable =
let dbtIdent = "corrections" :: Text
dbtStyle = def
-- TODO Continue here
withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
withType = id
dbtSQLQuery' uid = \(course `E.InnerJoin` sgroup `E.InnerJoin` sguser) -> do
E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId
E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
let crse = ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
return (crse, sgroup, lastSGEdit sgroup)
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
dbtProj = \x -> return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
& _dbrOutput . _3 %~ E.unValue
dbtColonnade = mconcat
[ dbRow
, sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just)
<*> view ( _2 )
, sortable (Just "course") (i18nCell MsgCourse) $
courseLinkCell <$> view (_dbrOutput . _1)
, sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
maybe mempty textCell <$> view _submissionGroupName
, sortable (Just "edit") (i18nCell MsgLastEdit) $
maybe mempty timeCell <$> view (_dbrOutput . _3)
]
validator = def -- DUPLICATED CODE: Handler.Corrections
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
& restrictSorting (\name _ -> name /= "corrector")
& defaultSorting [("edit",SortDesc)]
dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
, ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName )
, ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _ ) -> lastSGEdit sgroup)
]
dbtFilter = Map.fromList
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..}

64
src/Handler/Submission.hs
View File

@ -31,6 +31,7 @@ import Control.Monad.Trans.Maybe
import Control.Monad.State.Class import Control.Monad.State.Class
import Control.Monad.Trans.State.Strict (StateT) import Control.Monad.Trans.State.Strict (StateT)
import Data.Monoid (Any(..))
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Text as Text import qualified Data.Text as Text
@ -106,9 +107,12 @@ getSubmissionOwnR tid ssh csh shn = do
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid ssh csh shn (SubmissionMode mcid) = do submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
uid <- requireAuthId uid <- requireAuthId
msmid <- traverse decrypt mcid msmid <- traverse decrypt mcid
(Entity shid Sheet{..}, buddies, lastEdits, lastEditsUser) <- runDB $ do actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
case msmid of case msmid of
Nothing -> do Nothing -> do
@ -136,7 +140,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail return $ user E.^. UserEmail
return (sheet,buddies,[],[]) return (sheet, map E.unValue buddies, [])
(E.Value smid:_) -> do (E.Value smid:_) -> do
cID <- encrypt smid cID <- encrypt smid
addMessageI "info" $ MsgSubmissionAlreadyExists addMessageI "info" $ MsgSubmissionAlreadyExists
@ -146,30 +150,31 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
shid' <- submissionSheet <$> get404 smid shid' <- submissionSheet <$> get404 smid
-- fetch buddies from current submission -- fetch buddies from current submission
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do (Any isOwner, buddies) <- do
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail return $ (user E.^. UserId, user E.^. UserEmail)
-- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime] let breakUserFromBuddies (E.Value userID, E.Value email)
lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do | uid == userID = (Any True , [])
E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) | otherwise = (Any False, [email])
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid return $ foldMap breakUserFromBuddies submittors
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
-- E.limit numberOfSubmissionEditDates -- DEPRECATED we shall show all edits lastEdits <- do
return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime) raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
lastEdits <- forM lastEditValues $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
lastEditUserValues <- E.select . E.from $ \(submissionEdit) -> do E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
E.&&. submissionEdit E.^. SubmissionEditUser E.==. E.val uid -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] let userName = if maySubmit || isOwner
E.limit 1 then E.just $ user E.^. UserDisplayName
return $ submissionEdit E.^. SubmissionEditTime else E.nothing
lastEditsUser <- forM lastEditUserValues $ \(E.Value time) -> formatTime SelFormatDateTime time return $ (userName, submissionEdit E.^. SubmissionEditTime)
return (sheet,buddies,lastEdits,lastEditsUser) forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (sheet,buddies,lastEdits)
let unpackZips = True -- undefined -- TODO let unpackZips = True -- undefined -- TODO
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
mCID <- runDB $ do mCID <- runDB $ do
res' <- case res of res' <- case res of
(FormMissing ) -> return $ FormMissing (FormMissing ) -> return $ FormMissing
@ -250,9 +255,6 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
Nothing -> return () Nothing -> return ()
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True
-- Maybe construct a table to display uploaded archive files -- Maybe construct a table to display uploaded archive files
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ()) let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
colonnadeFiles cid = mconcat colonnadeFiles cid = mconcat
@ -311,6 +313,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSubmissionEditHead tid ssh csh shn setTitleI $ MsgSubmissionEditHead tid ssh csh shn
let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))
urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
$(widgetFile "submission") $(widgetFile "submission")

12
templates/profileData.hamlet
View File

@ -19,6 +19,11 @@
<div .container> <div .container>
^{enrolledCoursesTable} ^{enrolledCoursesTable}
<div .container>
<h2> Noten
<div .container>
^{examTable}
<div .container> <div .container>
<h2> Übungsgruppen <h2> Übungsgruppen
<div .container> <div .container>
@ -40,12 +45,7 @@
<div .container> <div .container>
<h2> _{MsgCorrector} <h2> _{MsgCorrector}
<div .container> <div .container>
^{correctorTable} ^{correctionsTable}
<div .container>
<h2> Klausuren
<div .container>
^{examTable}
<h2> <h2>
<em> TODO: Knopf zum Löschen aller Daten erstellen <em> TODO: Knopf zum Löschen aller Daten erstellen

18
templates/submission.hamlet
View File

@ -1,8 +1,8 @@
$maybe cID <- mcid $maybe cID <- mcid
<section> <section>
<h2> <h2>
<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv <a href=@{urlArchive cID}>Archiv
(<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>) (<a href=@{urlOriginal cID}>Original</a>)
$maybe fileTable <- mFileTable $maybe fileTable <- mFileTable
<h3>_{MsgSubmissionFiles} <h3>_{MsgSubmissionFiles}
@ -11,15 +11,11 @@ $maybe cID <- mcid
$if not (null lastEdits) $if not (null lastEdits)
<h3>_{MsgLastEdits} <h3>_{MsgLastEdits}
<ul> <ul>
$forall (name,time) <- lastEdits $forall (mbName,time) <- lastEdits
<li>_{MsgEditedBy name time} $maybe name <- mbName
<li>_{MsgEditedBy name time}
_{MsgLastEditByUser}: # $nothing
$if null lastEditsUser <li>#{display time}
_{MsgNoEditByUser}
$else
$forall time <- lastEditsUser
#{display time}
$if maySubmit $if maySubmit