Gregor Kleen
parent
47c97652f2
commit
899741bb41
@ -85,6 +85,7 @@ SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheet
|
||||
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
|
||||
SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht.
|
||||
|
||||
SheetUploadMode: Abgabe von Dateien
|
||||
SheetExercise: Aufgabenstellung
|
||||
SheetHint: Hinweis
|
||||
SheetHintFrom: Hinweis ab
|
||||
@ -285,3 +286,9 @@ DummyLoginTitle: Development-Login
|
||||
CorrectorNormal: Normal
|
||||
CorrectorMissing: Abwesend
|
||||
CorrectorExcused: Entschuldigt
|
||||
|
||||
UploadModeNone: Kein Upload
|
||||
UploadModeUnpack: Upload, einzelne Datei
|
||||
UploadModeNoUnpack: Upload, ZIP-Archive entpacken
|
||||
|
||||
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
|
||||
1
models
1
models
@ -108,6 +108,7 @@ Sheet
|
||||
activeTo UTCTime
|
||||
hintFrom UTCTime Maybe
|
||||
solutionFrom UTCTime Maybe
|
||||
uploadMode UploadMode
|
||||
CourseSheet course name
|
||||
SheetEdit
|
||||
user UserId
|
||||
|
||||
@ -81,6 +81,7 @@ data SheetForm = SheetForm
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: UTCTime
|
||||
, sfActiveTo :: UTCTime
|
||||
, sfUploadMode :: UploadMode
|
||||
, sfSheetF :: Maybe (Source Handler (Either FileId File))
|
||||
, sfHintFrom :: Maybe UTCTime
|
||||
, sfHintF :: Maybe (Source Handler (Either FileId File))
|
||||
@ -118,6 +119,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
& setTooltip MsgSheetActiveFromTip)
|
||||
(sfActiveFrom <$> template)
|
||||
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
|
||||
<*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True))
|
||||
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
|
||||
& setTooltip MsgSheetHintFromTip)
|
||||
@ -367,6 +369,7 @@ getSheetNewR tid ssh csh = do
|
||||
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
|
||||
, sfActiveFrom = addOneWeek sheetActiveFrom
|
||||
, sfActiveTo = addOneWeek sheetActiveTo
|
||||
, sfUploadMode = sheetUploadMode
|
||||
, sfSheetF = Nothing
|
||||
, sfHintFrom = addOneWeek <$> sheetHintFrom
|
||||
, sfHintF = Nothing
|
||||
@ -400,6 +403,7 @@ getSEditR tid ssh csh shn = do
|
||||
, sfVisibleFrom = sheetVisibleFrom
|
||||
, sfActiveFrom = sheetActiveFrom
|
||||
, sfActiveTo = sheetActiveTo
|
||||
, sfUploadMode = sheetUploadMode
|
||||
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
|
||||
, sfHintFrom = sheetHintFrom
|
||||
, sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
|
||||
@ -428,7 +432,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
actTime <- liftIO getCurrentTime
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let newSheet = Sheet
|
||||
{ sheetCourse = cid
|
||||
{ sheetCourse = cid
|
||||
, sheetName = sfName
|
||||
, sheetDescription = sfDescription
|
||||
, sheetType = sfType
|
||||
@ -439,6 +443,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
, sheetActiveTo = sfActiveTo
|
||||
, sheetHintFrom = sfHintFrom
|
||||
, sheetSolutionFrom = sfSolutionFrom
|
||||
, sheetUploadMode = sfUploadMode
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
|
||||
@ -63,10 +63,14 @@ import qualified Text.Blaze.Html5.Attributes as HA
|
||||
-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
||||
|
||||
|
||||
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
|
||||
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
|
||||
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
|
||||
makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do
|
||||
let
|
||||
fileUpload = case uploadMode of
|
||||
NoUpload -> pure Nothing
|
||||
(Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
flip (renderAForm FormStandard) html $ (,)
|
||||
<$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
<$> fileUpload
|
||||
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
||||
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
|
||||
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
|
||||
@ -173,8 +177,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 (sheet,buddies,lastEdits)
|
||||
let unpackZips = True -- undefined -- TODO
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
|
||||
mCID <- runDB $ do
|
||||
res' <- case res of
|
||||
(FormMissing ) -> return $ FormMissing
|
||||
@ -231,7 +234,14 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
-> return smid
|
||||
(Just files, _) -- new files
|
||||
-> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
|
||||
_ -> error "Impossible, because of definition of `makeSubmissionForm`"
|
||||
(Nothing, Nothing) -- new submission, no file upload requested
|
||||
-> insert Submission
|
||||
{ submissionSheet = shid
|
||||
, submissionRatingPoints = Nothing
|
||||
, submissionRatingComment = Nothing
|
||||
, submissionRatingBy = Nothing
|
||||
, submissionRatingTime = Nothing
|
||||
}
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
||||
|
||||
@ -249,6 +249,13 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
|
||||
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
||||
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
|
||||
|
||||
uploadModeField :: Field Handler UploadMode
|
||||
uploadModeField = selectFieldList
|
||||
[ (MsgUploadModeNone , NoUpload )
|
||||
, (MsgUploadModeNoUnpack, Upload False)
|
||||
, (MsgUploadModeUnpack , Upload True )
|
||||
]
|
||||
|
||||
zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Field Handler (Source Handler File)
|
||||
zipFileField doUnpack = Field{..}
|
||||
|
||||
@ -168,12 +168,18 @@ customMigrations = Map.fromListWith (>>)
|
||||
, whenM (tableExists "user") $ do
|
||||
userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
|
||||
[executeQQ|
|
||||
ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' ';
|
||||
ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT '';
|
||||
|]
|
||||
forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
|
||||
Just name -> update uid [UserSurname =. name]
|
||||
_other -> error $ "Empty userDisplayName found"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
|
||||
, whenM (tableExists "sheet") $ do
|
||||
[executeQQ|
|
||||
ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -193,6 +193,12 @@ instance DisplayAble DA where
|
||||
-}
|
||||
|
||||
|
||||
data UploadMode = NoUpload | Upload { unpackZips :: Bool }
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
|
||||
deriveJSON defaultOptions ''UploadMode
|
||||
derivePersistFieldJSON ''UploadMode
|
||||
|
||||
data ExamStatus = Attended | NoShow | Voided
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
||||
derivePersistField "ExamStatus"
|
||||
|
||||
@ -1,12 +1,17 @@
|
||||
$maybe cID <- mcid
|
||||
<section>
|
||||
<h2>
|
||||
<a href=@{urlArchive cID}>Archiv
|
||||
(<a href=@{urlOriginal cID}>Original</a>)
|
||||
$case sheetUploadMode
|
||||
$of Upload _
|
||||
<h2>
|
||||
<a href=@{urlArchive cID}>Archiv
|
||||
(<a href=@{urlOriginal cID}>Original</a>)
|
||||
|
||||
$maybe fileTable <- mFileTable
|
||||
<h3>_{MsgSubmissionFiles}
|
||||
^{fileTable}
|
||||
$maybe fileTable <- mFileTable
|
||||
<h3>_{MsgSubmissionFiles}
|
||||
^{fileTable}
|
||||
$of _
|
||||
<p>
|
||||
_{MsgSubmissionNoUploadExpected}
|
||||
|
||||
$if not (null lastEdits)
|
||||
<h3>_{MsgLastEdits}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user