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-09 14:53:15 +01:00
commit c3fc8a218a
13 changed files with 125 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
.vscode/tasks.json vendored
View File

@ -28,8 +28,20 @@
"focus": false,
"panel": "dedicated",
"showReuseMessage": false
},
"problemMatcher": []
}
},
{
"label": "test",
"type": "shell",
"command": "./test.sh",
"group": "test",
"presentation": {
"echo": true,
"reveal": "always",
"focus": true,
"panel": "dedicated",
"showReuseMessage": false
}
}
]
}

7
ChangeLog.md
View File

@ -1,3 +1,10 @@
* Version 09.11.2018
Bugfix: Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript
Verschiedene Verbesserungen für Korrektoren
* Version 19.10.2018
Benutzer können sich in der Testphase komplett selbst löschen

10
messages/uniworx/de.msg
View File

@ -274,6 +274,16 @@ RatingUpdated: Korrektur gespeichert
RatingDeleted: Korrektur zurückgesetzt
RatingFilesUpdated: Korrigierte Dateien überschrieben
RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc}
RatingMissingSeparator: Could not split rating header from comments
RatingMultiple: Encountered multiple point values in rating
RatingInvalid parseErr@String: Failed to parse rating point value #{parseErr}
RatingFileIsDirectory: We do not expect this to, it's included for totality
RatingNegative: Rating points must be non-negative
RatingExceedsMax: Rating point must not exceed maximum points
RatingNotExpected: Rating not expected
RatingBinaryExpected: Rating must be 0 or 1
NoTableContent: Kein Tabelleninhalt
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter

14
src/Foundation.hs
View File

@ -220,14 +220,16 @@ embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>)
embedRenderMessage ''UniWorX ''StudyFieldType id
embedRenderMessage ''UniWorX ''SheetFileType id
embedRenderMessage ''UniWorX ''CorrectorState id
embedRenderMessage ''UniWorX ''RatingException id
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>)
newtype SheetTypeComplete = SheetTypeComplete SheetType
instance RenderMessage UniWorX (SheetTypeComplete) where
renderMessage foundation ls (SheetTypeComplete sheetType) = case sheetType of
NotGraded -> mr NotGraded
other -> mr (grading other) <> ", " <> mr other
newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
instance RenderMessage UniWorX (SheetType) where
renderMessage foundation ls sheetType = case sheetType of
NotGraded -> mr $ SheetTypeHeader NotGraded
other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls

39
src/Handler/Corrections.hs
View File

@ -500,26 +500,31 @@ postCorrectionR tid ssh csh shn cid = do
case corrResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (rated, ratingPoints', ratingComment') -> do
runDBJobs $ do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
update sub [ SubmissionRatingBy =. (uid <$ guard rated)
-- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
-- , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes?
, SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints'
, SubmissionRatingComment =. ratingComment'
]
FormSuccess (rated, ratingPoints', ratingComment')
| errs <- validateRating sheetType Rating'
{ ratingPoints=ratingPoints'
, ratingComment=ratingComment'
, ratingTime=Nothing
}
-> mapM_ (addMessageI Error) errs
| otherwise -> do
runDBJobs $ do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
update sub [ SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints'
, SubmissionRatingComment =. ratingComment'
]
addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
when (rated && isNothing submissionRatingTime) $ do
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
when (rated && isNothing submissionRatingTime) $ do
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
case uploadResult of
FormMissing -> return ()

2
src/Handler/Sheet.hs
View File

@ -162,7 +162,7 @@ getSheetListR tid ssh csh = do
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
$ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
, sortable Nothing (i18nCell MsgSheetType)
$ \(Entity _ Sheet{..}, _, _) -> i18nCell $ SheetTypeComplete sheetType
$ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType
, sortable Nothing (i18nCell MsgSubmission)
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
Nothing -> mempty

42
src/Handler/Utils/Rating.hs
View File

@ -2,6 +2,7 @@
module Handler.Utils.Rating
( Rating(..), Rating'(..)
, validateRating
, getRating
, formatRating
, ratingFile
@ -15,12 +16,10 @@ module Handler.Utils.Rating
import Import
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
import Control.Monad.Trans.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text.Encoding.Error (UnicodeException(..))
@ -35,9 +34,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
import Text.Read (readEither)
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import System.FilePath
import qualified System.FilePath.Cryptographic as FilePath (decrypt)
@ -61,29 +57,19 @@ instance Pretty SheetGrading where
pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
data Rating = Rating
{ ratingCourseName :: CourseName
, ratingSheetName :: SheetName
, ratingCorrectorName :: Maybe Text
, ratingSheetType :: SheetType
, ratingValues :: Rating'
} deriving (Read, Show, Eq, Generic, Typeable)
data Rating' = Rating'
{ ratingPoints :: Maybe Points
, ratingComment :: Maybe Text
, ratingTime :: Maybe UTCTime
} deriving (Read, Show, Eq, Generic, Typeable)
data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
| RatingMissingSeparator -- ^ Could not split rating header from comments
| RatingMultiple -- ^ Encountered multiple point values in rating
| RatingInvalid String -- ^ Failed to parse rating point value
| RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
deriving (Show, Eq, Generic, Typeable)
instance Exception RatingException
validateRating :: SheetType -> Rating' -> [RatingException]
validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
| rp < 0
= [RatingNegative]
| NotGraded <- ratingSheetType
= [RatingNotExpected]
| (Just maxPoints ) <- ratingSheetType ^? _grading . _maxPoints
, rp > maxPoints
= [RatingExceedsMax]
| (Just PassBinary) <- ratingSheetType ^? _grading
, not (rp == 0 || rp == 1)
= [RatingBinaryExpected]
validateRating _ _ = []
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
getRating submissionId = runMaybeT $ do

9
src/Handler/Utils/Submission.hs
View File

@ -395,7 +395,7 @@ sinkSubmission userId mExists isUpdate = do
touchSubmission
lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
Right (submissionId', Rating'{..}) -> do
Right (submissionId', r'@Rating'{..}) -> do
$logDebugS "sinkSubmission" $ tshow submissionId'
unless (submissionId' == submissionId) $ do
@ -417,9 +417,12 @@ sinkSubmission userId mExists isUpdate = do
-- 'ratingTime' is ignored for consistency with 'File's:
--
-- 'fileModified' is simply stored and never inspected while
-- 'submissionChanged' is always set to @now@.
-- 'submissionChanged' is always set to @now@.
when anyChanges $ do
Sheet{..} <- lift $ getJust submissionSheet
mapM_ throwM $ validateRating sheetType r'
touchSubmission
lift $ update submissionId
[ SubmissionRatingPoints =. ratingPoints

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

@ -83,9 +83,6 @@ sheetCell crse shn =
link= CSheetR tid ssh csh shn SShowR
in anchorCell link $ display2widget shn
sheetTypeCell :: IsDBTable m a => SheetType -> DBCell m a
sheetTypeCell sheetType = i18nCell $ SheetTypeComplete sheetType
submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
submissionCell crse shn sid =
let tid = crse ^. _1

2
src/Import/NoFoundation.hs
View File

@ -7,6 +7,7 @@ import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJS
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import
import Model.Rating as Import
import Settings as Import
import Settings.StaticFiles as Import
import Yesod.Auth as Import
@ -37,6 +38,7 @@ import GHC.Generics as Import (Generic)
import Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..))
import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Control.Monad.Morph as Import (MFunctor(..))

37
src/Model/Rating.hs Normal file
View File

@ -0,0 +1,37 @@
module Model.Rating where
import ClassyPrelude.Yesod
import Model
-- import Data.Text (Text)
import Data.Text.Encoding.Error (UnicodeException(..))
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
data Rating = Rating
{ ratingCourseName :: CourseName
, ratingSheetName :: SheetName
, ratingCorrectorName :: Maybe Text
, ratingSheetType :: SheetType
, ratingValues :: Rating'
} deriving (Read, Show, Eq, Generic, Typeable)
data Rating' = Rating'
{ ratingPoints :: Maybe Points
, ratingComment :: Maybe Text
, ratingTime :: Maybe UTCTime
} deriving (Read, Show, Eq, Generic, Typeable)
data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
| RatingMissingSeparator -- ^ Could not split rating header from comments
| RatingMultiple -- ^ Encountered multiple point values in rating
| RatingInvalid String -- ^ Failed to parse rating point value
| RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
| RatingNegative -- ^ Rating points must be non-negative
| RatingExceedsMax -- ^ Rating point must not exceed maximum points
| RatingNotExpected -- ^ Rating not expected
| RatingBinaryExpected -- ^ Rating must be 0 or 1
deriving (Show, Eq, Generic, Typeable)
instance Exception RatingException

3
src/index.md
View File

@ -97,6 +97,9 @@ CryptoID
Model.Migration
: Manuelle Datenbank-Migration
Model.Rating
: Types for Submission Ratings that the Database does not depend on, but needed in Foundation
Jobs
: `handleJobs` worker thread handling background jobs
`JobQueueException`

2
templates/sheetShow.hamlet
View File

@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
<dt .deflist__dt>_{MsgSheetSolutionFrom}
<dd .deflist__dd>#{solution}
<dt .deflist__dt>_{MsgSheetType}
<dd .deflist__dd>_{SheetTypeComplete (sheetType sheet)}
<dd .deflist__dd>_{sheetType sheet}
$if CorrectorSubmissions == sheetSubmissionMode sheet
<dt .deflist__dt>_{MsgSheetPseudonym}
<dd .deflist__dd #pseudonym>