189 lines
11 KiB
Haskell
189 lines
11 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
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.Legacy 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 MsgSubmissionPseudonyms) & 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 MsgSubmissionCorrCreate $ do
|
|
setTitleI MsgSubmissionCorrCreate
|
|
$(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)
|