Gregor Kleen
parent
32e6306cd5
commit
1941338075
@ -14,12 +14,13 @@ import Utils.Lens
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import Data.Map (Map, (!))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Data.Semigroup (Sum(..))
|
||||
import Data.Monoid (All(..))
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
@ -46,7 +47,8 @@ import Database.Persist.Sql (updateWhereCount)
|
||||
|
||||
import Data.List (genericLength)
|
||||
|
||||
import Control.Monad.Trans.Writer (WriterT(..), runWriter)
|
||||
import Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT)
|
||||
import Control.Monad.Trans.Reader (mapReaderT)
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
@ -668,81 +670,96 @@ postCorrectionsCreateR = do
|
||||
FormMissing -> return ()
|
||||
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
|
||||
FormSuccess (sid, (pss, invalids)) -> do
|
||||
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet")
|
||||
allDone <- fmap getAll . execWriterT $ do
|
||||
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
|
||||
tell . All $ null invalids
|
||||
|
||||
runDB $ do
|
||||
Sheet{..} <- get404 sid
|
||||
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
|
||||
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
|
||||
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)
|
||||
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
|
||||
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) $ do
|
||||
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
|
||||
$(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
|
||||
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 uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
WriterT . runDB . mapReaderT runWriterT $ do
|
||||
Sheet{..} <- get404 sid
|
||||
(sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
|
||||
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
|
||||
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
|
||||
}
|
||||
when (genericLength spGroup > maxSize) $
|
||||
addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
|
||||
RegisteredGroups -> do
|
||||
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
|
||||
if
|
||||
| length (groups :: [E.Value SubmissionGroupId]) < 2
|
||||
-> do
|
||||
subId <- insert submissionPrototype
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
when (null groups) $
|
||||
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
|
||||
| otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
|
||||
NoGroups -> do
|
||||
subId <- insert submissionPrototype
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
when (length spGroup > 1) $
|
||||
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
|
||||
redirect CorrectionsGradeR
|
||||
unless (null duplicate)
|
||||
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
|
||||
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 :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
|
||||
$(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
|
||||
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 uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
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 uid now subId
|
||||
insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
|
||||
{ submissionUserUser = sheetUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
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)
|
||||
tell $ All False
|
||||
| otherwise ->
|
||||
addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
|
||||
NoGroups -> do
|
||||
subId <- insert submissionPrototype
|
||||
void . insert $ SubmissionEdit uid now subId
|
||||
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
|
||||
{ submissionUserUser = sheetPseudonymUser
|
||||
, submissionUserSubmission = subId
|
||||
}
|
||||
when (length spGroup > 1) $
|
||||
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
|
||||
when allDone $
|
||||
redirect CorrectionsGradeR
|
||||
|
||||
|
||||
defaultLayout $
|
||||
|
||||
@ -24,6 +24,9 @@ import qualified Data.ByteString as BS
|
||||
|
||||
import Data.Time
|
||||
|
||||
import Utils.Lens (review)
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
|
||||
|
||||
data DBAction = DBClear
|
||||
| DBTruncate
|
||||
@ -151,7 +154,7 @@ fillDb = do
|
||||
, userMailLanguages = MailLanguages ["de"]
|
||||
, userNotificationSettings = def
|
||||
}
|
||||
void . insert $ User
|
||||
tinaTester <- insert $ User
|
||||
{ userIdent = "tester@campus.lmu.de"
|
||||
, userAuthentication = AuthLDAP
|
||||
, userMatrikelnummer = Just "999"
|
||||
@ -312,6 +315,7 @@ fillDb = do
|
||||
insert_ $ CourseEdit jost now pmo
|
||||
void . insert $ DegreeCourse pmo sdBsc sdInf
|
||||
void . insert $ Lecturer jost pmo
|
||||
void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester]
|
||||
sh1 <- insert Sheet
|
||||
{ sheetCourse = pmo
|
||||
, sheetName = "Blatt 1"
|
||||
@ -328,6 +332,10 @@ fillDb = do
|
||||
, sheetSolutionFrom = Nothing
|
||||
}
|
||||
void . insert $ SheetEdit jost now sh1
|
||||
forM_ [fhamann, maxMuster, tinaTester] $ \u -> do
|
||||
p <- liftIO getRandom
|
||||
$logDebug (review _PseudonymText p)
|
||||
void . insert $ SheetPseudonym sh1 p u
|
||||
void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal
|
||||
void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal
|
||||
h102 <- insertFile "H10-2.hs"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user