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:
Gregor Kleen 2018-11-14 14:23:09 +01:00
commit 27f2e077fe
13 changed files with 248 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.vscode/tasks.json vendored
View File

@ -28,7 +28,8 @@
"focus": false,
"panel": "dedicated",
"showReuseMessage": false
}
},
"problemMatcher": []
},
{
"label": "test",

122
README.md
View File

@ -3,79 +3,125 @@
The following Description applies to Ubuntu or similar.
## Clone repository
Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`.
Clone this repository and navigate into
```sh
$ git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git && cd UniWorX
```
## LDAP
install:
`sudo apt-get install slapd ldap-utils`
install:
```sh
$ sudo apt-get install slapd ldap-utils
```
## PostgreSQL
install:
`sudo apt-get install postgresql`
install:
```sh
$ sudo apt-get install postgresql
```
switch to user *postgres* (got created during installation):
`sudo -i -u postgres`
switch to user *postgres* (got created during installation):
```sh
$ sudo -i -u postgres
```
add db user *uniworx*:
`createuser --interactive`
add db user *uniworx*:
```sh
$ createuser --interactive
```
you'll get a prompt:
```
Enter name of role to add:` - [enter 'uniworx']
```sh
Enter name of role to add:` - uniworx
Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?]
Password: uniworx
...
```
create database *uniworx*:
`createdb uniworx`
create database *uniworx*:
```sh
$ createdb uniworx
```
to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*:
`sudo adduser uniworx`
after you added the database switch back to your own user with `Ctrl + D`.
log-in as new user *uniworx*:
`sudo -i -u uniworx`
to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*. when you get asked for a password enter *uniworx*.
```sh
$ sudo adduser uniworx
```
you can now use `psql uniworx` to execute SQL-commands and such.
log-in as new user *uniworx*:
```sh
$ sudo -i -u uniworx
```
you can now use
```sh
$ psql uniworx
```
to execute SQL-commands and such.
## stack
Install with:
`curl -sSL https://get.haskellstack.org/ | sh`
Install with:
```sh
$ curl -sSL https://get.haskellstack.org/ | sh
```
setup stack and install dependencies:
`stack setup`
setup stack and install dependencies:
```sh
$ stack setup
```
During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using
`sudo apt-get install libsasl2-dev libldap2-dev`
During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using
```sh
$ sudo apt-get install libsasl2-dev libldap2-dev
```
If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*
Go ahead an install `libpq-dev` with
`sudo apt-get install libpq-dev`
If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*
Go ahead an install `libpq-dev` with
```sh
$ sudo apt-get install libpq-dev
```
Build the app:
`stack build`
Other packages you might need to install during this process:
```sh
$ sudo apt-get install pkg-config
sudo apt-get install libsodium-dev
```
Build the app:
```sh
$ stack build
```
This might take a few minutes if not hours... be prepared.
install yesod:
`stack install yesod-bin --install-ghc`
install yesod:
```sh
$ stack install yesod-bin --install-ghc
```
## Add Dumy-Data and run the app
After building the app you can prepare the database and add some dummy data:
`./fill-db.hs`
```sh
$ ./db.sh -f
```
Run the app:
`./start.sh`
`Devel application launched: http://localhost:3000`
means you are good to go.
Run the app:
```sh
$ ./start.sh
...
Devel application launched: http://localhost:3000
```
If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login.
***
# Sources and more infos
PostgreSQl:
PostgreSQl:
https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04
stack: https://docs.haskellstack.org/en/stable/README/#how-to-install

11
messages/uniworx/de.msg
View File

@ -142,6 +142,8 @@ SubmissionGroupName: Gruppenname
CorrectionsTitle: Zugewiesene Korrekturen
CourseCorrectionsTitle: Korrekturen für diesen Kurs
CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
CorrectorAssignTitle: Korrektor zuweisen
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
@ -192,6 +194,7 @@ CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Ante
DeleteRow: Zeile entfernen
ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorUpdated: Korrektor erfolgreich aktualisiert
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
CorrectorsPlaceholder: Korrektoren...
CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
@ -231,6 +234,7 @@ CorrAutoSetCorrector: Korrekturen verteilen
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
NoCorrector: Kein Korrektor
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
@ -261,7 +265,7 @@ RatingDone: Bewertung fertiggestellt
RatingPercent: Erreicht
RatingFiles: Korrigierte Dateien
PointsNotPositive: Punktzahl darf nicht negativ sein
PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein
PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein
RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
ColumnRatingPointsDone: Punktzahl/Abgeschlossen
Pseudonyms: Pseudonyme
@ -371,7 +375,7 @@ SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
SheetGradingPassBinary: Bestanden/Nicht Bestanden
SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
SheetGradingPoints': Punkte
SheetGradingPassPoints': Bestehen nach Punkten
@ -429,7 +433,7 @@ HelpUser: Meinen Benutzeraccount
HelpAnonymous: Keine Antwort (Anonym)
HelpEMail: E-Mail
HelpRequest: Supportanfrage / Verbesserungsvorschlag
HelpProblemPage: Problematische Seite
HelpProblemPage: Problematische Seite
HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
HelpSent: Ihre Supportanfrage wurde weitergeleitet.
@ -489,6 +493,7 @@ ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
ErrMsgHeading: Fehlermeldung entschlüsseln
ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten
InvalidRoute: Konnte URL nicht interpretieren

14
models
View File

@ -15,7 +15,7 @@ User json
notificationSettings NotificationSettings
UniqueAuthentication ident
UniqueEmail email
deriving Show
deriving Show Eq
UserAdmin
user UserId
school SchoolId
@ -46,9 +46,9 @@ Term json
start Day -- TermKey :: TermIdentifier -> TermId
end Day
holidays [Day]
lectureStart Day
lectureEnd Day
active Bool
lectureStart Day
lectureEnd Day
active Bool
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
deriving Show -- type TermId = Key Term
School json
@ -57,7 +57,7 @@ School json
UniqueSchool name
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
deriving Eq
deriving Eq
DegreeCourse json
course CourseId
degree StudyDegreeId
@ -89,7 +89,7 @@ CourseFavourite
course CourseId
UniqueCourseFavourite user course
deriving Show
Lecturer
Lecturer
user UserId
course CourseId
UniqueLecturer user course
@ -135,7 +135,7 @@ SheetFile
file FileId
type SheetFileType
UniqueSheetFile file sheet type
File
File
title FilePath
content ByteString Maybe -- Nothing iff this is a directory
modified UTCTime

7
routes
View File

@ -23,7 +23,7 @@
-- !isWrite -- only if it is write access (i.e. POST only) why needed???
--
-- !deprecated -- like free, but logs and gives a warning; entirely disabled in production
-- !development -- like free, but only for development builds
-- !development -- like free, but only for development builds
/static StaticR Static appStatic !free
/auth AuthR Auth getAuth !free
@ -79,9 +79,10 @@
/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
/subs/own SubmissionOwnR GET !free -- just redirect
/sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
/assign SAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner
/correctors SCorrR GET POST
/pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions

38
src/Foundation.hs
View File

@ -210,7 +210,7 @@ instance RenderMessage UniWorX (SheetType) where
renderMessage foundation ls sheetType = case sheetType of
NotGraded -> mr $ SheetTypeHeader NotGraded
other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
where
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
@ -425,6 +425,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
let
visible = NTop sheetVisibleFrom <= NTop (Just cTime)
active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
marking = cTime > sheetActiveTo
guard visible
@ -434,6 +435,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SubmissionNewR -> guard active
SubmissionR _ _ -> guard active
SubmissionR _ SAssignR -> guard $ marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
_ -> return ()
return Authorized
@ -637,7 +639,7 @@ instance Yesod UniWorX where
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
user <- MaybeT $ get uid
let courseFavourite = CourseFavourite uid now cid
$logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|]
-- update Favourites
void . lift $ upsertBy
@ -686,7 +688,7 @@ instance Yesod UniWorX where
#{formatted}
|]
| otherwise -> plaintext
errPage = case err of
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
@ -974,7 +976,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
}
, do
mCurrentRoute <- getCurrentRoute
return MenuItem
{ menuItemType = NavbarRight
, menuItemLabel = MsgMenuHelp
@ -1262,6 +1264,14 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgCorrectorAssignTitle
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SAssignR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
]
pageActions (CSheetR tid ssh csh shn SCorrR) =
[ MenuItem
@ -1453,6 +1463,7 @@ routeNormalizers =
, ncSchool
, ncCourse
, ncSheet
, verifySubmission
]
where
normalizeRender route = route <$ do
@ -1490,8 +1501,17 @@ routeNormalizers =
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
hasChanged shn sheetName
return $ CSheetR tid ssh csh sheetName subRoute
verifySubmission = maybeOrig $ \route -> do
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
sId <- decrypt cID
Submission{submissionSheet} <- lift . lift $ get404 sId
Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
tell . Any $ route /= newRoute
return newRoute
-- How to run database actions.
instance YesodPersist UniWorX where
type YesodPersistBackend UniWorX = SqlBackend
@ -1561,7 +1581,7 @@ instance YesodAuth UniWorX where
userEmail' = lookup (Attr "mail") ldapData
userDisplayName' = lookup (Attr "displayName") ldapData
userSurname' = lookup (Attr "sn") ldapData
userAuthentication
| isPWHash = error "PWHash should only work for users that are already known"
| otherwise = AuthLDAP
@ -1667,13 +1687,13 @@ instance YesodMail UniWorX where
mailSmtp act = do
pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
withResource pool act
mailT ctx mail = defMailT ctx $ do
mailT ctx mail = defMailT ctx $ do
void setMailObjectId
setDateCurrent
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
ret <- mail
setMailSmtpData
return ret

124
src/Handler/Corrections.hs
View File

@ -83,11 +83,7 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
let tid = course ^. _3
ssh = course ^. _4
csh = course ^. _2
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
$ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
@ -135,7 +131,7 @@ colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
let csh = course ^. _2
@ -181,7 +177,7 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
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 dbtColonnade psValidator dbtProj' = do
@ -303,11 +299,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
unless (null unassigned) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
(unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
unless (null unassignedUnauth) $ do
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
unless (null unassignedAuth) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassignedAuth]
[ SubmissionRatingBy =. Just uid
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
]
@ -319,15 +320,15 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
return (E.countRows :: E.SqlExpr (E.Value Int64))
when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
redirect currentRoute
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections
subs <- mapM decrypt $ Set.toList subs'
runDB $ do
num <- updateWhereCount [SubmissionId <-. subs]
[ SubmissionRatingPoints =. Nothing
, SubmissionRatingComment =. Nothing
, SubmissionRatingBy =. Nothing
[ SubmissionRatingBy =. Nothing
, SubmissionRatingAssigned =. Nothing
, SubmissionRatingTime =. Nothing
-- , SubmissionRatingPoints =. Nothing -- Kept for easy reassignment by 2nd corrector
-- , SubmissionRatingComment =. Nothing -- Kept for easy reassignment by 2nd corrector
]
addMessageI Success $ MsgRemovedCorrections num
redirect currentRoute
@ -337,11 +338,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
unless (null unassigned) $ do
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
(unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
unless (null unassignedUnauth) $ do
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
unless (null unassignedAuth) $ do
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth)
unless (null assigned) $
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
unless (null stillUnassigned) $ do
@ -353,10 +359,21 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections")
where
authorizedToAssign :: SubmissionId -> DB Bool
authorizedToAssign sId = do
[(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <-
E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ submission E.^. SubmissionId E.==. E.val sId
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName)
cID <- encrypt sId
let route = CSubmissionR tid ssh csh shn cID SAssignR
(== Authorized) <$> evalAccessDB route True
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
downloadAction :: ActionCorrections'
downloadAction = ( CorrDownload
, pure CorrDownloadData
@ -366,13 +383,13 @@ assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector
, wFormToAForm $ do
correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
return user
E.distinct $ return user
mr <- getMessageRender
@ -483,8 +500,8 @@ postCorrectionR tid ssh csh shn cid = do
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
pointsForm = case sheetType of
NotGraded -> pure Nothing
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl")
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl")
(Just submissionRatingPoints)
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
@ -500,7 +517,7 @@ postCorrectionR tid ssh csh shn cid = do
case corrResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (rated, ratingPoints', ratingComment')
FormSuccess (rated, ratingPoints', ratingComment')
| errs <- validateRating sheetType Rating'
{ ratingPoints=ratingPoints'
, ratingComment=ratingComment'
@ -511,7 +528,7 @@ postCorrectionR tid ssh csh shn cid = do
runDBJobs $ do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
update sub [ SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints'
@ -522,7 +539,7 @@ postCorrectionR tid ssh csh shn cid = do
when (rated && isNothing submissionRatingTime) $ do
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
@ -531,7 +548,7 @@ postCorrectionR tid ssh csh shn cid = do
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess fileUploads -> do
uid <- requireAuthId
void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
addMessageI Success MsgRatingFilesUpdated
@ -545,7 +562,7 @@ postCorrectionR tid ssh csh shn cid = do
_ -> notFound
getCorrectionUserR tid ssh csh shn cid = do
sub <- decrypt cid
results <- runDB $ correctionData tid ssh csh shn sub
case results of
@ -557,7 +574,7 @@ getCorrectionUserR tid ssh csh shn cid = do
$(widgetFile "correction-user")
_ -> notFound
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
getCorrectionsUploadR = postCorrectionsUploadR
postCorrectionsUploadR = do
@ -577,7 +594,7 @@ postCorrectionsUploadR = do
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
mr <- (toHtml .) <$> getMessageRender
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
defaultLayout $
$(widgetFile "corrections-upload")
@ -692,17 +709,17 @@ postCorrectionsCreateR = do
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
}
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
redirect CorrectionsGradeR
defaultLayout $
$(widgetFile "corrections-create")
where
partitionEithers' :: [[Either a b]] -> ([[b]], [a])
partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws)
= let
@ -735,7 +752,7 @@ postCorrectionsGradeR = do
psValidator = def
& defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
cID <- encrypt subId
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
@ -762,3 +779,36 @@ postCorrectionsGradeR = do
defaultLayout $
$(widgetFile "corrections-grade")
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSAssignR = postSAssignR
postSAssignR tid ssh csh shn cID = do
let actionUrl = CSubmissionR tid ssh csh shn cID SAssignR
sId <- decrypt cID
(currentCorrector, sheetCorrectors) <- runDB $ do
Submission{submissionRatingBy, submissionSheet} <- get404 sId
sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
userCorrector <- traverse getJustEntity submissionRatingBy
return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)
$logDebugS "SAssignR" $ tshow currentCorrector
let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
((corrResult, corrForm), corrEncoding) <- runFormPost . renderAForm FormStandard $
aopt correctorField (fslI MsgCorrector) (Just currentCorrector)
<* submitButton
formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
now <- liftIO getCurrentTime
update sId [ SubmissionRatingBy =. mbUserId
, SubmissionRatingAssigned =. (now <$ mbUserId)
]
addMessageI Success MsgCorrectorUpdated
redirect actionUrl
defaultLayout $ do
setTitleI MsgCorrectorAssignTitle
$(widgetFile "submission-assign")

20
src/Utils.hs
View File

@ -306,9 +306,9 @@ ifMaybeM (Just x) _ act = act x
maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if
maybePositive a | a > 0 = Just a
| otherwise = Nothing
| otherwise = Nothing
positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
positiveSum (Sum x) = maybePositive x
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
@ -441,6 +441,22 @@ ofoldr1M _ _ = error "otoList of NonNull is empty"
ofoldl1M f (otoList -> x:xs) = foldlM f x xs
ofoldl1M _ _ = error "otoList of NonNull is empty"
partitionM :: forall mono m .
( MonoFoldable mono
, Monoid mono
, MonoPointed mono
, Monad m)
=> (Element mono -> m Bool) -> mono -> m (mono, mono)
partitionM crit = ofoldlM dist mempty
where
dist :: (mono,mono) -> Element mono -> m (mono,mono)
dist acc x = do
okay <- crit x
return $ if
| okay -> acc `mappend` (opoint x, mempty)
| otherwise -> acc `mappend` (mempty, opoint x)
--------------
-- Sessions --
--------------

2
templates/formPage.hamlet
View File

@ -1,2 +1,2 @@
<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
<form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
^{formWidget}

2
templates/formPageI18n.hamlet
View File

@ -1,5 +1,5 @@
$maybe text <- formText
<h3>
_{text}
<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
<form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
^{formWidget}

5
templates/messages/submissionsAssignUnauthorized.hamlet Normal file
View File

@ -0,0 +1,5 @@
_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
<ul>
$forall cID <- unassignedUnauth'
<li><pre>#{toPathPiece cID}

1
templates/standalone/inputs.lucius
View File

@ -91,7 +91,6 @@ input[type*="time"] {
input[type="number"] {
width: 100px;
text-align: right;
}
input[type*="date"],

2
templates/submission-assign.hamlet Normal file
View File

@ -0,0 +1,2 @@
<form method=post action=@{actionUrl} enctype=#{corrEncoding}>
^{corrForm}