refactor: split up Corrections and move below Submission
This commit is contained in:
Gregor Kleen
parent
21af3e1348
commit
b4cf9ca4bb
@ -109,7 +109,6 @@ import Handler.Course
|
|||||||
import Handler.Sheet
|
import Handler.Sheet
|
||||||
import Handler.Submission
|
import Handler.Submission
|
||||||
import Handler.Tutorial
|
import Handler.Tutorial
|
||||||
import Handler.Corrections
|
|
||||||
import Handler.Material
|
import Handler.Material
|
||||||
import Handler.CryptoIDDispatch
|
import Handler.CryptoIDDispatch
|
||||||
import Handler.SystemMessage
|
import Handler.SystemMessage
|
||||||
|
|||||||
@ -20,7 +20,7 @@ import Handler.Course.Register
|
|||||||
|
|
||||||
import Jobs.Queue
|
import Jobs.Queue
|
||||||
|
|
||||||
import Handler.Corrections
|
import Handler.Submission.List
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
|||||||
@ -6,6 +6,11 @@ module Handler.Submission
|
|||||||
, module Handler.Submission.Delete
|
, module Handler.Submission.Delete
|
||||||
, module Handler.Submission.Assign
|
, module Handler.Submission.Assign
|
||||||
, module Handler.Submission.SubmissionUserInvite
|
, module Handler.Submission.SubmissionUserInvite
|
||||||
|
, module Handler.Submission.List
|
||||||
|
, module Handler.Submission.Correction
|
||||||
|
, module Handler.Submission.Create
|
||||||
|
, module Handler.Submission.Grade
|
||||||
|
, module Handler.Submission.Upload
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Handler.Submission.New
|
import Handler.Submission.New
|
||||||
@ -14,6 +19,11 @@ import Handler.Submission.Download
|
|||||||
import Handler.Submission.Delete
|
import Handler.Submission.Delete
|
||||||
import Handler.Submission.Assign
|
import Handler.Submission.Assign
|
||||||
import Handler.Submission.SubmissionUserInvite (getSInviteR, postSInviteR)
|
import Handler.Submission.SubmissionUserInvite (getSInviteR, postSInviteR)
|
||||||
|
import Handler.Submission.List (getCorrectionsR, postCorrectionsR, getCCorrectionsR, postCCorrectionsR, getSSubsR, postSSubsR)
|
||||||
|
import Handler.Submission.Correction
|
||||||
|
import Handler.Submission.Create
|
||||||
|
import Handler.Submission.Grade
|
||||||
|
import Handler.Submission.Upload
|
||||||
|
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|||||||
@ -1,10 +1,24 @@
|
|||||||
module Handler.Submission.Assign
|
module Handler.Submission.Assign
|
||||||
( getSubAssignR, postSubAssignR
|
( getSubAssignR, postSubAssignR
|
||||||
|
, getCAssignR, postCAssignR
|
||||||
|
, getSAssignR, postSAssignR
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import hiding (link)
|
||||||
|
|
||||||
import Handler.Utils
|
import Handler.Utils hiding (colSchool)
|
||||||
|
import Handler.Utils.Corrections
|
||||||
|
import Handler.Utils.Submission
|
||||||
|
|
||||||
|
import Data.List as List (foldl, foldr)
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Data.Map.Strict ((!))
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
|
||||||
getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||||
@ -40,3 +54,228 @@ postSubAssignR tid ssh csh shn cID = do
|
|||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI MsgCorrectorAssignTitle
|
setTitleI MsgCorrectorAssignTitle
|
||||||
$(widgetFile "submission-assign")
|
$(widgetFile "submission-assign")
|
||||||
|
|
||||||
|
|
||||||
|
data ButtonSubmissionsAssign = BtnSubmissionsAssign
|
||||||
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||||
|
instance Universe ButtonSubmissionsAssign
|
||||||
|
instance Finite ButtonSubmissionsAssign
|
||||||
|
nullaryPathPiece ''ButtonSubmissionsAssign camelToPathPiece
|
||||||
|
embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
|
||||||
|
instance Button UniWorX ButtonSubmissionsAssign where
|
||||||
|
btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
|
||||||
|
|
||||||
|
getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||||
|
getCAssignR = postCAssignR
|
||||||
|
postCAssignR tid ssh csh = do
|
||||||
|
cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||||
|
assignHandler tid ssh csh cid []
|
||||||
|
|
||||||
|
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||||
|
getSAssignR = postSAssignR
|
||||||
|
postSAssignR tid ssh csh shn = do
|
||||||
|
(shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn
|
||||||
|
assignHandler tid ssh csh cid [shid]
|
||||||
|
|
||||||
|
{- TODO: Feature:
|
||||||
|
make distivt buttons for each sheet, so that users see which sheet will be assigned.
|
||||||
|
Currently this information is available within the page heading!
|
||||||
|
|
||||||
|
Stub:
|
||||||
|
data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName
|
||||||
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||||
|
instance Button UniWorX ButtonCorrectionsAssign
|
||||||
|
-- Are those needed any more?
|
||||||
|
instance Universe ButtonCorrectionsAssign
|
||||||
|
instance Finite ButtonCorrectionsAssign
|
||||||
|
nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece
|
||||||
|
embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id
|
||||||
|
instance Button UniWorX ButtonCorrectionsAssign where
|
||||||
|
btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary]
|
||||||
|
-- use runButtonForm' instead later on
|
||||||
|
-}
|
||||||
|
|
||||||
|
assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html
|
||||||
|
assignHandler tid ssh csh cid assignSids = do
|
||||||
|
-- evaluate form first, since it affects DB action
|
||||||
|
(btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions
|
||||||
|
|
||||||
|
-- gather data
|
||||||
|
(orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
|
||||||
|
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||||
|
nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
|
||||||
|
|
||||||
|
sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
|
||||||
|
let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList
|
||||||
|
sheets = entities2map sheetList
|
||||||
|
sheetIds = Map.keys sheets
|
||||||
|
groupsPossible :: Bool
|
||||||
|
groupsPossible =
|
||||||
|
let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups
|
||||||
|
in List.foldr foldFun False sheetList
|
||||||
|
assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids
|
||||||
|
|
||||||
|
-- plan or assign unassigned submissions for given sheets
|
||||||
|
let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational))
|
||||||
|
buildA acc sid = maybeT (return acc) $ do
|
||||||
|
let shn = sheetName $ sheets ! sid
|
||||||
|
-- is sheet closed?
|
||||||
|
guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable
|
||||||
|
-- ask for assignment plan
|
||||||
|
let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections
|
||||||
|
ignoreExceptions NoCorrectors = return mempty
|
||||||
|
ignoreExceptions NoCorrectorsByProportion = return mempty
|
||||||
|
ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing
|
||||||
|
(plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
|
||||||
|
guard $ not $ null plan -- only proceed if there is a plan for this sheet
|
||||||
|
-- implement assignment plan
|
||||||
|
status <- lift $ case btnResult of
|
||||||
|
Nothing -> return (Set.empty, Set.empty)
|
||||||
|
(Just BtnSubmissionsAssign) -> do
|
||||||
|
status@(sub_ok,sub_fail) <- writeSubmissionPlan plan
|
||||||
|
let nr_ok = olength sub_ok
|
||||||
|
nr_fail = olength sub_fail
|
||||||
|
alert_ok = toMaybe (nr_ok > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok
|
||||||
|
alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed nr_fail
|
||||||
|
msg_status = bool Success Error $ nr_fail > 0
|
||||||
|
msg_header = SomeMessage $ shn <> ":"
|
||||||
|
when (nr_ok > 0 || nr_fail > 0) $
|
||||||
|
addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail]
|
||||||
|
return status
|
||||||
|
return $ Map.insert shn (status, countMapElems plan, deficit) acc
|
||||||
|
assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts
|
||||||
|
then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
|
||||||
|
else return assignSids
|
||||||
|
assignment <- foldM buildA Map.empty assignSids'
|
||||||
|
|
||||||
|
correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do
|
||||||
|
E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||||
|
E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
|
||||||
|
return (corrector, user)
|
||||||
|
let correctorMap' :: Map UserId (User, Map SheetName SheetCorrector)
|
||||||
|
correctorMap' = (\f -> foldl f Map.empty correctors)
|
||||||
|
(\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
|
||||||
|
let shn = sheetName $ sheets ! sheetCorrectorSheet
|
||||||
|
in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc
|
||||||
|
)
|
||||||
|
-- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names
|
||||||
|
act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do
|
||||||
|
E.on $ submission E.^. SubmissionRatingBy E.==. (E.just $ user E.^. UserId)
|
||||||
|
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
|
||||||
|
return (submission E.^. SubmissionSheet, user)
|
||||||
|
let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
|
||||||
|
correctorMap = (\f -> foldl f correctorMap' act_correctors)
|
||||||
|
(\acc (E.Value sheetCorrectorSheet, Entity uid user) ->
|
||||||
|
let shn = sheetName $ sheets ! sheetCorrectorSheet
|
||||||
|
scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused
|
||||||
|
in Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged
|
||||||
|
)
|
||||||
|
|
||||||
|
submissions <- E.select . E.from $ \submission -> do
|
||||||
|
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
|
||||||
|
let numSubmittors = E.subSelectCount . E.from $ \subUser ->
|
||||||
|
E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
|
||||||
|
return (submission, numSubmittors)
|
||||||
|
-- prepare map
|
||||||
|
let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
|
||||||
|
infoMap = List.foldl (flip buildS) emptySheets submissions
|
||||||
|
|
||||||
|
-- ensure that all sheets are shown, including those without any submissions
|
||||||
|
emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds
|
||||||
|
emptyCorrs = foldl (\m uid -> let cic = Just uid in
|
||||||
|
Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap
|
||||||
|
|
||||||
|
|
||||||
|
buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo)
|
||||||
|
buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m =
|
||||||
|
let shnm = sheetName $ sheets ! submissionSheet
|
||||||
|
corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned
|
||||||
|
cinf = Map.singleton submissionRatingBy $ CorrectionInfo
|
||||||
|
{ ciSubmittors = fromIntegral nrSbmtrs
|
||||||
|
, ciSubmissions = 1
|
||||||
|
, ciAssigned = maybe 0 (const 1) submissionRatingBy -- only used in sheetMap
|
||||||
|
, ciCorrected = maybe 0 (const 1) submissionRatingTime
|
||||||
|
, ciCorrector = submissionRatingBy
|
||||||
|
, ciMin = corTime
|
||||||
|
, ciTot = corTime
|
||||||
|
, ciMax = corTime
|
||||||
|
}
|
||||||
|
in Map.insertWith (Map.unionWith (<>)) shnm cinf m
|
||||||
|
|
||||||
|
return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
|
||||||
|
|
||||||
|
let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
|
||||||
|
-- create aggregate maps
|
||||||
|
|
||||||
|
-- Always iterate over orderedSheetNames for consistent sorting!
|
||||||
|
sheetMap :: Map SheetName CorrectionInfo
|
||||||
|
sheetMap = Map.map fold infoMap
|
||||||
|
|
||||||
|
sheetLoad :: Map SheetName Load
|
||||||
|
sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap)
|
||||||
|
let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc
|
||||||
|
buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal}
|
||||||
|
= Map.insertWith (<>) s l acc
|
||||||
|
buildL acc _ _ = acc
|
||||||
|
in Map.foldl buildSL Map.empty correctorMap
|
||||||
|
|
||||||
|
deficitMap :: Map UserId Rational
|
||||||
|
deficitMap = foldMap (view _3) assignment
|
||||||
|
|
||||||
|
corrMap :: Map (Maybe UserId) CorrectionInfo
|
||||||
|
corrMap = Map.unionsWith (<>) $ Map.elems infoMap
|
||||||
|
|
||||||
|
corrInfos :: [CorrectionInfo]
|
||||||
|
corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap
|
||||||
|
where byName Nothing = Nothing
|
||||||
|
byName (Just uid) = Map.lookup uid correctorMap
|
||||||
|
corrMapSum :: CorrectionInfo
|
||||||
|
corrMapSum = fold corrMap
|
||||||
|
|
||||||
|
let -- whamlet convenience functions
|
||||||
|
-- avoid nestes hamlet $maybe with duplicated $nothing
|
||||||
|
getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text)
|
||||||
|
getCorrector (Just uid)
|
||||||
|
| Just (User{..},loadMap) <- Map.lookup uid correctorMap
|
||||||
|
= (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName)
|
||||||
|
-- | Just (User{..} ) <- Map.lookup uid lecturerNames
|
||||||
|
-- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases
|
||||||
|
getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty)
|
||||||
|
-- avoid nestes hamlet $maybe with duplicated $nothing
|
||||||
|
getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo
|
||||||
|
getCorrSheetStatus corr shn
|
||||||
|
| (Just smap) <- Map.lookup shn infoMap
|
||||||
|
= Map.lookup corr smap
|
||||||
|
getCorrSheetStatus _ _ = Nothing
|
||||||
|
-- avoid nestes hamlet $maybe with duplicated $nothing
|
||||||
|
getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int
|
||||||
|
getCorrNewAssignment corr shn
|
||||||
|
| (Just (_,cass,_)) <- Map.lookup shn assignment
|
||||||
|
= Map.lookup corr cass
|
||||||
|
getCorrNewAssignment _ _ = Nothing
|
||||||
|
-- avoid nestes hamlet $maybe with duplicated $nothing
|
||||||
|
getCorrDeficit :: Maybe UserId -> Maybe Rational
|
||||||
|
getCorrDeficit (Just uid) = Map.lookup uid deficitMap
|
||||||
|
getCorrDeficit _ = Nothing
|
||||||
|
|
||||||
|
getLoadSum :: SheetName -> Text
|
||||||
|
getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad
|
||||||
|
= showCompactCorrectorLoad load CorrectorNormal
|
||||||
|
getLoadSum _ = mempty
|
||||||
|
|
||||||
|
showDiffDays :: Maybe NominalDiffTime -> Text
|
||||||
|
showDiffDays = foldMap formatDiffDays
|
||||||
|
showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
|
||||||
|
showAvgsDays Nothing _ = mempty
|
||||||
|
showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
|
||||||
|
let headingShort
|
||||||
|
| 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
|
||||||
|
| otherwise = MsgMenuCorrectionsAssign
|
||||||
|
headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
|
||||||
|
|
||||||
|
unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames
|
||||||
|
unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets
|
||||||
|
|
||||||
|
siteLayoutMsg headingShort $ do
|
||||||
|
setTitleI headingLong
|
||||||
|
$(widgetFile "corrections-overview")
|
||||||
|
|||||||
154
src/Handler/Submission/Correction.hs
Normal file
154
src/Handler/Submission/Correction.hs
Normal file
@ -0,0 +1,154 @@
|
|||||||
|
module Handler.Submission.Correction
|
||||||
|
( getCorrectionR, postCorrectionR
|
||||||
|
, getCorrectionUserR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import hiding (link)
|
||||||
|
-- import System.FilePath (takeFileName)
|
||||||
|
|
||||||
|
import Jobs
|
||||||
|
import Handler.Utils hiding (colSchool)
|
||||||
|
import Handler.Utils.Submission
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
import qualified Control.Monad.State.Class as State
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
import qualified Data.Conduit.List as C
|
||||||
|
|
||||||
|
|
||||||
|
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
||||||
|
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
||||||
|
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||||
|
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||||
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||||
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||||
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||||
|
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||||
|
E.&&. submission E.^. SubmissionId E.==. E.val sub
|
||||||
|
return (course, sheet, submission, corrector)
|
||||||
|
|
||||||
|
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||||
|
getCorrectionR tid ssh csh shn cid = do
|
||||||
|
mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
|
||||||
|
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
|
||||||
|
postCorrectionR tid ssh csh shn cid = do
|
||||||
|
sub <- decrypt cid
|
||||||
|
|
||||||
|
(results, isLecturer) <- runDB $ (,)
|
||||||
|
<$> correctionData tid ssh csh shn sub
|
||||||
|
<*> hasWriteAccessTo (CSheetR tid ssh csh shn SSubsR)
|
||||||
|
|
||||||
|
MsgRenderer mr <- getMsgRenderer
|
||||||
|
case results of
|
||||||
|
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
|
||||||
|
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
||||||
|
pointsForm = case sheetType of
|
||||||
|
NotGraded
|
||||||
|
-> pure Nothing
|
||||||
|
(preview _grading -> Just PassBinary)
|
||||||
|
-> Just <$> apopt (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) submissionRatingPoints
|
||||||
|
(preview _grading -> Just PassAlways)
|
||||||
|
-> Just <$> aforced (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) 1
|
||||||
|
_otherwise
|
||||||
|
-> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
|
||||||
|
(fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
|
||||||
|
(Just submissionRatingPoints)
|
||||||
|
correctorForm
|
||||||
|
| not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId
|
||||||
|
| otherwise = wFormToAForm $ do
|
||||||
|
let correctors = E.from $ \user -> do
|
||||||
|
let isCorrector = E.exists . E.from $ \sheetCorrector ->
|
||||||
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||||
|
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId
|
||||||
|
isLecturer' = E.exists . E.from $ \lecturer ->
|
||||||
|
E.where_ $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||||
|
E.&&. lecturer E.^. LecturerCourse E.==. E.val cId
|
||||||
|
E.where_ $ isCorrector E.||. isLecturer'
|
||||||
|
return user
|
||||||
|
wopt (selectField' (Just $ SomeMessage MsgSubmissionNoCorrector) $ userOptionsE correctors) (fslI MsgSubmissionCorrector & setTooltip MsgSubmissionCorrectorTip) (Just submissionRatingBy)
|
||||||
|
validateCorr = do
|
||||||
|
(now, ratingBy', rated, ratingPoints', ratingComment') <- State.get
|
||||||
|
mapM_ tellValidationError $ validateRating sheetType Rating'
|
||||||
|
{ ratingPoints = ratingPoints'
|
||||||
|
, ratingComment = ratingComment'
|
||||||
|
, ratingTime = guardOn rated now
|
||||||
|
}
|
||||||
|
guardValidation MsgSubmissionCannotBeRatedWithoutCorrector $ isn't _Nothing ratingBy' || not rated
|
||||||
|
|
||||||
|
((corrResult, corrForm'), corrEncoding) <- runFormPost . validateForm validateCorr . identifyForm FIDcorrection . renderAForm FormStandard $ (,,,,)
|
||||||
|
<$> wFormToAForm (pure <$> liftIO getCurrentTime)
|
||||||
|
<*> correctorForm
|
||||||
|
<*> apopt checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..})
|
||||||
|
<*> pointsForm
|
||||||
|
<*> aopt (textareaField & isoField _Wrapped & cfStrip) (fslI MsgRatingComment) (Just submissionRatingComment)
|
||||||
|
let corrForm = wrapForm' BtnSave corrForm' def
|
||||||
|
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||||
|
, formEncoding = corrEncoding
|
||||||
|
}
|
||||||
|
|
||||||
|
((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
|
||||||
|
apopt (zipFileField True Nothing) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing
|
||||||
|
let uploadForm = wrapForm uploadForm' def
|
||||||
|
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||||
|
, formEncoding = uploadEncoding
|
||||||
|
}
|
||||||
|
|
||||||
|
formResult corrResult $ \(now, ratingBy', rated, ratingPoints', ratingComment') -> do
|
||||||
|
runDBJobs $ do
|
||||||
|
update sub [ SubmissionRatingBy =. ratingBy'
|
||||||
|
, SubmissionRatingTime =. (now <$ guard rated)
|
||||||
|
, SubmissionRatingPoints =. ratingPoints'
|
||||||
|
, SubmissionRatingComment =. ratingComment'
|
||||||
|
]
|
||||||
|
|
||||||
|
when (rated && is _Nothing submissionRatingTime) $ do
|
||||||
|
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
|
||||||
|
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
|
||||||
|
|
||||||
|
addMessageI Success $ if
|
||||||
|
| rated -> MsgRatingUpdated
|
||||||
|
| is _Nothing ratingComment'
|
||||||
|
, is _Nothing ratingPoints'
|
||||||
|
, is _Nothing ratingBy' -> MsgRatingDeleted
|
||||||
|
| is _Nothing ratingComment'
|
||||||
|
, is _Nothing ratingPoints' -> MsgCorrectorUpdated
|
||||||
|
| otherwise -> MsgRatingDraftUpdated
|
||||||
|
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||||
|
|
||||||
|
formResult uploadResult $ \fileUploads -> do
|
||||||
|
uid <- maybeAuthId
|
||||||
|
|
||||||
|
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
||||||
|
|
||||||
|
when (is _Just res) $ do
|
||||||
|
addMessageI Success MsgRatingFilesUpdated
|
||||||
|
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||||
|
|
||||||
|
let heading = MsgCorrectionHead tid ssh csh shn cid
|
||||||
|
headingWgt = [whamlet|
|
||||||
|
$newline never
|
||||||
|
_{heading}
|
||||||
|
$if not (submissionRatingDone subm)
|
||||||
|
\ ^{isVisibleWidget False}
|
||||||
|
|]
|
||||||
|
siteLayout headingWgt $ do
|
||||||
|
setTitleI heading
|
||||||
|
let userCorrection = $(widgetFile "correction-user")
|
||||||
|
$(widgetFile "correction")
|
||||||
|
_ -> notFound
|
||||||
|
|
||||||
|
|
||||||
|
getCorrectionUserR tid ssh csh shn cid = do
|
||||||
|
sub <- decrypt cid
|
||||||
|
|
||||||
|
results <- runDB $ correctionData tid ssh csh shn sub
|
||||||
|
|
||||||
|
case results of
|
||||||
|
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] ->
|
||||||
|
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
||||||
|
in defaultLayout $(widgetFile "correction-user")
|
||||||
|
_ -> notFound
|
||||||
184
src/Handler/Submission/Create.hs
Normal file
184
src/Handler/Submission/Create.hs
Normal file
@ -0,0 +1,184 @@
|
|||||||
|
module Handler.Submission.Create
|
||||||
|
( getCorrectionsCreateR, postCorrectionsCreateR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import hiding (link)
|
||||||
|
-- import System.FilePath (takeFileName)
|
||||||
|
|
||||||
|
import Jobs
|
||||||
|
import Handler.Utils hiding (colSchool)
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Data.Map.Strict ((!))
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
import qualified Control.Monad.State.Class as State
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
import Data.List (genericLength)
|
||||||
|
|
||||||
|
|
||||||
|
getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
|
||||||
|
getCorrectionsCreateR = postCorrectionsCreateR
|
||||||
|
postCorrectionsCreateR = do
|
||||||
|
uid <- requireAuthId
|
||||||
|
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_
|
||||||
|
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
|
||||||
|
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||||
|
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_ $ isCorrector E.||. isLecturer
|
||||||
|
E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
|
||||||
|
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
|
||||||
|
MsgRenderer mr <- getMsgRenderer
|
||||||
|
return . mkOptionList $ do
|
||||||
|
(cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts'
|
||||||
|
let tid' = mr $ ShortTermIdentifier (unTermKey tid)
|
||||||
|
return Option
|
||||||
|
{ optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn
|
||||||
|
, optionInternalValue = sid
|
||||||
|
, optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet)
|
||||||
|
}
|
||||||
|
MsgRenderer mr <- getMsgRenderer
|
||||||
|
((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,)
|
||||||
|
<$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing
|
||||||
|
<*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing)
|
||||||
|
|
||||||
|
case pseudonymRes of
|
||||||
|
FormMissing -> return ()
|
||||||
|
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||||||
|
FormSuccess (sid, (pss, invalids)) -> do
|
||||||
|
allDone <- fmap getAll . execWriterT $ do
|
||||||
|
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
|
||||||
|
tell . All $ null invalids
|
||||||
|
|
||||||
|
WriterT . runDBJobs . mapReaderT (mapWriterT $ fmap ((,) <$> ((,) <$> view (_1 . _1) <*> view _2) <*> view (_1 . _2)) . runWriterT) $ do
|
||||||
|
Sheet{..} <- get404 sid :: ReaderT SqlBackend (WriterT (Set QueuedJobId) (WriterT All (HandlerFor UniWorX))) Sheet
|
||||||
|
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
|
||||||
|
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
|
||||||
|
lift . lift . tell . All $ null unknown
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
let
|
||||||
|
sps' :: [[SheetPseudonym]]
|
||||||
|
duplicate :: Set Pseudonym
|
||||||
|
( sps'
|
||||||
|
, Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
|
||||||
|
) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
|
||||||
|
known <- State.gets $ Map.member sheetPseudonymPseudonym
|
||||||
|
State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
|
||||||
|
return $ bool (p :) id known ps
|
||||||
|
submissionPrototype = Submission
|
||||||
|
{ submissionSheet = sid
|
||||||
|
, submissionRatingPoints = Nothing
|
||||||
|
, submissionRatingComment = Nothing
|
||||||
|
, submissionRatingBy = Just uid
|
||||||
|
, submissionRatingAssigned = Just now
|
||||||
|
, submissionRatingTime = Nothing
|
||||||
|
}
|
||||||
|
unless (null duplicate) $
|
||||||
|
addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates")
|
||||||
|
existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||||||
|
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||||||
|
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
|
||||||
|
E.&&. submission E.^. SubmissionSheet E.==. E.val sid
|
||||||
|
return submissionUser
|
||||||
|
unless (null existingSubUsers) . mapReaderT lift $ do
|
||||||
|
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: _ CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
|
||||||
|
let trigger = [whamlet|_{MsgSheetCreateExisting}|]
|
||||||
|
content = Right $(widgetFile "messages/submissionCreateExisting")
|
||||||
|
addMessageModal Warning trigger content
|
||||||
|
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
|
||||||
|
forM_ sps'' $ \spGroup
|
||||||
|
-> let
|
||||||
|
sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
|
||||||
|
in case sheetGrouping of
|
||||||
|
Arbitrary maxSize -> do
|
||||||
|
subId <- insert submissionPrototype
|
||||||
|
void . insert $ SubmissionEdit (Just uid) now subId
|
||||||
|
audit $ TransactionSubmissionEdit subId sid
|
||||||
|
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||||
|
{ submissionUserUser = sheetPseudonymUser
|
||||||
|
, submissionUserSubmission = subId
|
||||||
|
}
|
||||||
|
forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do
|
||||||
|
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId
|
||||||
|
audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser
|
||||||
|
when (genericLength spGroup > maxSize) $
|
||||||
|
addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
|
||||||
|
RegisteredGroups -> do
|
||||||
|
let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
|
||||||
|
groups <- E.select . E.from $ \submissionGroup -> do
|
||||||
|
E.where_ . E.exists . E.from $ \submissionGroupUser ->
|
||||||
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
|
||||||
|
return $ submissionGroup E.^. SubmissionGroupId
|
||||||
|
groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do
|
||||||
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups)
|
||||||
|
return $ submissionGroupUser E.^. SubmissionGroupUserUser
|
||||||
|
if
|
||||||
|
| [_] <- groups
|
||||||
|
, Map.keysSet spGroup' `Set.isSubsetOf` groupUsers
|
||||||
|
-> do
|
||||||
|
subId <- insert submissionPrototype
|
||||||
|
void . insert $ SubmissionEdit (Just uid) now subId
|
||||||
|
audit $ TransactionSubmissionEdit subId sid
|
||||||
|
insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
|
||||||
|
{ submissionUserUser = sheetUser
|
||||||
|
, submissionUserSubmission = subId
|
||||||
|
}
|
||||||
|
forM_ groupUsers $ \subUid -> do
|
||||||
|
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid subId
|
||||||
|
audit $ TransactionSubmissionUserEdit subId subUid
|
||||||
|
when (null groups) $
|
||||||
|
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
|
||||||
|
| length groups < 2
|
||||||
|
-> do
|
||||||
|
forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do
|
||||||
|
addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym)
|
||||||
|
lift . lift . tell $ All False
|
||||||
|
| otherwise ->
|
||||||
|
addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
|
||||||
|
NoGroups -> do
|
||||||
|
subId <- insert submissionPrototype
|
||||||
|
void . insert $ SubmissionEdit (Just uid) now subId
|
||||||
|
audit $ TransactionSubmissionEdit subId sid
|
||||||
|
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||||
|
{ submissionUserUser = sheetPseudonymUser
|
||||||
|
, submissionUserSubmission = subId
|
||||||
|
}
|
||||||
|
forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do
|
||||||
|
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId
|
||||||
|
audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser
|
||||||
|
when (length spGroup > 1) $
|
||||||
|
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
|
||||||
|
when allDone $
|
||||||
|
redirect CorrectionsGradeR
|
||||||
|
|
||||||
|
let pseudonymForm = wrapForm pseudonymWidget def
|
||||||
|
{ formAction = Just $ SomeRoute CorrectionsCreateR
|
||||||
|
, formEncoding = pseudonymEncoding
|
||||||
|
}
|
||||||
|
|
||||||
|
siteLayoutMsg MsgCorrCreate $ do
|
||||||
|
setTitleI MsgCorrCreate
|
||||||
|
$(widgetFile "corrections-create")
|
||||||
|
where
|
||||||
|
partitionEithers' :: [[Either a b]] -> ([[b]], [a])
|
||||||
|
partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
|
||||||
|
|
||||||
|
textToList :: Textarea -> ([[Pseudonym]], Map (Text, Text) [Pseudonym])
|
||||||
|
textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . map Text.strip . Text.lines . unTextarea -> ws)
|
||||||
|
= runWriter . fmap (mapMaybe sequence) $ mapM (\ws' -> mapM (toPseudonym ws') ws') ws
|
||||||
|
where
|
||||||
|
toPseudonym w' w
|
||||||
|
| Just res <- w ^? _PseudonymText = return $ Just res
|
||||||
|
| otherwise = Nothing <$ tell (Map.singleton (Text.intercalate ", " w', w) $ w ^.. pseudonymFragments . _PseudonymWords)
|
||||||
@ -1,6 +1,7 @@
|
|||||||
module Handler.Submission.Download
|
module Handler.Submission.Download
|
||||||
( getSubDownloadR
|
( getSubDownloadR
|
||||||
, getSubArchiveR
|
, getSubArchiveR
|
||||||
|
, getCorrectionsDownloadR
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
@ -8,6 +9,8 @@ import Import
|
|||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Submission
|
import Handler.Utils.Submission
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
import qualified Data.Text.Encoding as Text
|
import qualified Data.Text.Encoding as Text
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
@ -69,3 +72,16 @@ getSubArchiveR tid ssh csh shn cID sfType = do
|
|||||||
maybe (return ()) (yieldM . ratingFile cID) rating
|
maybe (return ()) (yieldM . ratingFile cID) rating
|
||||||
|
|
||||||
serveSomeFiles archiveName source
|
serveSomeFiles archiveName source
|
||||||
|
|
||||||
|
|
||||||
|
getCorrectionsDownloadR :: Handler TypedContent
|
||||||
|
getCorrectionsDownloadR = do -- download all assigned and open submissions
|
||||||
|
uid <- requireAuthId
|
||||||
|
subs <- runDB $ selectKeysList
|
||||||
|
[ SubmissionRatingBy ==. Just uid
|
||||||
|
, SubmissionRatingTime ==. Nothing
|
||||||
|
] []
|
||||||
|
when (null subs) $ do
|
||||||
|
addMessageI Info MsgNoOpenSubmissions
|
||||||
|
redirect CorrectionsR
|
||||||
|
submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs
|
||||||
|
|||||||
90
src/Handler/Submission/Grade.hs
Normal file
90
src/Handler/Submission/Grade.hs
Normal file
@ -0,0 +1,90 @@
|
|||||||
|
module Handler.Submission.Grade
|
||||||
|
( getCorrectionsGradeR, postCorrectionsGradeR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import hiding (link)
|
||||||
|
|
||||||
|
import Handler.Utils hiding (colSchool)
|
||||||
|
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
import Data.List (genericLength)
|
||||||
|
|
||||||
|
import Handler.Submission.List
|
||||||
|
|
||||||
|
|
||||||
|
getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
|
||||||
|
getCorrectionsGradeR = postCorrectionsGradeR
|
||||||
|
postCorrectionsGradeR = do
|
||||||
|
uid <- requireAuthId
|
||||||
|
let whereClause = ratedBy uid
|
||||||
|
displayColumns = mconcat -- should match getSSubsR for consistent UX
|
||||||
|
[ -- dbRow,
|
||||||
|
colSchool
|
||||||
|
, colTerm
|
||||||
|
, colCourse
|
||||||
|
, colSheet
|
||||||
|
, colSMatrikel
|
||||||
|
, colSubmittors
|
||||||
|
, colSGroups
|
||||||
|
, colPseudonyms
|
||||||
|
, colSubmissionLink
|
||||||
|
, colRated
|
||||||
|
, colRatedField
|
||||||
|
, colPointsField
|
||||||
|
, colMaxPointsField
|
||||||
|
, colCommentField
|
||||||
|
] -- Continue here
|
||||||
|
filterUI = Just $ \mPrev -> mconcat
|
||||||
|
[ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)
|
||||||
|
, prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm)
|
||||||
|
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
|
||||||
|
, Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
|
||||||
|
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
||||||
|
, prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
|
||||||
|
, prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
|
||||||
|
, Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
|
||||||
|
]
|
||||||
|
courseOptions = runDB $ do
|
||||||
|
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
||||||
|
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
|
||||||
|
termOptions = runDB $ do
|
||||||
|
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
||||||
|
optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
|
||||||
|
schoolOptions = runDB $ do
|
||||||
|
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
||||||
|
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
||||||
|
psValidator = def
|
||||||
|
& restrictAnonymous
|
||||||
|
& restrictCorrector
|
||||||
|
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
|
||||||
|
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
||||||
|
|
||||||
|
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def
|
||||||
|
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
|
||||||
|
}
|
||||||
|
|
||||||
|
formResult tableRes $ \resMap -> do
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do
|
||||||
|
s@Submission{..} <- get404 subId
|
||||||
|
if
|
||||||
|
| submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s
|
||||||
|
-> do audit $ TransactionSubmissionEdit subId $ s ^. _submissionSheet
|
||||||
|
Just subId <$ update subId [ SubmissionRatingPoints =. mPoints
|
||||||
|
, SubmissionRatingComment =. mComment
|
||||||
|
, SubmissionRatingBy =. Just uid
|
||||||
|
, SubmissionRatingTime =. now <$ guard rated
|
||||||
|
]
|
||||||
|
| otherwise -> return Nothing
|
||||||
|
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
|
||||||
|
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
|
||||||
|
content = Right $(widgetFile "messages/correctionsUploaded")
|
||||||
|
unless (null subs') $ addMessageModal Success trigger content
|
||||||
|
redirect CorrectionsGradeR
|
||||||
|
|
||||||
|
siteLayoutMsg MsgCorrectionsGrade $ do
|
||||||
|
setTitleI MsgCorrectionsGrade
|
||||||
|
$(widgetFile "corrections-grade")
|
||||||
@ -1,60 +1,34 @@
|
|||||||
module Handler.Corrections
|
module Handler.Submission.List
|
||||||
( getCorrectionsR, postCorrectionsR
|
( getCorrectionsR, postCorrectionsR
|
||||||
, getCCorrectionsR, postCCorrectionsR
|
, getCCorrectionsR, postCCorrectionsR
|
||||||
, getSSubsR, postSSubsR
|
, getSSubsR, postSSubsR
|
||||||
, getCorrectionR, postCorrectionR
|
|
||||||
, getCorrectionsUploadR, postCorrectionsUploadR
|
|
||||||
, getCorrectionsCreateR, postCorrectionsCreateR
|
|
||||||
, getCorrectionsGradeR, postCorrectionsGradeR
|
|
||||||
, getCAssignR, postCAssignR
|
|
||||||
, getSAssignR, postSAssignR
|
|
||||||
, getCorrectionsDownloadR
|
|
||||||
, correctionsR'
|
, correctionsR'
|
||||||
|
, restrictAnonymous, restrictCorrector
|
||||||
, ratedBy, courseIs, sheetIs, userIs
|
, ratedBy, courseIs, sheetIs, userIs
|
||||||
, colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit
|
, colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups
|
||||||
, makeCorrectionsTable
|
, makeCorrectionsTable
|
||||||
|
, CorrectionTableData
|
||||||
, ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
|
, ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import hiding (link)
|
import Import hiding (link)
|
||||||
-- import System.FilePath (takeFileName)
|
|
||||||
|
|
||||||
import Jobs
|
|
||||||
import Handler.Utils hiding (colSchool)
|
import Handler.Utils hiding (colSchool)
|
||||||
import Handler.Utils.Corrections
|
|
||||||
import Handler.Utils.Submission
|
import Handler.Utils.Submission
|
||||||
import Handler.Utils.SheetType
|
import Handler.Utils.SheetType
|
||||||
import Handler.Utils.Delete
|
import Handler.Utils.Delete
|
||||||
-- import Handler.Utils.Zip
|
|
||||||
|
|
||||||
import Data.List as List (foldl, foldr)
|
import Data.List as List (foldr)
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Data.Map.Strict ((!))
|
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
|
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
import qualified Control.Monad.State.Class as State
|
|
||||||
|
|
||||||
-- import Data.Time
|
|
||||||
-- import Data.Function ((&))
|
|
||||||
--
|
|
||||||
-- import Colonnade hiding (fromMaybe, singleton, bool)
|
|
||||||
-- import Yesod.Colonnade
|
|
||||||
--
|
|
||||||
-- import qualified Data.UUID.Cryptographic as UUID
|
|
||||||
-- import qualified Data.Conduit.List as C
|
|
||||||
|
|
||||||
import Database.Esqueleto.Utils.TH
|
import Database.Esqueleto.Utils.TH
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
import qualified Database.Esqueleto.Utils as E
|
import qualified Database.Esqueleto.Utils as E
|
||||||
import qualified Database.Esqueleto.Internal.Language (From)
|
import qualified Database.Esqueleto.Internal.Language (From)
|
||||||
-- import qualified Database.Esqueleto.Internal.Sql as E
|
|
||||||
|
|
||||||
-- import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
|
||||||
|
|
||||||
-- import Network.Mime
|
|
||||||
|
|
||||||
import Text.Hamlet (ihamletFile)
|
import Text.Hamlet (ihamletFile)
|
||||||
|
|
||||||
@ -62,9 +36,6 @@ import Database.Persist.Sql (updateWhereCount)
|
|||||||
|
|
||||||
import Data.List (genericLength)
|
import Data.List (genericLength)
|
||||||
|
|
||||||
import qualified Data.Conduit.List as C
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
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))
|
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))
|
||||||
type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
|
type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
|
||||||
@ -108,8 +79,6 @@ userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOute
|
|||||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||||
E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- Columns
|
-- Columns
|
||||||
colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||||
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||||
@ -228,7 +197,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
|
|||||||
_other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
_other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
||||||
)
|
)
|
||||||
|
|
||||||
colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
|
colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
|
||||||
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
|
colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
|
||||||
|
|
||||||
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
||||||
@ -656,6 +625,7 @@ autoAssignAction shid = ( CorrAutoSetCorrector
|
|||||||
, pure $ CorrAutoSetCorrectorData shid
|
, pure $ CorrAutoSetCorrectorData shid
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
getCorrectionsR, postCorrectionsR :: Handler TypedContent
|
getCorrectionsR, postCorrectionsR :: Handler TypedContent
|
||||||
getCorrectionsR = postCorrectionsR
|
getCorrectionsR = postCorrectionsR
|
||||||
postCorrectionsR = do
|
postCorrectionsR = do
|
||||||
@ -772,644 +742,3 @@ postSSubsR tid ssh csh shn = do
|
|||||||
, autoAssignAction shid
|
, autoAssignAction shid
|
||||||
, deleteAction
|
, deleteAction
|
||||||
]
|
]
|
||||||
|
|
||||||
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
|
||||||
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
|
||||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
|
||||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
|
||||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
|
||||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
||||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
|
||||||
E.&&. submission E.^. SubmissionId E.==. E.val sub
|
|
||||||
return (course, sheet, submission, corrector)
|
|
||||||
|
|
||||||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
|
||||||
getCorrectionR tid ssh csh shn cid = do
|
|
||||||
mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
|
|
||||||
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
|
|
||||||
postCorrectionR tid ssh csh shn cid = do
|
|
||||||
sub <- decrypt cid
|
|
||||||
|
|
||||||
(results, isLecturer) <- runDB $ (,)
|
|
||||||
<$> correctionData tid ssh csh shn sub
|
|
||||||
<*> hasWriteAccessTo (CSheetR tid ssh csh shn SSubsR)
|
|
||||||
|
|
||||||
MsgRenderer mr <- getMsgRenderer
|
|
||||||
case results of
|
|
||||||
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
|
|
||||||
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
|
||||||
pointsForm = case sheetType of
|
|
||||||
NotGraded
|
|
||||||
-> pure Nothing
|
|
||||||
(preview _grading -> Just PassBinary)
|
|
||||||
-> Just <$> apopt (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) submissionRatingPoints
|
|
||||||
(preview _grading -> Just PassAlways)
|
|
||||||
-> Just <$> aforced (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) 1
|
|
||||||
_otherwise
|
|
||||||
-> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
|
|
||||||
(fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
|
|
||||||
(Just submissionRatingPoints)
|
|
||||||
correctorForm
|
|
||||||
| not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId
|
|
||||||
| otherwise = wFormToAForm $ do
|
|
||||||
let correctors = E.from $ \user -> do
|
|
||||||
let isCorrector = E.exists . E.from $ \sheetCorrector ->
|
|
||||||
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
|
||||||
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId
|
|
||||||
isLecturer' = E.exists . E.from $ \lecturer ->
|
|
||||||
E.where_ $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
|
||||||
E.&&. lecturer E.^. LecturerCourse E.==. E.val cId
|
|
||||||
E.where_ $ isCorrector E.||. isLecturer'
|
|
||||||
return user
|
|
||||||
wopt (selectField' (Just $ SomeMessage MsgSubmissionNoCorrector) $ userOptionsE correctors) (fslI MsgSubmissionCorrector & setTooltip MsgSubmissionCorrectorTip) (Just submissionRatingBy)
|
|
||||||
validateCorr = do
|
|
||||||
(now, ratingBy', rated, ratingPoints', ratingComment') <- State.get
|
|
||||||
mapM_ tellValidationError $ validateRating sheetType Rating'
|
|
||||||
{ ratingPoints = ratingPoints'
|
|
||||||
, ratingComment = ratingComment'
|
|
||||||
, ratingTime = guardOn rated now
|
|
||||||
}
|
|
||||||
guardValidation MsgSubmissionCannotBeRatedWithoutCorrector $ isn't _Nothing ratingBy' || not rated
|
|
||||||
|
|
||||||
((corrResult, corrForm'), corrEncoding) <- runFormPost . validateForm validateCorr . identifyForm FIDcorrection . renderAForm FormStandard $ (,,,,)
|
|
||||||
<$> wFormToAForm (pure <$> liftIO getCurrentTime)
|
|
||||||
<*> correctorForm
|
|
||||||
<*> apopt checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..})
|
|
||||||
<*> pointsForm
|
|
||||||
<*> aopt (textareaField & isoField _Wrapped & cfStrip) (fslI MsgRatingComment) (Just submissionRatingComment)
|
|
||||||
let corrForm = wrapForm' BtnSave corrForm' def
|
|
||||||
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
||||||
, formEncoding = corrEncoding
|
|
||||||
}
|
|
||||||
|
|
||||||
((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
|
|
||||||
apopt (zipFileField True Nothing) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing
|
|
||||||
let uploadForm = wrapForm uploadForm' def
|
|
||||||
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
||||||
, formEncoding = uploadEncoding
|
|
||||||
}
|
|
||||||
|
|
||||||
formResult corrResult $ \(now, ratingBy', rated, ratingPoints', ratingComment') -> do
|
|
||||||
runDBJobs $ do
|
|
||||||
update sub [ SubmissionRatingBy =. ratingBy'
|
|
||||||
, SubmissionRatingTime =. (now <$ guard rated)
|
|
||||||
, SubmissionRatingPoints =. ratingPoints'
|
|
||||||
, SubmissionRatingComment =. ratingComment'
|
|
||||||
]
|
|
||||||
|
|
||||||
when (rated && is _Nothing submissionRatingTime) $ do
|
|
||||||
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
|
|
||||||
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
|
|
||||||
|
|
||||||
addMessageI Success $ if
|
|
||||||
| rated -> MsgRatingUpdated
|
|
||||||
| is _Nothing ratingComment'
|
|
||||||
, is _Nothing ratingPoints'
|
|
||||||
, is _Nothing ratingBy' -> MsgRatingDeleted
|
|
||||||
| is _Nothing ratingComment'
|
|
||||||
, is _Nothing ratingPoints' -> MsgCorrectorUpdated
|
|
||||||
| otherwise -> MsgRatingDraftUpdated
|
|
||||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
||||||
|
|
||||||
formResult uploadResult $ \fileUploads -> do
|
|
||||||
uid <- maybeAuthId
|
|
||||||
|
|
||||||
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
|
||||||
|
|
||||||
when (is _Just res) $ do
|
|
||||||
addMessageI Success MsgRatingFilesUpdated
|
|
||||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
||||||
|
|
||||||
let heading = MsgCorrectionHead tid ssh csh shn cid
|
|
||||||
headingWgt = [whamlet|
|
|
||||||
$newline never
|
|
||||||
_{heading}
|
|
||||||
$if not (submissionRatingDone subm)
|
|
||||||
\ ^{isVisibleWidget False}
|
|
||||||
|]
|
|
||||||
siteLayout headingWgt $ do
|
|
||||||
setTitleI heading
|
|
||||||
let userCorrection = $(widgetFile "correction-user")
|
|
||||||
$(widgetFile "correction")
|
|
||||||
_ -> notFound
|
|
||||||
|
|
||||||
|
|
||||||
getCorrectionUserR tid ssh csh shn cid = do
|
|
||||||
sub <- decrypt cid
|
|
||||||
|
|
||||||
results <- runDB $ correctionData tid ssh csh shn sub
|
|
||||||
|
|
||||||
case results of
|
|
||||||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] ->
|
|
||||||
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
|
||||||
in defaultLayout $(widgetFile "correction-user")
|
|
||||||
_ -> notFound
|
|
||||||
|
|
||||||
|
|
||||||
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
|
||||||
getCorrectionsUploadR = postCorrectionsUploadR
|
|
||||||
postCorrectionsUploadR = do
|
|
||||||
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
|
|
||||||
areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing
|
|
||||||
|
|
||||||
case uploadRes of
|
|
||||||
FormMissing -> return ()
|
|
||||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
|
||||||
FormSuccess files -> do
|
|
||||||
uid <- requireAuthId
|
|
||||||
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkMultiSubmission uid True
|
|
||||||
case mbSubs of
|
|
||||||
Nothing -> return ()
|
|
||||||
(Just subs)
|
|
||||||
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
|
|
||||||
| otherwise -> do
|
|
||||||
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
|
|
||||||
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
|
|
||||||
content = Right $(widgetFile "messages/correctionsUploaded")
|
|
||||||
addMessageModal Success trigger content
|
|
||||||
|
|
||||||
let uploadForm = wrapForm upload def
|
|
||||||
{ formAction = Just $ SomeRoute CorrectionsUploadR
|
|
||||||
, formEncoding = uploadEncoding
|
|
||||||
}
|
|
||||||
|
|
||||||
maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings'
|
|
||||||
|
|
||||||
defaultLayout $ do
|
|
||||||
let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions")
|
|
||||||
$(widgetFile "corrections-upload")
|
|
||||||
|
|
||||||
getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
|
|
||||||
getCorrectionsCreateR = postCorrectionsCreateR
|
|
||||||
postCorrectionsCreateR = do
|
|
||||||
uid <- requireAuthId
|
|
||||||
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_
|
|
||||||
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
|
|
||||||
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
|
||||||
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_ $ isCorrector E.||. isLecturer
|
|
||||||
E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
|
|
||||||
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
|
|
||||||
MsgRenderer mr <- getMsgRenderer
|
|
||||||
return . mkOptionList $ do
|
|
||||||
(cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts'
|
|
||||||
let tid' = mr $ ShortTermIdentifier (unTermKey tid)
|
|
||||||
return Option
|
|
||||||
{ optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn
|
|
||||||
, optionInternalValue = sid
|
|
||||||
, optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet)
|
|
||||||
}
|
|
||||||
MsgRenderer mr <- getMsgRenderer
|
|
||||||
((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,)
|
|
||||||
<$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing
|
|
||||||
<*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing)
|
|
||||||
|
|
||||||
case pseudonymRes of
|
|
||||||
FormMissing -> return ()
|
|
||||||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
|
||||||
FormSuccess (sid, (pss, invalids)) -> do
|
|
||||||
allDone <- fmap getAll . execWriterT $ do
|
|
||||||
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
|
|
||||||
tell . All $ null invalids
|
|
||||||
|
|
||||||
WriterT . runDBJobs . mapReaderT (mapWriterT $ fmap ((,) <$> ((,) <$> view (_1 . _1) <*> view _2) <*> view (_1 . _2)) . runWriterT) $ do
|
|
||||||
Sheet{..} <- get404 sid :: ReaderT SqlBackend (WriterT (Set QueuedJobId) (WriterT All (HandlerFor UniWorX))) Sheet
|
|
||||||
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
|
|
||||||
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
|
|
||||||
lift . lift . tell . All $ null unknown
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
let
|
|
||||||
sps' :: [[SheetPseudonym]]
|
|
||||||
duplicate :: Set Pseudonym
|
|
||||||
( sps'
|
|
||||||
, Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
|
|
||||||
) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
|
|
||||||
known <- State.gets $ Map.member sheetPseudonymPseudonym
|
|
||||||
State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
|
|
||||||
return $ bool (p :) id known ps
|
|
||||||
submissionPrototype = Submission
|
|
||||||
{ submissionSheet = sid
|
|
||||||
, submissionRatingPoints = Nothing
|
|
||||||
, submissionRatingComment = Nothing
|
|
||||||
, submissionRatingBy = Just uid
|
|
||||||
, submissionRatingAssigned = Just now
|
|
||||||
, submissionRatingTime = Nothing
|
|
||||||
}
|
|
||||||
unless (null duplicate) $
|
|
||||||
addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates")
|
|
||||||
existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
|
||||||
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
|
||||||
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
|
|
||||||
E.&&. submission E.^. SubmissionSheet E.==. E.val sid
|
|
||||||
return submissionUser
|
|
||||||
unless (null existingSubUsers) . mapReaderT lift $ do
|
|
||||||
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: _ CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
|
|
||||||
let trigger = [whamlet|_{MsgSheetCreateExisting}|]
|
|
||||||
content = Right $(widgetFile "messages/submissionCreateExisting")
|
|
||||||
addMessageModal Warning trigger content
|
|
||||||
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
|
|
||||||
forM_ sps'' $ \spGroup
|
|
||||||
-> let
|
|
||||||
sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
|
|
||||||
in case sheetGrouping of
|
|
||||||
Arbitrary maxSize -> do
|
|
||||||
subId <- insert submissionPrototype
|
|
||||||
void . insert $ SubmissionEdit (Just uid) now subId
|
|
||||||
audit $ TransactionSubmissionEdit subId sid
|
|
||||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
|
||||||
{ submissionUserUser = sheetPseudonymUser
|
|
||||||
, submissionUserSubmission = subId
|
|
||||||
}
|
|
||||||
forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do
|
|
||||||
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId
|
|
||||||
audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser
|
|
||||||
when (genericLength spGroup > maxSize) $
|
|
||||||
addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
|
|
||||||
RegisteredGroups -> do
|
|
||||||
let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
|
|
||||||
groups <- E.select . E.from $ \submissionGroup -> do
|
|
||||||
E.where_ . E.exists . E.from $ \submissionGroupUser ->
|
|
||||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
|
|
||||||
return $ submissionGroup E.^. SubmissionGroupId
|
|
||||||
groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do
|
|
||||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups)
|
|
||||||
return $ submissionGroupUser E.^. SubmissionGroupUserUser
|
|
||||||
if
|
|
||||||
| [_] <- groups
|
|
||||||
, Map.keysSet spGroup' `Set.isSubsetOf` groupUsers
|
|
||||||
-> do
|
|
||||||
subId <- insert submissionPrototype
|
|
||||||
void . insert $ SubmissionEdit (Just uid) now subId
|
|
||||||
audit $ TransactionSubmissionEdit subId sid
|
|
||||||
insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
|
|
||||||
{ submissionUserUser = sheetUser
|
|
||||||
, submissionUserSubmission = subId
|
|
||||||
}
|
|
||||||
forM_ groupUsers $ \subUid -> do
|
|
||||||
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid subId
|
|
||||||
audit $ TransactionSubmissionUserEdit subId subUid
|
|
||||||
when (null groups) $
|
|
||||||
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
|
|
||||||
| length groups < 2
|
|
||||||
-> do
|
|
||||||
forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do
|
|
||||||
addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym)
|
|
||||||
lift . lift . tell $ All False
|
|
||||||
| otherwise ->
|
|
||||||
addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
|
|
||||||
NoGroups -> do
|
|
||||||
subId <- insert submissionPrototype
|
|
||||||
void . insert $ SubmissionEdit (Just uid) now subId
|
|
||||||
audit $ TransactionSubmissionEdit subId sid
|
|
||||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
|
||||||
{ submissionUserUser = sheetPseudonymUser
|
|
||||||
, submissionUserSubmission = subId
|
|
||||||
}
|
|
||||||
forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do
|
|
||||||
hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId
|
|
||||||
audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser
|
|
||||||
when (length spGroup > 1) $
|
|
||||||
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
|
|
||||||
when allDone $
|
|
||||||
redirect CorrectionsGradeR
|
|
||||||
|
|
||||||
let pseudonymForm = wrapForm pseudonymWidget def
|
|
||||||
{ formAction = Just $ SomeRoute CorrectionsCreateR
|
|
||||||
, formEncoding = pseudonymEncoding
|
|
||||||
}
|
|
||||||
|
|
||||||
siteLayoutMsg MsgCorrCreate $ do
|
|
||||||
setTitleI MsgCorrCreate
|
|
||||||
$(widgetFile "corrections-create")
|
|
||||||
where
|
|
||||||
partitionEithers' :: [[Either a b]] -> ([[b]], [a])
|
|
||||||
partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
|
|
||||||
|
|
||||||
textToList :: Textarea -> ([[Pseudonym]], Map (Text, Text) [Pseudonym])
|
|
||||||
textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . map Text.strip . Text.lines . unTextarea -> ws)
|
|
||||||
= runWriter . fmap (mapMaybe sequence) $ mapM (\ws' -> mapM (toPseudonym ws') ws') ws
|
|
||||||
where
|
|
||||||
toPseudonym w' w
|
|
||||||
| Just res <- w ^? _PseudonymText = return $ Just res
|
|
||||||
| otherwise = Nothing <$ tell (Map.singleton (Text.intercalate ", " w', w) $ w ^.. pseudonymFragments . _PseudonymWords)
|
|
||||||
|
|
||||||
getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
|
|
||||||
getCorrectionsGradeR = postCorrectionsGradeR
|
|
||||||
postCorrectionsGradeR = do
|
|
||||||
uid <- requireAuthId
|
|
||||||
let whereClause = ratedBy uid
|
|
||||||
displayColumns = mconcat -- should match getSSubsR for consistent UX
|
|
||||||
[ -- dbRow,
|
|
||||||
colSchool
|
|
||||||
, colTerm
|
|
||||||
, colCourse
|
|
||||||
, colSheet
|
|
||||||
, colSMatrikel
|
|
||||||
, colSubmittors
|
|
||||||
, colSGroups
|
|
||||||
, colPseudonyms
|
|
||||||
, colSubmissionLink
|
|
||||||
, colRated
|
|
||||||
, colRatedField
|
|
||||||
, colPointsField
|
|
||||||
, colMaxPointsField
|
|
||||||
, colCommentField
|
|
||||||
] -- Continue here
|
|
||||||
filterUI = Just $ \mPrev -> mconcat
|
|
||||||
[ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)
|
|
||||||
, prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm)
|
|
||||||
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
|
|
||||||
, Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
|
|
||||||
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
|
||||||
, prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
|
|
||||||
, prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
|
|
||||||
, Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
|
|
||||||
]
|
|
||||||
courseOptions = runDB $ do
|
|
||||||
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
||||||
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
|
|
||||||
termOptions = runDB $ do
|
|
||||||
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
||||||
optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
|
|
||||||
schoolOptions = runDB $ do
|
|
||||||
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
|
||||||
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
|
||||||
psValidator = def
|
|
||||||
& restrictAnonymous
|
|
||||||
& restrictCorrector
|
|
||||||
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
|
|
||||||
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
|
||||||
|
|
||||||
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def
|
|
||||||
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
|
|
||||||
}
|
|
||||||
|
|
||||||
formResult tableRes $ \resMap -> do
|
|
||||||
now <- liftIO getCurrentTime
|
|
||||||
subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do
|
|
||||||
s@Submission{..} <- get404 subId
|
|
||||||
if
|
|
||||||
| submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s
|
|
||||||
-> do audit $ TransactionSubmissionEdit subId $ s ^. _submissionSheet
|
|
||||||
Just subId <$ update subId [ SubmissionRatingPoints =. mPoints
|
|
||||||
, SubmissionRatingComment =. mComment
|
|
||||||
, SubmissionRatingBy =. Just uid
|
|
||||||
, SubmissionRatingTime =. now <$ guard rated
|
|
||||||
]
|
|
||||||
| otherwise -> return Nothing
|
|
||||||
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
|
|
||||||
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
|
|
||||||
content = Right $(widgetFile "messages/correctionsUploaded")
|
|
||||||
unless (null subs') $ addMessageModal Success trigger content
|
|
||||||
redirect CorrectionsGradeR
|
|
||||||
|
|
||||||
siteLayoutMsg MsgCorrectionsGrade $ do
|
|
||||||
setTitleI MsgCorrectionsGrade
|
|
||||||
$(widgetFile "corrections-grade")
|
|
||||||
|
|
||||||
|
|
||||||
data ButtonSubmissionsAssign = BtnSubmissionsAssign
|
|
||||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
||||||
instance Universe ButtonSubmissionsAssign
|
|
||||||
instance Finite ButtonSubmissionsAssign
|
|
||||||
nullaryPathPiece ''ButtonSubmissionsAssign camelToPathPiece
|
|
||||||
embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
|
|
||||||
instance Button UniWorX ButtonSubmissionsAssign where
|
|
||||||
btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
|
|
||||||
|
|
||||||
getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
||||||
getCAssignR = postCAssignR
|
|
||||||
postCAssignR tid ssh csh = do
|
|
||||||
cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
||||||
assignHandler tid ssh csh cid []
|
|
||||||
|
|
||||||
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
||||||
getSAssignR = postSAssignR
|
|
||||||
postSAssignR tid ssh csh shn = do
|
|
||||||
(shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn
|
|
||||||
assignHandler tid ssh csh cid [shid]
|
|
||||||
|
|
||||||
{- TODO: Feature:
|
|
||||||
make distivt buttons for each sheet, so that users see which sheet will be assigned.
|
|
||||||
Currently this information is available within the page heading!
|
|
||||||
|
|
||||||
Stub:
|
|
||||||
data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName
|
|
||||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
||||||
instance Button UniWorX ButtonCorrectionsAssign
|
|
||||||
-- Are those needed any more?
|
|
||||||
instance Universe ButtonCorrectionsAssign
|
|
||||||
instance Finite ButtonCorrectionsAssign
|
|
||||||
nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece
|
|
||||||
embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id
|
|
||||||
instance Button UniWorX ButtonCorrectionsAssign where
|
|
||||||
btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary]
|
|
||||||
-- use runButtonForm' instead later on
|
|
||||||
-}
|
|
||||||
|
|
||||||
assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html
|
|
||||||
assignHandler tid ssh csh cid assignSids = do
|
|
||||||
-- evaluate form first, since it affects DB action
|
|
||||||
(btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions
|
|
||||||
|
|
||||||
-- gather data
|
|
||||||
(orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
|
|
||||||
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
||||||
nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
|
|
||||||
|
|
||||||
sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
|
|
||||||
let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList
|
|
||||||
sheets = entities2map sheetList
|
|
||||||
sheetIds = Map.keys sheets
|
|
||||||
groupsPossible :: Bool
|
|
||||||
groupsPossible =
|
|
||||||
let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups
|
|
||||||
in List.foldr foldFun False sheetList
|
|
||||||
assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids
|
|
||||||
|
|
||||||
-- plan or assign unassigned submissions for given sheets
|
|
||||||
let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational))
|
|
||||||
buildA acc sid = maybeT (return acc) $ do
|
|
||||||
let shn = sheetName $ sheets ! sid
|
|
||||||
-- is sheet closed?
|
|
||||||
guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable
|
|
||||||
-- ask for assignment plan
|
|
||||||
let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections
|
|
||||||
ignoreExceptions NoCorrectors = return mempty
|
|
||||||
ignoreExceptions NoCorrectorsByProportion = return mempty
|
|
||||||
ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing
|
|
||||||
(plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
|
|
||||||
guard $ not $ null plan -- only proceed if there is a plan for this sheet
|
|
||||||
-- implement assignment plan
|
|
||||||
status <- lift $ case btnResult of
|
|
||||||
Nothing -> return (Set.empty, Set.empty)
|
|
||||||
(Just BtnSubmissionsAssign) -> do
|
|
||||||
status@(sub_ok,sub_fail) <- writeSubmissionPlan plan
|
|
||||||
let nr_ok = olength sub_ok
|
|
||||||
nr_fail = olength sub_fail
|
|
||||||
alert_ok = toMaybe (nr_ok > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok
|
|
||||||
alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed nr_fail
|
|
||||||
msg_status = bool Success Error $ nr_fail > 0
|
|
||||||
msg_header = SomeMessage $ shn <> ":"
|
|
||||||
when (nr_ok > 0 || nr_fail > 0) $
|
|
||||||
addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail]
|
|
||||||
return status
|
|
||||||
return $ Map.insert shn (status, countMapElems plan, deficit) acc
|
|
||||||
assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts
|
|
||||||
then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
|
|
||||||
else return assignSids
|
|
||||||
assignment <- foldM buildA Map.empty assignSids'
|
|
||||||
|
|
||||||
correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do
|
|
||||||
E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
|
||||||
E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
|
|
||||||
return (corrector, user)
|
|
||||||
let correctorMap' :: Map UserId (User, Map SheetName SheetCorrector)
|
|
||||||
correctorMap' = (\f -> foldl f Map.empty correctors)
|
|
||||||
(\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
|
|
||||||
let shn = sheetName $ sheets ! sheetCorrectorSheet
|
|
||||||
in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc
|
|
||||||
)
|
|
||||||
-- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names
|
|
||||||
act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do
|
|
||||||
E.on $ submission E.^. SubmissionRatingBy E.==. (E.just $ user E.^. UserId)
|
|
||||||
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
|
|
||||||
return (submission E.^. SubmissionSheet, user)
|
|
||||||
let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
|
|
||||||
correctorMap = (\f -> foldl f correctorMap' act_correctors)
|
|
||||||
(\acc (E.Value sheetCorrectorSheet, Entity uid user) ->
|
|
||||||
let shn = sheetName $ sheets ! sheetCorrectorSheet
|
|
||||||
scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused
|
|
||||||
in Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged
|
|
||||||
)
|
|
||||||
|
|
||||||
submissions <- E.select . E.from $ \submission -> do
|
|
||||||
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
|
|
||||||
let numSubmittors = E.subSelectCount . E.from $ \subUser ->
|
|
||||||
E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
|
|
||||||
return (submission, numSubmittors)
|
|
||||||
-- prepare map
|
|
||||||
let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
|
|
||||||
infoMap = List.foldl (flip buildS) emptySheets submissions
|
|
||||||
|
|
||||||
-- ensure that all sheets are shown, including those without any submissions
|
|
||||||
emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds
|
|
||||||
emptyCorrs = foldl (\m uid -> let cic = Just uid in
|
|
||||||
Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap
|
|
||||||
|
|
||||||
|
|
||||||
buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo)
|
|
||||||
buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m =
|
|
||||||
let shnm = sheetName $ sheets ! submissionSheet
|
|
||||||
corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned
|
|
||||||
cinf = Map.singleton submissionRatingBy $ CorrectionInfo
|
|
||||||
{ ciSubmittors = fromIntegral nrSbmtrs
|
|
||||||
, ciSubmissions = 1
|
|
||||||
, ciAssigned = maybe 0 (const 1) submissionRatingBy -- only used in sheetMap
|
|
||||||
, ciCorrected = maybe 0 (const 1) submissionRatingTime
|
|
||||||
, ciCorrector = submissionRatingBy
|
|
||||||
, ciMin = corTime
|
|
||||||
, ciTot = corTime
|
|
||||||
, ciMax = corTime
|
|
||||||
}
|
|
||||||
in Map.insertWith (Map.unionWith (<>)) shnm cinf m
|
|
||||||
|
|
||||||
return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
|
|
||||||
|
|
||||||
let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
|
|
||||||
-- create aggregate maps
|
|
||||||
|
|
||||||
-- Always iterate over orderedSheetNames for consistent sorting!
|
|
||||||
sheetMap :: Map SheetName CorrectionInfo
|
|
||||||
sheetMap = Map.map fold infoMap
|
|
||||||
|
|
||||||
sheetLoad :: Map SheetName Load
|
|
||||||
sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap)
|
|
||||||
let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc
|
|
||||||
buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal}
|
|
||||||
= Map.insertWith (<>) s l acc
|
|
||||||
buildL acc _ _ = acc
|
|
||||||
in Map.foldl buildSL Map.empty correctorMap
|
|
||||||
|
|
||||||
deficitMap :: Map UserId Rational
|
|
||||||
deficitMap = foldMap (view _3) assignment
|
|
||||||
|
|
||||||
corrMap :: Map (Maybe UserId) CorrectionInfo
|
|
||||||
corrMap = Map.unionsWith (<>) $ Map.elems infoMap
|
|
||||||
|
|
||||||
corrInfos :: [CorrectionInfo]
|
|
||||||
corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap
|
|
||||||
where byName Nothing = Nothing
|
|
||||||
byName (Just uid) = Map.lookup uid correctorMap
|
|
||||||
corrMapSum :: CorrectionInfo
|
|
||||||
corrMapSum = fold corrMap
|
|
||||||
|
|
||||||
let -- whamlet convenience functions
|
|
||||||
-- avoid nestes hamlet $maybe with duplicated $nothing
|
|
||||||
getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text)
|
|
||||||
getCorrector (Just uid)
|
|
||||||
| Just (User{..},loadMap) <- Map.lookup uid correctorMap
|
|
||||||
= (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName)
|
|
||||||
-- | Just (User{..} ) <- Map.lookup uid lecturerNames
|
|
||||||
-- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases
|
|
||||||
getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty)
|
|
||||||
-- avoid nestes hamlet $maybe with duplicated $nothing
|
|
||||||
getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo
|
|
||||||
getCorrSheetStatus corr shn
|
|
||||||
| (Just smap) <- Map.lookup shn infoMap
|
|
||||||
= Map.lookup corr smap
|
|
||||||
getCorrSheetStatus _ _ = Nothing
|
|
||||||
-- avoid nestes hamlet $maybe with duplicated $nothing
|
|
||||||
getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int
|
|
||||||
getCorrNewAssignment corr shn
|
|
||||||
| (Just (_,cass,_)) <- Map.lookup shn assignment
|
|
||||||
= Map.lookup corr cass
|
|
||||||
getCorrNewAssignment _ _ = Nothing
|
|
||||||
-- avoid nestes hamlet $maybe with duplicated $nothing
|
|
||||||
getCorrDeficit :: Maybe UserId -> Maybe Rational
|
|
||||||
getCorrDeficit (Just uid) = Map.lookup uid deficitMap
|
|
||||||
getCorrDeficit _ = Nothing
|
|
||||||
|
|
||||||
getLoadSum :: SheetName -> Text
|
|
||||||
getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad
|
|
||||||
= showCompactCorrectorLoad load CorrectorNormal
|
|
||||||
getLoadSum _ = mempty
|
|
||||||
|
|
||||||
showDiffDays :: Maybe NominalDiffTime -> Text
|
|
||||||
showDiffDays = foldMap formatDiffDays
|
|
||||||
showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
|
|
||||||
showAvgsDays Nothing _ = mempty
|
|
||||||
showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
|
|
||||||
let headingShort
|
|
||||||
| 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
|
|
||||||
| otherwise = MsgMenuCorrectionsAssign
|
|
||||||
headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
|
|
||||||
|
|
||||||
unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames
|
|
||||||
unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets
|
|
||||||
|
|
||||||
siteLayoutMsg headingShort $ do
|
|
||||||
setTitleI headingLong
|
|
||||||
$(widgetFile "corrections-overview")
|
|
||||||
|
|
||||||
getCorrectionsDownloadR :: Handler TypedContent
|
|
||||||
getCorrectionsDownloadR = do -- download all assigned and open submissions
|
|
||||||
uid <- requireAuthId
|
|
||||||
subs <- runDB $ selectKeysList
|
|
||||||
[ SubmissionRatingBy ==. Just uid
|
|
||||||
, SubmissionRatingTime ==. Nothing
|
|
||||||
] []
|
|
||||||
when (null subs) $ do
|
|
||||||
addMessageI Info MsgNoOpenSubmissions
|
|
||||||
redirect CorrectionsR
|
|
||||||
submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs
|
|
||||||
50
src/Handler/Submission/Upload.hs
Normal file
50
src/Handler/Submission/Upload.hs
Normal file
@ -0,0 +1,50 @@
|
|||||||
|
module Handler.Submission.Upload
|
||||||
|
( getCorrectionsUploadR, postCorrectionsUploadR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import hiding (link)
|
||||||
|
-- import System.FilePath (takeFileName)
|
||||||
|
|
||||||
|
import Jobs
|
||||||
|
import Handler.Utils hiding (colSchool)
|
||||||
|
import Handler.Utils.Submission
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
import Data.List (genericLength)
|
||||||
|
|
||||||
|
import qualified Data.Conduit.List as C
|
||||||
|
|
||||||
|
|
||||||
|
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
||||||
|
getCorrectionsUploadR = postCorrectionsUploadR
|
||||||
|
postCorrectionsUploadR = do
|
||||||
|
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
|
||||||
|
areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing
|
||||||
|
|
||||||
|
case uploadRes of
|
||||||
|
FormMissing -> return ()
|
||||||
|
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||||
|
FormSuccess files -> do
|
||||||
|
uid <- requireAuthId
|
||||||
|
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkMultiSubmission uid True
|
||||||
|
case mbSubs of
|
||||||
|
Nothing -> return ()
|
||||||
|
(Just subs)
|
||||||
|
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
|
||||||
|
| otherwise -> do
|
||||||
|
subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
|
||||||
|
let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
|
||||||
|
content = Right $(widgetFile "messages/correctionsUploaded")
|
||||||
|
addMessageModal Success trigger content
|
||||||
|
|
||||||
|
let uploadForm = wrapForm upload def
|
||||||
|
{ formAction = Just $ SomeRoute CorrectionsUploadR
|
||||||
|
, formEncoding = uploadEncoding
|
||||||
|
}
|
||||||
|
|
||||||
|
maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings'
|
||||||
|
|
||||||
|
defaultLayout $ do
|
||||||
|
let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions")
|
||||||
|
$(widgetFile "corrections-upload")
|
||||||
Reference in New Issue
Block a user