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

Merge branch 'master' into recipient-form

Browse Source
This commit is contained in:
Felix Hamann 2019-04-21 16:03:54 +02:00
commit bfeb560d5d
19 changed files with 249 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
messages/uniworx/de.msg
View File

@ -456,9 +456,10 @@ UploadModeNone: Kein Upload
UploadModeUnpack: Upload, einzelne Datei
UploadModeNoUnpack: Upload, ZIP-Archive entpacken
SheetNoSubmissions: Keine Abgabe
SheetCorrectorSubmissions: Abgabe extern mit Pseudonym
SheetUserSubmissions: Direkte Abgabe
NoSubmissions: Keine Abgabe
CorrectorSubmissions: Abgabe extern mit Pseudonym
UserSubmissions: Direkte Abgabe
BothSubmissions: Abgabe direkt & extern mit Pseudonym
SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.

3
models/sheets
View File

@ -10,8 +10,7 @@ Sheet -- exercise sheet for a given course
activeTo UTCTime -- Submission is only permitted before
hintFrom UTCTime Maybe -- Additional files are made available
solutionFrom UTCTime Maybe -- Solution is made available
uploadMode UploadMode -- Take apart Zip-Archives or not?
submissionMode SheetSubmissionMode default='UserSubmissions' -- Submission upload by students or through tutors only?
submissionMode SubmissionMode -- Submission upload by students and/or through tutors?
autoDistribute Bool default=false -- Should correctors be assigned submissions automagically?
CourseSheet course name
deriving Generic

18
src/CryptoID.hs
View File

@ -58,21 +58,3 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
deriving (Show, Read, Eq)
pattern NewSubmission :: SubmissionMode
pattern NewSubmission = SubmissionMode Nothing
pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode
pattern ExistingSubmission cID = SubmissionMode (Just cID)
instance PathPiece SubmissionMode where
fromPathPiece "new" = Just $ SubmissionMode Nothing
fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s
toPathPiece (SubmissionMode Nothing) = "new"
toPathPiece (SubmissionMode (Just x)) = toPathPiece x

27
src/Database/Persist/TH/Directory.hs
View File

@ -2,26 +2,35 @@ module Database.Persist.TH.Directory
( persistDirectoryWith
) where
import ClassyPrelude hiding (mapM_, toList)
import ClassyPrelude
import Database.Persist.TH (parseReferences)
import Database.Persist.Quasi (PersistSettings)
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Syntax hiding (lift)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified System.IO as SIO
import System.FilePath
import qualified System.Directory.Tree as DirTree
import Data.Foldable (Foldable(..), mapM_)
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
import Control.Lens
persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
persistDirectoryWith settings dir = do
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do
h <- SIO.openFile fp SIO.ReadMode
SIO.hSetEncoding h SIO.utf8_bom
Text.hGetContents h
mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
fn <- MaybeT . return . fromNullable $ takeFileName fp
guard . not $ head fn == '.'
guard . not $ head fn == '#' && last fn == '#'
lift $ do
h <- SIO.openFile fp SIO.ReadMode
SIO.hSetEncoding h SIO.utf8_bom
Text.hGetContents h
mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files
parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files
parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files

32
src/Foundation.hs
View File

@ -253,9 +253,13 @@ embedRenderMessage ''UniWorX ''RatingException id
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
embedRenderMessage ''UniWorX ''LecturerType id
embedRenderMessage ''UniWorX ''SubmissionModeDescr
$ let verbMap [_, _, "None"] = "NoSubmissions"
verbMap [_, _, v] = v <> "Submissions"
verbMap _ = error "Invalid number of verbs"
in verbMap . splitCamel
newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@ -742,15 +746,15 @@ tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == UserSubmissions
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
guard $ is _Just submissionModeUser
return Authorized
r -> $unsupportedAuthPredicate AuthUserSubmissions r
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == CorrectorSubmissions
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
guard submissionModeCorrector
return Authorized
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do
@ -1891,7 +1895,7 @@ pageActions (CorrectionsR) =
, menuItemModal = False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId
[E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let
isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
@ -1900,10 +1904,9 @@ pageActions (CorrectionsR) =
isLecturer = E.exists . E.from $ \lecturer -> E.where_
$ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. ( isCorrector' E.||. isLecturer )
return E.countRows
return $ (sheetCount :: Int) /= 0
E.where_ $ isCorrector' E.||. isLecturer
return $ sheet E.^. SheetSubmissionMode
return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
}
, MenuItem
{ menuItemType = PageActionPrime
@ -1931,7 +1934,7 @@ pageActions (CorrectionsGradeR) =
, menuItemModal = False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId
[E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let
isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
@ -1940,10 +1943,9 @@ pageActions (CorrectionsGradeR) =
isLecturer = E.exists . E.from $ \lecturer -> E.where_
$ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. ( isCorrector' E.||. isLecturer )
return E.countRows
return $ (sheetCount :: Int) /= 0
E.where_ $ isCorrector' E.||. isLecturer
return $ sheet E.^. SheetSubmissionMode
return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
}
]
pageActions _ = []

10
src/Handler/Corrections.hs
View File

@ -80,9 +80,6 @@ courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO
sheetIs :: Key Sheet -> CorrectionTableWhere
sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere
submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
-- Columns
colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
@ -731,7 +728,7 @@ getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
getCorrectionsCreateR = postCorrectionsCreateR
postCorrectionsCreateR = do
uid <- requireAuthId
let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let
isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_
@ -740,10 +737,9 @@ postCorrectionsCreateR = do
isLecturer = E.exists . E.from $ \lecturer -> E.where_
$ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. ( isCorrector E.||. isLecturer )
E.where_ $ isCorrector E.||. isLecturer
E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName))
mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
mkOptList opts = do
opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts

4
src/Handler/Profile.hs
View File

@ -515,9 +515,9 @@ mkCorrectionsTable =
, sortable (toNothing "cload") (i18nCell MsgCorProportion) $
correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal)
, sortable (toNothing "assigned") (i18nCell MsgCorProportion) $
int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue)
int64Cell <$> view (_dbrOutput . _4 . _1 . _Value)
, sortable (toNothing "corrected") (i18nCell MsgCorProportion) $
int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
int64Cell <$> view (_dbrOutput . _4 . _2 . _Value)
]
validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]

9
src/Handler/Sheet.hs
View File

@ -71,8 +71,7 @@ data SheetForm = SheetForm
, sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime
, sfActiveTo :: UTCTime
, sfSubmissionMode :: SheetSubmissionMode
, sfUploadMode :: UploadMode
, sfSubmissionMode :: SubmissionMode
, sfSheetF :: Maybe (Source Handler (Either FileId File))
, sfHintFrom :: Maybe UTCTime
, sfHintF :: Maybe (Source Handler (Either FileId File))
@ -112,8 +111,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
& setTooltip MsgSheetActiveFromTip)
(sfActiveFrom <$> template)
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
<*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
<*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True))
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
@ -464,7 +462,6 @@ getSheetNewR tid ssh csh = do
, sfActiveFrom = addTime sheetActiveFrom
, sfActiveTo = addTime sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfUploadMode = sheetUploadMode
, sfSheetF = Nothing
, sfHintFrom = addTime <$> sheetHintFrom
, sfHintF = Nothing
@ -497,7 +494,6 @@ getSEditR tid ssh csh shn = do
, sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfUploadMode = sheetUploadMode
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
, sfHintFrom = sheetHintFrom
, sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
@ -539,7 +535,6 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetActiveTo = sfActiveTo
, sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom
, sheetUploadMode = sfUploadMode
, sheetSubmissionMode = sfSubmissionMode
, sheetAutoDistribute = fromMaybe False oldAutoDistribute
}

10
src/Handler/Submission.hs
View File

@ -75,12 +75,12 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FI
getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionNewR = postSubmissionNewR
postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn Nothing
getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubShowR = postSubShowR
postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid
getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionOwnR tid ssh csh shn = do
@ -98,8 +98,8 @@ getSubmissionOwnR tid ssh csh shn = do
cID <- encrypt sid
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
submissionHelper tid ssh csh shn mcid = do
(Entity uid userData) <- requireAuth
msmid <- traverse decrypt mcid
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
@ -168,7 +168,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
return (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (csheet,buddies,lastEdits)
((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies)
let formWidget = wrapForm formWidget' def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype

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

@ -140,7 +140,47 @@ linkButton lbl cls url = do
^{lbl}
|]
--------------------------
-- Interactive fieldset --
--------------------------
multiAction :: forall action a.
( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction acts fs@FieldSettings{..} defAction csrf = do
mr <- getMessageRender
let
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
(actionRes, actionView) <- mreq (selectField $ return options) fs defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let actionResults = view _1 <$> results
actionViews = Map.foldrWithKey accViews [] results
accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> AForm Handler a
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, Widget))
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
------------
-- Fields --
------------
@ -277,8 +317,26 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
uploadModeField :: Field Handler UploadMode
uploadModeField = selectField optionsFinite
submissionModeField :: Field Handler SheetSubmissionMode
submissionModeField = selectField optionsFinite
submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
where
uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)
actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
actions = Map.fromList
[ ( SubmissionModeNone
, pure $ SubmissionMode False Nothing
)
, ( SubmissionModeCorrector
, pure $ SubmissionMode True Nothing
)
, ( SubmissionModeUser
, SubmissionMode False . Just <$> uploadModeForm
)
, ( SubmissionModeBoth
, SubmissionMode True . Just <$> uploadModeForm
)
]
pseudonymWordField :: Field Handler PseudonymWord
pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
@ -605,42 +663,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
}) cPairs
multiAction :: forall action a.
( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction acts fs@FieldSettings{..} defAction csrf = do
mr <- getMessageRender
let
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
(actionRes, actionView) <- mreq (selectField $ return options) fs defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let actionResults = view _1 <$> results
actionViews = Map.foldrWithKey accViews [] results
accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> AForm Handler a
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, Widget))
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
formResultModal res finalDest handler = maybeT_ $ do
messages <- case res of

17
src/Model/Migration.hs
View File

@ -223,6 +223,23 @@ customMigrations = Map.fromListWith (>>)
whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
)
, ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
, whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |]
[executeQQ|
ALTER TABLE "sheet" DROP COLUMN "upload_mode";
ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT;
ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb;
|]
forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do
let submissionMode' = case (submissionMode, uploadMode) of
( Legacy.NoSubmissions , _ ) -> SubmissionMode False Nothing
( Legacy.CorrectorSubmissions, _ ) -> SubmissionMode True Nothing
( Legacy.UserSubmissions , Legacy.NoUpload ) -> SubmissionMode False (Just NoUpload)
( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ Upload True)
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
[executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
)
]

40
src/Model/Migration/Types.hs
View File

@ -1,11 +1,17 @@
module Model.Migration.Types where
import ClassyPrelude.Yesod
import Data.Aeson
import Data.Aeson.TH (deriveJSON, defaultOptions)
import Utils.PathPiece
import qualified Model as Current
import qualified Model.Types.JSON as Current
import Data.Universe
data SheetType
= Bonus { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
| Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben
@ -19,6 +25,40 @@ sheetType Normal {..} = Current.Normal Current.Points {..}
sheetType Pass {..} = Current.Normal Current.PassPoints {..}
sheetType NotGraded = Current.NotGraded
data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriving (Show, Read, Eq, Ord, Generic)
deriveJSON defaultOptions ''UploadMode
Current.derivePersistFieldJSON ''UploadMode
instance Universe UploadMode where
universe = NoUpload : (Upload <$> universe)
instance Finite UploadMode
instance PathPiece UploadMode where
toPathPiece = \case
NoUpload -> "no-upload"
Upload True -> "unpack"
Upload False -> "no-unpack"
fromPathPiece = finiteFromPathPiece
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
| UserSubmissions
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
} ''SheetSubmissionMode
derivePersistField "SheetSubmissionMode"
instance Universe SheetSubmissionMode
instance Finite SheetSubmissionMode
nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
{- TODO:
* RenderMessage instance for newtype(SheetType) if needed
-}

63
src/Model/Types.hs
View File

@ -16,6 +16,7 @@ import Utils
import Control.Lens hiding (universe)
import Utils.Lens.TH
import Data.Map ((!))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
@ -24,6 +25,7 @@ import Data.Monoid (Sum(..))
import Data.Maybe (fromJust)
import Data.Universe
import Data.Universe.Helpers
import Data.Universe.TH
import Data.UUID.Types (UUID)
import qualified Data.UUID.Types as UUID
@ -289,12 +291,14 @@ instance DisplayAble DA where
data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriving (Show, Read, Eq, Ord, Generic)
deriveJSON defaultOptions ''UploadMode
derivePersistFieldJSON ''UploadMode
deriveFinite ''UploadMode
instance Universe UploadMode where
universe = NoUpload : (Upload <$> universe)
instance Finite UploadMode
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
, fieldLabelModifier = camelToPathPiece
, sumEncoding = TaggedObject "mode" "settings"
}''UploadMode
derivePersistFieldJSON ''UploadMode
instance PathPiece UploadMode where
toPathPiece = \case
@ -303,20 +307,49 @@ instance PathPiece UploadMode where
Upload False -> "no-unpack"
fromPathPiece = finiteFromPathPiece
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
| UserSubmissions
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
data SubmissionMode = SubmissionMode
{ submissionModeCorrector :: Bool
, submissionModeUser :: Maybe UploadMode
}
deriving (Show, Read, Eq, Ord, Generic)
deriveFinite ''SubmissionMode
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
} ''SheetSubmissionMode
derivePersistField "SheetSubmissionMode"
{ fieldLabelModifier = camelToPathPiece' 2
} ''SubmissionMode
derivePersistFieldJSON ''SubmissionMode
instance Universe SheetSubmissionMode
instance Finite SheetSubmissionMode
instance PathPiece SubmissionMode where
toPathPiece = (Map.fromList (zip universeF verbs) !)
where
verbs = [ "no-submissions"
, "no-upload"
, "no-unpack"
, "unpack"
, "correctors"
, "correctors+no-upload"
, "correctors+no-unpack"
, "correctors+unpack"
]
fromPathPiece = finiteFromPathPiece
nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
data SubmissionModeDescr = SubmissionModeNone
| SubmissionModeCorrector
| SubmissionModeUser
| SubmissionModeBoth
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe SubmissionModeDescr
instance Finite SubmissionModeDescr
nullaryPathPiece ''SubmissionModeDescr $ camelToPathPiece' 2
classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector
classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth
data ExamStatus = Attended | NoShow | Voided
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)

7
src/Utils/Lens.hs
View File

@ -11,9 +11,6 @@ import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
_unValue :: Lens' (E.Value a) a
_unValue f (E.Value a) = E.Value <$> f a
_PathPiece :: PathPiece v => Prism' Text v
_PathPiece = prism' toPathPiece fromPathPiece
@ -102,6 +99,10 @@ makePrisms ''ErrorResponse
makeLenses_ ''SheetCorrectorInvitation
makeLenses_ ''SubmissionMode
makePrisms ''E.Value
-- makeClassy_ ''Load

10
static/js/utils/form.js
View File

@ -149,7 +149,7 @@
var INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR = '.interactive-fieldset--target';
var INTERACTIVE_FIELDSET_INITIALIZED_CLASS = 'interactive-fieldset--initialized';
var INTERACTIVE_FIELDSET_CHILD_SELECTOR = 'input:not([disabled])';
var INTERACTIVE_FIELDSET_CHILD_SELECTOR = 'input:not([disabled]), select:not([disabled]), textarea:not([disabled]), button:not([disabled])';
var interactiveFieldsetUtil = function(element) {
var conditionalInput;
@ -188,6 +188,10 @@
childInputs = Array.from(element.querySelectorAll(INTERACTIVE_FIELDSET_CHILD_SELECTOR));
// add event listener
var observer = new MutationObserver(function(mutationsList, observer) {
updateVisibility();
});
observer.observe(conditionalInput, { attributes: true, attributeFilter: ['disabled'] });
conditionalInput.addEventListener('input', updateVisibility);
// initial visibility update
@ -204,12 +208,12 @@
}
function updateVisibility() {
var active = matchesConditionalValue();
var active = matchesConditionalValue() && !conditionalInput.disabled;
target.classList.toggle('hidden', !active);
childInputs.forEach(function(el) {
el.toggleAttribute('disabled', !active);
el.disabled = !active;
});
}

6
templates/sheetShow.hamlet
View File

@ -18,15 +18,15 @@ $maybe descr <- sheetDescription sheet
<dt .deflist__dt>_{MsgSheetSolutionFrom}
<dd .deflist__dd>#{solution}
<dt .deflist__dt>_{MsgSheetSubmissionMode}
<dd .deflist__dd>_{sheetSubmissionMode sheet}
<dd .deflist__dd>_{classifySubmissionMode (sheetSubmissionMode sheet)}
$case sheetSubmissionMode sheet
$of CorrectorSubmissions
$of SubmissionMode True _
<div .tooltip>
<div .tooltip__handle>
<div .tooltip__content>_{MsgSheetCorrectorSubmissionsTip}
$of _
$case sheetSubmissionMode sheet
$of CorrectorSubmissions
$of SubmissionMode True _
<dt .deflist__dt>_{MsgSheetPseudonym}
<dd .deflist__dd #pseudonym>
$maybe pseudonym <- mPseudonym

10
templates/submission.hamlet
View File

@ -1,7 +1,10 @@
$maybe cID <- mcid
<section>
$case sheetUploadMode
$of Upload _
$case sheetSubmissionMode
$of SubmissionMode False Nothing
<p>
_{MsgSubmissionNoUploadExpected}
$of _
<h2>
<a href=@{urlArchive cID}>Archiv
(<a href=@{urlOriginal cID}>Original</a>)
@ -9,9 +12,6 @@ $maybe cID <- mcid
$maybe fileTable <- mFileTable
<h3>_{MsgSubmissionFiles}
^{fileTable}
$of _
<p>
_{MsgSubmissionNoUploadExpected}
$if maySubmit && not (null lastEdits)
<h3>_{MsgLastEdits}

9
test/Database.hs
View File

@ -397,11 +397,11 @@ fillDb = do
void . insert $ DegreeCourse ffp sdMst sdInf
void . insert $ Lecturer jost ffp CourseLecturer
void . insert $ Lecturer gkleen ffp CourseAssistant
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
insert_ $ SheetEdit gkleen now adhoc
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
insert_ $ SheetEdit gkleen now feste
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
insert_ $ SheetEdit gkleen now keine
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
[(fhamann , Nothing)
@ -496,8 +496,7 @@ fillDb = do
, sheetVisibleFrom = Just now
, sheetActiveFrom = now
, sheetActiveTo = (14 * nominalDay) `addUTCTime` now
, sheetSubmissionMode = CorrectorSubmissions
, sheetUploadMode = Upload True
, sheetSubmissionMode = SubmissionMode True Nothing
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing
, sheetAutoDistribute = True

12
test/Model/TypesSpec.hs
View File

@ -66,7 +66,11 @@ instance Arbitrary UploadMode where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary SheetSubmissionMode where
instance Arbitrary SubmissionMode where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary SubmissionModeDescr where
arbitrary = genericArbitrary
shrink = genericShrink
@ -171,8 +175,10 @@ spec = do
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
lawsCheckHspec (Proxy @UploadMode)
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
lawsCheckHspec (Proxy @SheetSubmissionMode)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @SubmissionMode)
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, finiteLaws ]
lawsCheckHspec (Proxy @SubmissionModeDescr)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
lawsCheckHspec (Proxy @ExamStatus)
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
lawsCheckHspec (Proxy @Load)