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

First part of issue #187 implemented.

Browse Source
This commit is contained in:
SJost 2018-09-20 16:49:19 +02:00
parent 7caad588f8
commit a20ff1468e
12 changed files with 119 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
messages/uniworx/de.msg
View File

@ -185,7 +185,7 @@ Users: Benutzer
HomeHeading: Aktuelle Termine
LoginHeading: Authentifizierung
LoginTitle: Authentifizierung
ProfileHeading: Benutzerprofil und Einstellungen
ProfileHeading: Benutzereinstellungen
ProfileDataHeading: Gespeicherte Benutzerdaten
ImpressumHeading: Impressum
@ -290,6 +290,7 @@ CorrectorExcused: Entschuldigt
DayIsAHoliday tid@TermId date@Text: #{date} ist ein Feiertag
DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid}
DayIsOutOfTerm tid@TermId date@Text: #{date} liegt nicht im #{display tid}
UploadModeNone: Kein Upload
UploadModeUnpack: Upload, einzelne Datei
UploadModeNoUnpack: Upload, ZIP-Archive entpacken
@ -297,4 +298,4 @@ UploadModeNoUnpack: Upload, ZIP-Archive entpacken
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
FieldPrimary: Hauptfach
FieldSecondary: Nebenfach
FieldSecondary: Nebenfach

10
models
View File

@ -54,7 +54,7 @@ School json
shorthand (CI Text)
UniqueSchool name
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = School { unSchoolKey :: SchoolShorthand }
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
deriving Eq
DegreeCourse json
course CourseId
@ -133,10 +133,10 @@ File
deriving Show Eq
Submission
sheet SheetId
ratingPoints Points Maybe
ratingComment Text Maybe
ratingBy UserId Maybe
ratingTime UTCTime Maybe
ratingPoints Points Maybe -- "Just" does not mean done
ratingComment Text Maybe -- "Just" does not mean done
ratingBy UserId Maybe -- assigned corrector
ratingTime UTCTime Maybe -- "Just" here indicates done!
deriving Show
SubmissionEdit
user UserId

2
src/Foundation.hs
View File

@ -743,7 +743,7 @@ defaultLinks = -- Define the menu items of the header.
, menuItemAccessCallback' = return True
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Profile"
{ menuItemLabel = "Profil"
, menuItemIcon = Just "cogs"
, menuItemRoute = ProfileR
, menuItemAccessCallback' = isJust <$> maybeAuthPair

32
src/Handler/Course.hs
View File

@ -313,8 +313,33 @@ postCRegisterR tid ssh csh = do
getCourseNewR :: Handler Html
getCourseNewR = do
-- TODO: Defaults für Semester hier ermitteln und übergeben
courseEditHandler True Nothing
uid <- requireAuthId
params <- runInputGetResult $ (,,)
<$> ireq ciTextField "csh"
<*> iopt textField "tid"
<*> iopt ciTextField "sid"
template <- case params of
FormMissing -> return Nothing
FormFailure [] -> return Nothing
FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml) >> return Nothing
FormSuccess (csh,mbTid,mbSid) -> do
oldCourses <- runDB $ do
E.select $ E.from $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseSchool E.==. lecturer E.^. UserLecturerSchool
E.where_ $ course E.^. CourseShorthand E.==. E.val csh
E.&&. lecturer E.^. UserLecturerUser E.==. E.val uid -- only search courses for lecturer's school (admin does not help here)
whenIsJust (SchoolKey <$> mbSid) $
\sid -> E.where_ $ course E.^. CourseSchool E.==. E.val sid
whenIsJust (mbTid >>= tidFromText) $
\tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
let courseCreated c = E.sub_select . E.from $ \edit -> do
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
return $ E.min_ $ edit E.^. CourseEditTime -- oldest edit must be creation
E.orderBy [E.desc $ courseCreated course] -- most recent courses
E.limit 1
return course
return $ listToMaybe oldCourses
courseEditHandler True template
postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler False Nothing
@ -343,6 +368,7 @@ courseDeleteHandler = undefined
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
courseEditHandler isGet course = do
-- isGet <- isWriteRequest
-- $logDebug "€€€€€€ courseEditHandler started"
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm
@ -462,7 +488,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
userId <- liftHandlerT requireAuthId
(fmap concat . sequence)
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
]
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
<$> pure (cfCourseId =<< template)

40
src/Handler/Profile.hs
View File

@ -94,7 +94,7 @@ getProfileR = do
_ -> return ()
(admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$>
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
(E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
@ -107,12 +107,6 @@ getProfileR = do
return (school E.^. SchoolShorthand)
)
<*>
(E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand)
)
<*>
(E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
@ -120,12 +114,6 @@ getProfileR = do
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
)
<*>
(E.select $ E.from $ \(participant `E.InnerJoin` course) -> do
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, participant E.^. CourseParticipantRegistration)
)
<*>
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
@ -164,15 +152,17 @@ getProfileDataR = do
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
enrolledCoursesTable <- mkEnrolledCoursesTable uid
-- Tabelle mit allen Klausuren und Noten
examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO
examTable <- return [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionTable <- mkSubmissionTable uid
-- Tabelle mit allen Abgabegruppen
submissionGroupTable <- mkSubmissionGroupTable uid
-- Tabelle mit allen Korrektor-Aufgaben
correctionsTable <- mkCorrectionsTable uid
-- Tabelle mit allen eigenen Tutorials
ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Tabelle mit allen Tutorials
tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO
tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
defaultLayout $ do
$(widgetFile "profileData")
$(widgetFile "dsgvDisclaimer")
@ -421,7 +411,7 @@ mkSubmissionGroupTable =
mkCorrectionsTable :: UserId -> Handler Widget
-- Table listing all corrections made by the given user
-- Table listing sum of corrections made by the given user per sheet
mkCorrectionsTable =
let dbtIdent = "corrections" :: Text
dbtStyle = def
@ -430,6 +420,17 @@ mkCorrectionsTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
withType = id
corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
return $ E.countRows
corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
E.&&. (E.not_ $ E.isNothing $ submission E.^. SubmissionRatingTime)
return $ E.countRows
dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
@ -438,7 +439,7 @@ mkCorrectionsTable =
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
return (crse, sheet E.^. SheetName, corrector)
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
dbtProj = \x -> return $ x
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
@ -458,6 +459,10 @@ mkCorrectionsTable =
correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
, sortable (toNothing "cload") (i18nCell MsgCorProportion) $
correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal)
, sortable (toNothing "assigned") (i18nCell MsgCorProportion) $
int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue)
, sortable (toNothing "corrected") (i18nCell MsgCorProportion) $
int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
]
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)]
@ -476,4 +481,3 @@ mkCorrectionsTable =
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator $ DBTable {..}

5
src/Handler/Utils.hs
View File

@ -36,6 +36,11 @@ downloadFiles = do
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
return userDefaultDownloadFiles
tidFromText :: Text -> Maybe TermId
tidFromText = (fmap TermKey) . maybeRight . termFromText
simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
nameWidget :: Text -> Text -> Widget
nameWidget displayName surname

12
src/Handler/Utils/Form.hs
View File

@ -111,7 +111,7 @@ instance Button UniWorX AdminHijackUserButton where
-- instance PathPiece LinkButton where
-- LinkButton route = ???
linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget
linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
-- [whamlet|
-- <form method=post action=@{url}>
@ -120,10 +120,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
-- |]
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
simpleLink :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
{-
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
combinedButtonField btns inner csrf = do
@ -190,6 +186,9 @@ buttonForm csrf = do
ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a)
ciField = convertField CI.mk CI.original
ciTextField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m (CI Text)
ciTextField = ciField textField
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField
@ -222,6 +221,9 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
termActiveField :: Field Handler TermId
termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
termsField :: [TermId] -> Field Handler TermId
termsField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName
termActiveOld :: Field Handler TermIdentifier
termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName

6
src/Handler/Utils/Table/Cells.hs
View File

@ -35,6 +35,12 @@ userCell displayName surname = cell $ nameWidget displayName surname
maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
maybeTimeCell = maybe mempty timeCell
numCell :: (IsDBTable m a, Num b, DisplayAble b) => b -> DBCell m a
numCell = textCell . display
int64Cell :: (IsDBTable m a) => Int64-> DBCell m a
int64Cell = numCell
termCell :: IsDBTable m a => TermId -> DBCell m a
termCell tid = anchorCell link name
where

1
src/Model/Types.hs
View File

@ -286,6 +286,7 @@ shortened = iso shorten expand
termToText :: TermIdentifier -> Text
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
-- also see Hander.Utils.tidFromText
termFromText :: Text -> Either Text TermIdentifier
termFromText t
| (s:ys) <- Text.unpack t

21
src/Utils.hs
View File

@ -323,6 +323,27 @@ instance Ord a => Ord (NTop (Maybe a)) where
-----------
-- Maybe --
-----------
maybeLeft :: Either a b -> Maybe a
maybeLeft (Left a) = Just a
maybeLeft _ = Nothing
maybeRight :: Either a b -> Maybe b
maybeRight (Right b) = Just b
maybeRight _ = Nothing
whenIsLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
whenIsLeft (Left x) f = f x
whenIsLeft (Right _) _ = return ()
whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
whenIsRight (Right x) f = f x
whenIsRight (Left _) _ = return ()
---------------
-- Exception --
---------------

27
templates/profile.hamlet
View File

@ -16,21 +16,18 @@
<dt .deflist__dt> Administrator
<dd .deflist__dd>
<ul .list-ul>
$forall institute <- admin_rights
<li .list-ul__item>#{display institute}
$forall (E.Value institute) <- admin_rights
<li .list-ul__item>
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
$if not $ null lecturer_rights
<dt .deflist__dt> Lehrberechtigt
<dd .deflist__dd>
<ul .list-ul>
$forall institute <- lecturer_rights
<li .list-ul__item>#{display institute}
$if not $ null lecture_owner
<dt .deflist__dt> Eigene Kurse
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_owner
$forall (E.Value institute) <- lecturer_rights
<li .list-ul__item>
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
$if not $ null lecture_corrector
<dt .deflist__dt> Korrektor
<dd .deflist__dd>
@ -64,14 +61,4 @@
<td .table__td>_{E.unValue fieldtype}
<td .table__td>#{display semester}
$if not $ null participant
<dt .deflist__dt> Teilnehmer
<dd .deflist__dd>
<dl .deflist>
$forall (E.Value tid, E.Value ssh, E.Value csh, E.Value regSince) <- participant
<dt .deflist__dt>
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
<dd .deflist__dd>
seit ^{formatTimeW SelFormatDateTime regSince}
^{settingsForm}

14
templates/profileData.hamlet
View File

@ -6,8 +6,6 @@
und verlinkt werden
(alle Abgaben, Klausurnoten, etc.)
<em> TODO: Hier alle Daten in Tabellen anzeigen!
$if hasRows
<div .container>
<h2> Eigene Kurse
@ -24,6 +22,11 @@
<div .container>
^{examTable}
<div .container>
<h2> Eigene Übungsgruppen
<div .container>
^{ownTutorialTable}
<div .container>
<h2> Übungsgruppen
<div .container>
@ -47,6 +50,13 @@
<div .container>
^{correctionsTable}
<h4> Hinweis:
Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt;
auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier nicht aufgeführt werden.
Hier finden Sie eine
<a href=@{CorrectionsR}>Auflistung aller tatsächlich zugewiesenen Korrekturen
.
<h2>
<em> TODO: Knopf zum Löschen aller Daten erstellen