Merge branch 'master' into http-client-html-helpers
This commit is contained in:
Felix Hamann
commit
b66ed42548
@ -1,3 +1,7 @@
|
||||
* Version 20.05.2019
|
||||
|
||||
Komplett überarbeitete Funktionalität zur automatischen Verteilung von Korrekturen
|
||||
|
||||
* Version 13.05.2019
|
||||
|
||||
Kursverwalter können Teilnehmer hinzufügen
|
||||
|
||||
@ -394,6 +394,10 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den
|
||||
CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
|
||||
SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
|
||||
|
||||
AssignSubmissionExceptionNoCorrectors: Es sind keine Korrektoren eingestellt
|
||||
AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit Anteil ungleich Null eingestellt
|
||||
AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden
|
||||
|
||||
|
||||
CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
|
||||
NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
|
||||
@ -521,6 +525,7 @@ UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden au
|
||||
|
||||
UploadModeExtensionRestriction: Zulässige Dateiendungen
|
||||
UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
|
||||
UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein
|
||||
|
||||
UploadSpecificFiles: Vorgegebene Dateinamen
|
||||
NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden.
|
||||
|
||||
@ -11,6 +11,7 @@ Tutorial json
|
||||
deregisterUntil UTCTime Maybe
|
||||
lastChanged UTCTime default=now()
|
||||
UniqueTutorial course name
|
||||
deriving Generic
|
||||
Tutor
|
||||
tutorial TutorialId
|
||||
user UserId
|
||||
|
||||
@ -243,6 +243,7 @@ tests:
|
||||
- uniworx
|
||||
- hspec >=2.0.0
|
||||
- QuickCheck
|
||||
- HUnit
|
||||
- yesod-test
|
||||
- conduit-extra
|
||||
- quickcheck-classes
|
||||
|
||||
@ -432,7 +432,18 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
redirect currentRoute
|
||||
FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
let
|
||||
assignExceptions :: AssignSubmissionException -> Handler ()
|
||||
assignExceptions NoCorrectors = addMessageI Error MsgAssignSubmissionExceptionNoCorrectors
|
||||
assignExceptions NoCorrectorsByProportion = addMessageI Error MsgAssignSubmissionExceptionNoCorrectorsByProportion
|
||||
assignExceptions (SubmissionsNotFound subIds) = do
|
||||
subCIDs <- mapM encrypt . Set.toList $ toNullable subIds :: Handler [CryptoFileNameSubmission]
|
||||
let errorModal = msgModal
|
||||
[whamlet|_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}|]
|
||||
(Right $(widgetFile "messages/submissionsAssignNotFound"))
|
||||
addMessageWidget Error errorModal
|
||||
|
||||
handle assignExceptions . runDB $ do
|
||||
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
|
||||
unless (null alreadyAssigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
|
||||
@ -359,15 +359,15 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
|
||||
, ( UploadModeAny
|
||||
, UploadAny
|
||||
<$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips)
|
||||
<*> apreq extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
|
||||
<*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
|
||||
)
|
||||
, ( UploadModeSpecific
|
||||
, UploadSpecific <$> specificFileForm
|
||||
)
|
||||
]
|
||||
|
||||
extensionRestrictionField :: Field Handler (Maybe (NonNull (Set Extension)))
|
||||
extensionRestrictionField = convertField (fromNullable . toSet) (maybe "" $ intercalate ", " . Set.toList . toNullable) textField
|
||||
extensionRestrictionField :: Field Handler (NonNull (Set Extension))
|
||||
extensionRestrictionField = checkMMap (return . maybe (Left MsgUploadModeExtensionRestrictionEmpty) Right . fromNullable . toSet) (intercalate ", " . Set.toList . toNullable) textField
|
||||
where
|
||||
toSet = Set.fromList . filter (not . Text.null) . map (stripDot . Text.strip) . Text.splitOn ","
|
||||
stripDot ext
|
||||
|
||||
@ -13,27 +13,25 @@ module Handler.Utils.Submission
|
||||
|
||||
import Import hiding (joinPath)
|
||||
import Jobs.Queue
|
||||
import Prelude (lcm)
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Control.Monad.State hiding (forM_, mapM_,foldM)
|
||||
import Control.Monad.State as State (StateT)
|
||||
import Control.Monad.State.Class as State
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter)
|
||||
import Control.Monad.RWS.Lazy (RWST)
|
||||
import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST)
|
||||
import qualified Control.Monad.Random as Rand
|
||||
import qualified System.Random.Shuffle as Rand (shuffleM)
|
||||
|
||||
import Data.Maybe ()
|
||||
|
||||
import qualified Data.List as List
|
||||
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.Ratio
|
||||
|
||||
import Data.Monoid (Monoid, Any(..), Sum(..))
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
@ -56,155 +54,178 @@ import Text.Hamlet (ihamletFile)
|
||||
import qualified Control.Monad.Catch as E (Handler(..))
|
||||
|
||||
|
||||
data AssignSubmissionException = NoCorrectorsByProportion
|
||||
deriving (Typeable, Show)
|
||||
data AssignSubmissionException = NoCorrectors
|
||||
| NoCorrectorsByProportion
|
||||
| SubmissionsNotFound (NonNull (Set SubmissionId))
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Exception AssignSubmissionException
|
||||
|
||||
-- | Assigns all submissions according to sheet corrector loads
|
||||
assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
|
||||
assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors
|
||||
-> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
|
||||
-> YesodDB UniWorX ( Set SubmissionId
|
||||
, Set SubmissionId
|
||||
) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
|
||||
assignSubmissions sid restriction = do
|
||||
Sheet{..} <- getJust sid
|
||||
correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
|
||||
let
|
||||
-- byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
|
||||
corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
|
||||
corrsProp = filter hasPositiveLoad correctors
|
||||
countsToLoad' :: UserId -> Bool
|
||||
countsToLoad' uid = Map.findWithDefault True uid loadMap
|
||||
loadMap :: Map UserId Bool
|
||||
loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]
|
||||
|
||||
currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor') -> do
|
||||
let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
-- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
|
||||
-- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
|
||||
E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial)
|
||||
E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial)
|
||||
E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser)
|
||||
E.where_ (tutor E.^. TutorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
|
||||
return $ tutor E.^. TutorUser
|
||||
E.on $ tutor' E.?. UserId `E.in_` E.justList tutors
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
|
||||
E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
|
||||
return (submission E.^. SubmissionId, tutor' E.?. UserId)
|
||||
|
||||
let subTutor' :: Map SubmissionId (Set UserId)
|
||||
subTutor' = Map.fromListWith Set.union $ currentSubs
|
||||
& mapped._2 %~ (maybe Set.empty Set.singleton . E.unValue)
|
||||
& mapped._1 %~ E.unValue
|
||||
|
||||
prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
|
||||
E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser)
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial)
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser
|
||||
E.where_ $ tutor E.^. TutorUser E.==. sheetCorrector E.^. SheetCorrectorUser
|
||||
E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission)
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse
|
||||
E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors)
|
||||
return (sheetCorrector, isByTutorial, E.isNothing (submission E.?. SubmissionId))
|
||||
correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.where_ $ sheetCorrector E.^. SheetCorrectorState `E.in_` E.valList [CorrectorNormal, CorrectorMissing]
|
||||
return (sheet E.^. SheetId, sheetCorrector)
|
||||
|
||||
let
|
||||
prevSubs' :: Map SheetId (Map UserId (Rational, Integer))
|
||||
prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do
|
||||
(Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs
|
||||
guard $ maybe True (not isByTutorial ||) byTutorial
|
||||
let proportion
|
||||
| CorrectorExcused <- sheetCorrectorState = 0
|
||||
| otherwise = byProportion
|
||||
return . Map.singleton sheetCorrectorSheet $ Map.singleton sheetCorrectorUser (proportion, bool 1 0 isPlaceholder)
|
||||
correctors :: Map SheetId (Map UserId (Load, CorrectorState))
|
||||
correctors = Map.fromList $ do
|
||||
E.Value sheetId <- Set.toList $ setOf (folded . _1) correctorsRaw
|
||||
let loads = Map.fromList $ do
|
||||
(E.Value sheetId', Entity _ SheetCorrector{..})
|
||||
<- correctorsRaw
|
||||
guard $ sheetId' == sheetId
|
||||
return (sheetCorrectorUser, (sheetCorrectorLoad, sheetCorrectorState))
|
||||
return (sheetId, loads)
|
||||
|
||||
deficit :: Map UserId Integer
|
||||
deficit = Map.filter (> 0) $ Map.foldr (Map.unionWith (+) . toDeficit) Map.empty prevSubs'
|
||||
|
||||
toDeficit :: Map UserId (Rational, Integer) -> Map UserId Integer
|
||||
toDeficit assignments = toDeficit' <$> assignments
|
||||
sheetCorrectors :: Map UserId Load
|
||||
sheetCorrectors = Map.mapMaybe filterLoad $ correctors ! sid
|
||||
where
|
||||
assigned' = getSum $ foldMap (Sum . snd) assignments
|
||||
props = getSum $ foldMap (Sum . fst) assignments
|
||||
filterLoad (l@Load{..}, CorrectorNormal) = l <$ guard (isJust byTutorial || byProportion /= 0)
|
||||
filterLoad _ = Nothing
|
||||
|
||||
toDeficit' (prop, assigned) = let
|
||||
target
|
||||
| props == 0 = 0
|
||||
| otherwise = round $ fromInteger assigned' * (prop / props)
|
||||
in target - assigned
|
||||
unless (Map.member sid correctors) $
|
||||
throwM NoCorrectors
|
||||
|
||||
$logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs'
|
||||
$logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit
|
||||
submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorial `E.InnerJoin` tutorialUser `E.InnerJoin` tutor)) -> do
|
||||
E.on $ tutor E.?. TutorTutorial E.==. tutorial E.?. TutorialId
|
||||
E.on $ tutorialUser E.?. TutorialParticipantTutorial E.==. tutorial E.?. TutorialId
|
||||
E.on $ tutorialUser E.?. TutorialParticipantUser E.==. E.just (submissionUser E.^. SubmissionUserUser)
|
||||
E.&&. tutor E.?. TutorUser `E.in_` E.justList (E.valList $ foldMap Map.keys correctors)
|
||||
E.&&. tutorial E.?. TutorialCourse E.==. E.just (E.val sheetCourse)
|
||||
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse
|
||||
|
||||
return (sheet E.^. SheetId, submission, tutor E.?. TutorUser)
|
||||
|
||||
let
|
||||
lcd :: Integer
|
||||
lcd = foldr lcm 1 $ map (denominator . byProportion . sheetCorrectorLoad . entityVal) corrsProp
|
||||
wholeProps :: Map UserId Integer
|
||||
wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ]
|
||||
detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit
|
||||
detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps
|
||||
-- | All submissions in this course so far
|
||||
submissionData :: Map SubmissionId
|
||||
( Maybe UserId -- Corrector
|
||||
, Map UserId (Sum Natural) -- Tutors
|
||||
, SheetId
|
||||
)
|
||||
submissionData = Map.fromListWith merge $ map process submissionDataRaw
|
||||
where
|
||||
process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) $ assertM isCorrectorByTutorial mTutId, sheetId))
|
||||
merge (corrA, tutorsA, sheetA) (corrB, tutorsB, sheetB)
|
||||
| corrA /= corrB = error "Same submission seen with different correctors"
|
||||
| sheetA /= sheetB = error "Same submission seen with different sheets"
|
||||
| otherwise = (corrA, Map.unionWith mappend tutorsA tutorsB, sheetA)
|
||||
|
||||
$logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue
|
||||
-- Not done in esqueleto, since inspection of `Load`-Values is difficult
|
||||
isCorrectorByTutorial = maybe False (\Load{..} -> is _Just byTutorial) . flip Map.lookup sheetCorrectors
|
||||
|
||||
queue <- liftIO . Rand.evalRandIO . execWriterT $ do
|
||||
tell $ map Just detQueue
|
||||
forever $
|
||||
tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ]
|
||||
targetSubmissions = Set.fromList $ do
|
||||
(E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw
|
||||
guard $ sheetId == sid
|
||||
case restriction of
|
||||
Just restriction' ->
|
||||
guard $ subId `Set.member` restriction'
|
||||
Nothing ->
|
||||
guard $ is _Nothing submissionRatingBy
|
||||
return subId
|
||||
|
||||
$logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue)
|
||||
targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions
|
||||
oldSubmissionData = Map.withoutKeys submissionData targetSubmissions
|
||||
|
||||
whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing ->
|
||||
throwM $ SubmissionsNotFound missing
|
||||
|
||||
let
|
||||
assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m ()
|
||||
assignSubmission countsToLoad smid tutid = do
|
||||
_1 %= Map.insert smid tutid
|
||||
_3 . at tutid %= assertM' (> 0) . maybe (-1) pred
|
||||
when countsToLoad $
|
||||
_2 %= List.delete (Just tutid)
|
||||
withSubmissionData :: MonadRWS (Map SubmissionId a) w (Map SubmissionId a) m
|
||||
=> (Map SubmissionId a -> b)
|
||||
-> m b
|
||||
withSubmissionData f = f <$> (mappend <$> ask <*> State.get)
|
||||
|
||||
-- | How many additional submission should the given corrector be assigned, if possible?
|
||||
calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
|
||||
calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet
|
||||
where
|
||||
sheetSizes :: Map SheetId Integer
|
||||
-- ^ Number of assigned submissions (to anyone) per sheet
|
||||
sheetSizes = Map.map getSum . Map.fromListWith mappend $ do
|
||||
(_, (Just _, _, sheetId)) <- Map.toList submissionState
|
||||
return (sheetId, Sum 1)
|
||||
|
||||
maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId)
|
||||
maximumDeficit = do
|
||||
transposed <- uses _3 invertMap
|
||||
traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed)
|
||||
deficitBySheet :: Map SheetId Rational
|
||||
-- ^ Deficite of @corrector@ per sheet
|
||||
deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do
|
||||
let assigned :: Rational
|
||||
assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState
|
||||
proportionSum :: Rational
|
||||
proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId
|
||||
where corrProportion (_, CorrectorExcused) = mempty
|
||||
corrProportion (Load{..}, _) = Sum byProportion
|
||||
extra
|
||||
| Just (Load{..}, corrState) <- correctors !? sheetId >>= Map.lookup corrector
|
||||
= sum
|
||||
[ assigned
|
||||
, fromMaybe 0 $ do -- If corrections assigned by tutorial do not count against proportion, substract them from deficit
|
||||
tutCounts <- byTutorial
|
||||
guard $ not tutCounts
|
||||
guard $ corrState /= CorrectorExcused
|
||||
return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState
|
||||
, fromMaybe 0 $ do
|
||||
guard $ corrState /= CorrectorExcused
|
||||
return . negate $ (byProportion / proportionSum) * fromIntegral sheetSize
|
||||
]
|
||||
| otherwise
|
||||
= assigned
|
||||
return $ negate extra
|
||||
|
||||
subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor'
|
||||
-- Sort target submissions by those that have tutors first and otherwise random
|
||||
--
|
||||
-- Deficit produced by restriction to tutors can thus be fixed by later submissions
|
||||
targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions
|
||||
|
||||
subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do
|
||||
let
|
||||
restrictTuts
|
||||
| Set.null tuts = id
|
||||
| otherwise = flip Map.restrictKeys tuts
|
||||
byDeficit <- withStateT (over _3 restrictTuts) maximumDeficit
|
||||
case byDeficit of
|
||||
Just q' -> do
|
||||
$logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)"
|
||||
assignSubmission False smid q'
|
||||
Nothing
|
||||
| Set.null tuts -> do
|
||||
q <- preuse $ _2 . _head . _Just
|
||||
case q of
|
||||
Just q' -> do
|
||||
$logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (queue)"
|
||||
assignSubmission True smid q'
|
||||
Nothing -> return ()
|
||||
| otherwise -> do
|
||||
q <- liftIO . Rand.evalRandIO $ Rand.uniform tuts
|
||||
$logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)"
|
||||
assignSubmission (countsToLoad' q) smid q
|
||||
(newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, subId) -> do
|
||||
tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural)
|
||||
let acceptableCorrectors
|
||||
| correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors
|
||||
, not $ null correctorsByTut
|
||||
= Map.keysSet correctorsByTut
|
||||
| otherwise
|
||||
= Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors
|
||||
|
||||
when (not $ null acceptableCorrectors) $ do
|
||||
deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit
|
||||
let
|
||||
bestCorrectors :: Set UserId
|
||||
bestCorrectors = acceptableCorrectors
|
||||
& maximumsBy (deficits !)
|
||||
& maximumsBy (tutors !?)
|
||||
|
||||
$logDebugS "assignSubmissions" [st|#{tshow i} Tutors for #{tshow subId}: #{tshow tutors}|]
|
||||
$logDebugS "assignSubmissions" [st|#{tshow i} Current (#{tshow subId}) relevant deficits: #{tshow deficits}|]
|
||||
$logDebugS "assignSubmissions" [st|#{tshow i} Assigning #{tshow subId} to one of #{tshow bestCorrectors}|]
|
||||
|
||||
ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
forM_ (Map.toList subTutor) $
|
||||
\(smid, tutid) -> update smid [ SubmissionRatingBy =. Just tutid
|
||||
, SubmissionRatingAssigned =. Just now ]
|
||||
execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, (mCorrector, _, _)) -> case mCorrector of
|
||||
Just corrector -> do
|
||||
lift $ update subId [ SubmissionRatingBy =. Just corrector
|
||||
, SubmissionRatingAssigned =. Just now
|
||||
]
|
||||
tell (Set.singleton subId, mempty)
|
||||
Nothing ->
|
||||
tell (mempty, Set.singleton subId)
|
||||
where
|
||||
maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a
|
||||
maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs
|
||||
|
||||
let assignedSubmissions = Map.keysSet subTutor
|
||||
unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
|
||||
return (assignedSubmissions, unassigendSubmissions)
|
||||
where
|
||||
hasPositiveLoad = (> 0) . byProportion . sheetCorrectorLoad . entityVal
|
||||
hasTutorialLoad = isJust . byTutorial . sheetCorrectorLoad . entityVal
|
||||
unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a]
|
||||
unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp
|
||||
|
||||
|
||||
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
||||
|
||||
@ -250,7 +250,9 @@ defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
|
||||
defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
{ constructorTagModifier = \c -> if
|
||||
| c == "UploadAny" -> "upload"
|
||||
| otherwise -> camelToPathPiece c
|
||||
, fieldLabelModifier = camelToPathPiece
|
||||
, sumEncoding = TaggedObject "mode" "settings"
|
||||
, omitNothingFields = True
|
||||
|
||||
@ -690,23 +690,32 @@ mforced Field{..} FieldSettings{..} val = do
|
||||
|
||||
aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> a -> AForm m a
|
||||
aforced field settings val = formToAForm $ second pure <$> mforced field settings val
|
||||
|
||||
apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> AForm m a
|
||||
-- ^ Pseudo required
|
||||
apreq f fs mx = formToAForm $ do
|
||||
mr <- getMessageRender
|
||||
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
|
||||
aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val
|
||||
|
||||
mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
|
||||
-- ^ Pseudo required
|
||||
--
|
||||
-- `FieldView` has `fvRequired` set to `True` and @FormSuccess Nothing@ is cast to `FormFailure`.
|
||||
-- Otherwise acts exactly like `mopt`.
|
||||
mpreq f fs mx = do
|
||||
mr <- getMessageRender
|
||||
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
|
||||
(res, fv) <- mopt f fs (Just <$> mx)
|
||||
let fv' = fv { fvRequired = True }
|
||||
return $ case res of
|
||||
FormSuccess (Just res')
|
||||
-> (FormSuccess res', fv')
|
||||
FormSuccess Nothing
|
||||
-> (FormFailure [mr MsgValueRequired], fv' { fvErrors = Just . toHtml $ mr MsgValueRequired })
|
||||
FormFailure errs
|
||||
-> (FormFailure errs, fv')
|
||||
FormMissing
|
||||
-> (FormMissing, fv')
|
||||
|
||||
apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> AForm m a
|
||||
apreq f fs mx = formToAForm $ over _2 pure <$> mpreq f fs mx
|
||||
|
||||
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
|
||||
wpreq f fs mx = mFormToWForm $ do
|
||||
mr <- getMessageRender
|
||||
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
|
||||
wpreq f fs mx = mFormToWForm $ mpreq f fs mx
|
||||
|
||||
@ -77,6 +77,8 @@ hasEntityUser = hasEntity
|
||||
|
||||
makeLenses_ ''SheetCorrector
|
||||
|
||||
makeLenses_ ''Load
|
||||
|
||||
makeLenses_ ''SubmissionGroup
|
||||
|
||||
makeLenses_ ''SheetGrading
|
||||
|
||||
4
templates/messages/submissionsAssignNotFound.hamlet
Normal file
4
templates/messages/submissionsAssignNotFound.hamlet
Normal file
@ -0,0 +1,4 @@
|
||||
<h2>_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}
|
||||
<ul>
|
||||
$forall cID <- subCIDs
|
||||
<li><pre>#{toPathPiece cID}
|
||||
@ -7,12 +7,6 @@ import ModelSpec ()
|
||||
import qualified Data.CryptoID as CID
|
||||
import Yesod.EmbeddedStatic
|
||||
|
||||
instance Arbitrary TermId where
|
||||
arbitrary = TermKey <$> arbitrary
|
||||
|
||||
instance Arbitrary SchoolId where
|
||||
arbitrary = SchoolKey <$> arbitrary
|
||||
|
||||
instance Arbitrary (Route Auth) where
|
||||
arbitrary = oneof
|
||||
[ return CheckR
|
||||
|
||||
192
test/Handler/Utils/SubmissionSpec.hs
Normal file
192
test/Handler/Utils/SubmissionSpec.hs
Normal file
@ -0,0 +1,192 @@
|
||||
module Handler.Utils.SubmissionSpec where
|
||||
|
||||
import qualified Yesod
|
||||
|
||||
import TestImport
|
||||
-- import qualified Test.HUnit.Base as HUnit
|
||||
|
||||
import Handler.Utils.Submission
|
||||
import ModelSpec ()
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.List (genericLength)
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import System.IO.Unsafe
|
||||
|
||||
import System.Random.Shuffle
|
||||
import Control.Monad.Random.Class
|
||||
|
||||
import Database.Persist.Sql (fromSqlKey)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
-- import Data.Maybe (fromJust)
|
||||
|
||||
|
||||
userNumber :: TVar Natural
|
||||
userNumber = unsafePerformIO $ newTVarIO 1
|
||||
{-# NOINLINE userNumber #-}
|
||||
|
||||
makeUsers :: Natural -> SqlPersistM [Entity User]
|
||||
makeUsers (fromIntegral -> n) = do
|
||||
users' <- liftIO . replicateM n $ generate arbitrary
|
||||
users <- forM users' $ \u -> do
|
||||
i <- atomically $ readTVar userNumber <* modifyTVar userNumber succ
|
||||
let u' = u { userIdent = CI.mk $ "user." <> tshow i
|
||||
, userEmail = CI.mk $ "user." <> tshow i <> "@example.com"
|
||||
}
|
||||
return u'
|
||||
uids <- insertMany users
|
||||
return $ zipWith Entity uids users
|
||||
|
||||
distributionExample :: SqlPersistM [(Natural, [Maybe Load])] -- ^ Number of submissions and corrector specification
|
||||
-> ([Entity Submission] -> [Entity SheetCorrector] -> SqlPersistM ()) -- ^ Setup hook
|
||||
-> (Map (Maybe SheetCorrector) (Set SubmissionId) -> Expectation)
|
||||
-> YesodExample UniWorX ()
|
||||
distributionExample mkParameters setupHook cont = do
|
||||
situations <- runDB $ do
|
||||
term <- liftIO $ generate arbitrary
|
||||
void . insert $ term
|
||||
school <- liftIO $ generate arbitrary
|
||||
void . insert $ school
|
||||
course <- liftIO $ generate arbitrary <&> \c -> c { courseTerm = TermKey $ termName term, courseSchool = SchoolKey $ schoolShorthand school }
|
||||
cid <- insert course
|
||||
|
||||
steps <- mkParameters
|
||||
let subsN = maybe 0 maximum . fromNullable $ map fst steps
|
||||
correctorsN = maybe 0 maximum . fromNullable $ map (genericLength . snd) steps
|
||||
participants <- makeUsers subsN
|
||||
correctors <- makeUsers correctorsN
|
||||
|
||||
situations <- forM (zip [1..] steps) $ \(i, (subsN', loads)) -> do
|
||||
sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetName = CI.mk $ "Sheet " <> tshow (i :: Integer), sheetCourse = cid }
|
||||
sid <- insert sheet
|
||||
|
||||
participants' <- liftIO $ take (fromIntegral subsN') <$> shuffleM participants
|
||||
let loads' = loads ++ replicate (fromIntegral $ correctorsN - genericLength loads) Nothing
|
||||
|
||||
submissions <- forM participants' $ \(Entity uid _) -> do
|
||||
sub@(Entity subId _) <- insertEntity $ Submission
|
||||
sid
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
void . insert $ SubmissionUser uid subId
|
||||
return sub
|
||||
|
||||
let sheetCorrectors = [ SheetCorrector corr sid load CorrectorNormal | (Entity corr _, Just load) <- zip correctors loads']
|
||||
scIds <- insertMany sheetCorrectors
|
||||
let sheetCorrectors' = zipWith Entity scIds sheetCorrectors
|
||||
|
||||
return (sid, (submissions, sheetCorrectors'))
|
||||
|
||||
mapM_ (uncurry setupHook) $ map snd situations
|
||||
|
||||
return situations
|
||||
|
||||
let subIds = concatMap (\(_, (subs, _)) -> map entityKey subs) situations
|
||||
|
||||
results <- runHandler . Yesod.runDB . mapM (\sid -> assignSubmissions sid Nothing) $ map fst situations
|
||||
|
||||
submissions <- fmap concat . forM results $ \(assigned, unassigned) -> runDB $ selectList ([ SubmissionId <-. Set.toList assigned ] ||. [ SubmissionId <-. Set.toList unassigned ]) []
|
||||
|
||||
liftIO $ do
|
||||
let (assigned, unassigned) = bimap concat concat $ unzip results
|
||||
Set.union assigned unassigned `shouldBe` Set.fromList subIds
|
||||
cont . Map.fromListWith mappend $ do
|
||||
Entity subId Submission{..} <- submissions
|
||||
let key = listToMaybe . filter (\(Entity _ (SheetCorrector uid _ _ _)) -> Just uid == submissionRatingBy) $ concatMap (\(_, (_, corrs)) -> corrs) situations
|
||||
return (entityVal <$> key, Set.singleton subId)
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = withApp . describe "Submission distribution" $ do
|
||||
it "is fair" $
|
||||
distributionExample
|
||||
(return [(500, replicate 10 (Just $ Load Nothing 1))])
|
||||
(\_ _ -> return ())
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult `shouldNotSatisfy` Map.member Nothing
|
||||
countResult `shouldSatisfy` all (== 50)
|
||||
)
|
||||
it "follows distribution" $
|
||||
distributionExample
|
||||
(return [(500, replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2))])
|
||||
(\_ _ -> return ())
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult `shouldNotSatisfy` Map.member Nothing
|
||||
countResult `shouldSatisfy` all (\(Just (SheetCorrector _ _ (Load _ prop) _), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList
|
||||
)
|
||||
it "follows cumulative distribution over multiple sheets" $ do
|
||||
ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100)
|
||||
let ns' = ns ++ [500 - sum ns]
|
||||
loads = replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2)
|
||||
distributionExample
|
||||
(return [ (n, loads) | n <- ns' ])
|
||||
(\_ _ -> return ())
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult
|
||||
countResult `shouldNotSatisfy` Map.member Nothing
|
||||
countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList
|
||||
)
|
||||
it "follows non-constant cumulative distribution over multiple sheets" $ do
|
||||
let ns = replicate 4 100
|
||||
loads = do
|
||||
(onesBefore, onesAfter) <- zip [0,2..6] [6,4..0]
|
||||
return $ replicate onesBefore (Just $ Load Nothing 1)
|
||||
++ replicate 2 (Just $ Load Nothing 2)
|
||||
++ replicate onesAfter (Just $ Load Nothing 1)
|
||||
distributionExample
|
||||
(return $ zip ns loads)
|
||||
(\_ _ -> return ())
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> fromSqlKey sheetCorrectorUser) countResult
|
||||
countResult `shouldNotSatisfy` Map.member Nothing
|
||||
countResult' `shouldSatisfy` all (\(Just _, subsSet) -> subsSet == 50) . Map.toList
|
||||
)
|
||||
it "handles tutorials with proportion" $ do
|
||||
ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100)
|
||||
let ns' = ns ++ [500 - sum ns]
|
||||
loads = replicate 6 (Just $ Load (Just True) 1) ++ replicate 2 (Just $ Load (Just True) 2)
|
||||
tutSubIds <- liftIO $ newTVarIO Map.empty
|
||||
distributionExample
|
||||
(return [ (n, loads) | n <- ns' ])
|
||||
(\subs corrs -> do
|
||||
tutSubmissions <- liftIO $ getRandomR (1,50)
|
||||
subs' <- liftIO $ shuffleM subs
|
||||
forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do
|
||||
Entity _ SheetCorrector{..} <- liftIO $ uniform corrs
|
||||
atomically . modifyTVar tutSubIds . Map.insertWith mappend sheetCorrectorUser $ Set.singleton subId
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
tut <- liftIO $ generate arbitrary <&> \c -> c { tutorialName = CI.mk $ "Tut for " <> tshow (fromSqlKey subId), tutorialCourse = sheetCourse }
|
||||
tutId <- insert tut
|
||||
void . insert $ Tutor tutId sheetCorrectorUser
|
||||
E.insertSelect . E.from $ \submissionUser -> do
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
|
||||
return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser)
|
||||
)
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult
|
||||
countResult' `shouldNotSatisfy` Map.member Nothing
|
||||
countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> fromIntegral subsSet == 50 * prop) . Map.toList
|
||||
|
||||
-- -- Does not currently work, because `User`s are reused within `distributionExample`, so submissions end up having more associated course-tutors, because the same user might be a member of a tutorial created for another submission
|
||||
--
|
||||
-- let subs = fold tutSubIds'
|
||||
-- forM_ subs $ \subId -> do
|
||||
-- let tutors = Map.keysSet $ Map.filter (Set.member subId) tutSubIds'
|
||||
-- assignedTo = Set.map (sheetCorrectorUser . fromJust) . Map.keysSet $ Map.filter (Set.member subId) result
|
||||
-- HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to multiple correctors") 1 $ Set.size assignedTo
|
||||
-- HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to non-tutors (" <> show (Set.map fromSqlKey tutors) <> ")") Set.empty (Set.map fromSqlKey $ assignedTo `Set.difference` tutors)
|
||||
)
|
||||
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model.TypesSpec where
|
||||
|
||||
import TestImport
|
||||
@ -12,7 +14,19 @@ import MailSpec ()
|
||||
import System.IO.Unsafe
|
||||
import Yesod.Auth.Util.PasswordStore
|
||||
|
||||
import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey)
|
||||
|
||||
import Text.Blaze.Html
|
||||
import Text.Blaze.Renderer.Text
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Time.Types (WeekDay(..))
|
||||
|
||||
|
||||
instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
|
||||
arbitrary = arbitrary `suchThatMap` fromNullable
|
||||
|
||||
instance Arbitrary Season where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
@ -24,6 +38,14 @@ instance Arbitrary TermIdentifier where
|
||||
return $ TermIdentifier{..}
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary TermId where
|
||||
arbitrary = TermKey <$> arbitrary
|
||||
shrink = map TermKey . shrink . unTermKey
|
||||
|
||||
instance Arbitrary SchoolId where
|
||||
arbitrary = SchoolKey <$> arbitrary
|
||||
shrink = map SchoolKey . shrink . unSchoolKey
|
||||
|
||||
instance Arbitrary Pseudonym where
|
||||
arbitrary = Pseudonym <$> arbitraryBoundedIntegral
|
||||
|
||||
@ -62,7 +84,24 @@ instance Arbitrary SubmissionFileType where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary UploadSpecificFile where
|
||||
arbitrary = UploadSpecificFile
|
||||
<$> (pack . getPrintableString <$> arbitrary)
|
||||
<*> (pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary UploadMode where
|
||||
arbitrary = oneof
|
||||
[ pure NoUpload
|
||||
, UploadAny
|
||||
<$> arbitrary
|
||||
<*> (fromNullable . Set.fromList . map (pack . getPrintableString) <$> arbitrary)
|
||||
, UploadSpecific <$> arbitrary
|
||||
]
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary UploadModeDescr where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -149,7 +188,26 @@ instance Arbitrary LecturerType where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary a => Arbitrary (ZIPArchiveName a) where
|
||||
instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key record) where
|
||||
arbitrary = toSqlKey <$> arbitrary
|
||||
shrink = map toSqlKey . shrink . fromSqlKey
|
||||
|
||||
instance Arbitrary Html where
|
||||
arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary
|
||||
shrink = map preEscapedToHtml . shrink . renderMarkup
|
||||
|
||||
instance Arbitrary WeekDay where
|
||||
arbitrary = oneof $ map pure [minBound..maxBound]
|
||||
|
||||
instance Arbitrary OccurenceSchedule where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary OccurenceException where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary Occurences where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -177,10 +235,14 @@ spec = do
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
|
||||
lawsCheckHspec (Proxy @SubmissionFileType)
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
|
||||
lawsCheckHspec (Proxy @UploadSpecificFile)
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @UploadMode)
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @UploadModeDescr)
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
|
||||
lawsCheckHspec (Proxy @SubmissionMode)
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, finiteLaws ]
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @SubmissionModeDescr)
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
|
||||
lawsCheckHspec (Proxy @ExamStatus)
|
||||
@ -215,8 +277,6 @@ spec = do
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @LecturerType)
|
||||
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @(ZIPArchiveName (CI Text)))
|
||||
[ eqLaws, ordLaws, showReadLaws, pathPieceLaws ]
|
||||
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
|
||||
@ -33,6 +33,42 @@ instance Arbitrary EmailAddress where
|
||||
isEmail l d = Email.isValid (makeEmailLike l d)
|
||||
makeEmailLike l d = CBS.concat [l, CBS.singleton '@', d]
|
||||
|
||||
instance Arbitrary Course where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary Sheet where
|
||||
arbitrary = Sheet
|
||||
<$> arbitrary
|
||||
<*> (CI.mk . pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary Tutorial where
|
||||
arbitrary = Tutorial
|
||||
<$> (CI.mk . pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> (CI.mk . pack . getPrintableString <$> arbitrary)
|
||||
<*> (fmap getPositive <$> arbitrary)
|
||||
<*> (pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary User where
|
||||
arbitrary = do
|
||||
userIdent <- CI.mk . pack <$> oneof
|
||||
|
||||
@ -6,7 +6,8 @@ module TestImport
|
||||
import Application (makeFoundation, makeLogWare)
|
||||
import ClassyPrelude as X hiding (delete, deleteBy, Handler, Index, (<.>), (<|), index, uncons, unsnoc, cons, snoc)
|
||||
import Database.Persist as X hiding (get)
|
||||
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool)
|
||||
import Database.Persist.Sql as X (SqlPersistM)
|
||||
import Database.Persist.Sql (runSqlPersistMPool)
|
||||
import Foundation as X
|
||||
import Model as X
|
||||
import Test.Hspec as X
|
||||
|
||||
Loading…
Reference in New Issue
Block a user