Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

db.hs

@@ -267,8 +267,8 @@ fillDb = do
     , sheetSolutionFrom = Nothing
     }
   void . insert $ SheetEdit jost now sh1
-  void . insert $ SheetCorrector jost sh1 (Load (Just True) 0)
+  void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal
-  void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1)
+  void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal
   h102 <- insertFile "H10-2.hs"
   h103 <- insertFile "H10-3.hs"
   pdf10 <- insertFile "ProMo_Uebung10.pdf"

messages/uniworx/de.msg

@@ -160,6 +160,7 @@ SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetN
 CountTutProp: Tutorien zählen gegen Proportion
 Corrector: Korrektor
 Correctors: Korrektoren
+CorState: Status
 CorByTut: Nach Tutorium
 CorProportion: Anteil
 DeleteRow: Zeile entfernen
@@ -253,6 +254,7 @@ DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern a
 
 InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
 AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren
+IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren
 
 LastEdits: Letzte Änderungen
 EditedBy name@Text time@Text: Durch #{name} um #{time}
@@ -263,3 +265,7 @@ SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe
 
 LDAPLoginTitle: Campus-Login
 DummyLoginTitle: Development-Login
+
+CorrectorNormal: Normal
+CorrectorMissing: Abwesend
+CorrectorExcused: Entschuldigt

models

@@ -115,6 +115,7 @@ SheetCorrector
     user            UserId
     sheet           SheetId
     load            Load
+    state           CorrectorState default='Normal'
     UniqueSheetCorrector user sheet
     deriving Show Eq Ord
 SheetFile

package.yaml

@@ -90,6 +90,7 @@ dependencies:
 - connection
 - universe
 - universe-base
+- random-shuffle
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Data/CaseInsensitive/Instances.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.CaseInsensitive.Instances
+  () where
+
+import ClassyPrelude.Yesod
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Database.Persist.Sql
+
+import Text.Blaze (ToMarkup(..))
+
+import Data.Text (Text)
+import qualified Data.Text.Encoding as Text
+
+
+instance PersistField (CI Text) where
+  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
+  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
+  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
+
+instance PersistField (CI String) where
+  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
+  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
+  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
+  
+instance PersistFieldSql (CI Text) where
+  sqlType _ = SqlOther "citext"
+
+instance PersistFieldSql (CI String) where
+  sqlType _ = SqlOther "citext"
+
+instance ToJSON a => ToJSON (CI a) where
+  toJSON = toJSON . CI.original
+
+instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
+  parseJSON = fmap CI.mk . parseJSON
+
+instance ToMessage a => ToMessage (CI a) where
+  toMessage = toMessage . CI.original
+
+instance ToMarkup a => ToMarkup (CI a) where
+  toMarkup = toMarkup . CI.original
+  preEscapedToMarkup = preEscapedToMarkup . CI.original
+
+instance ToWidget site a => ToWidget site (CI a) where
+  toWidget = toWidget . CI.original
+
+instance RenderMessage site a => RenderMessage site (CI a) where
+  renderMessage f ls msg = renderMessage f ls $ CI.original msg

src/Foundation.hs

@@ -196,6 +196,13 @@ instance RenderMessage UniWorX SheetFileType where
       SheetMarking  -> renderMessage' MsgSheetMarking
     where renderMessage' = renderMessage foundation ls
 
+instance RenderMessage UniWorX CorrectorState where
+  renderMessage foundation ls = \case
+      CorrectorNormal  -> renderMessage' MsgCorrectorNormal
+      CorrectorMissing -> renderMessage' MsgCorrectorMissing
+      CorrectorExcused -> renderMessage' MsgCorrectorExcused
+    where renderMessage' = renderMessage foundation ls
+
 instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
   renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
 
@@ -903,6 +910,14 @@ pageActions (CSheetR tid csh shn SShowR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (CSheetR tid csh shn SSubsR) =
+  [ PageActionPrime $ MenuItem
+      { menuItemLabel = "Korrektoren"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CSheetR tid csh shn SCorrR
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (CSubmissionR tid csh shn cid SubShowR) =
   [ PageActionPrime $ MenuItem
       { menuItemLabel = "Korrektur"

src/Handler/Sheet.hs

@@ -502,11 +502,11 @@ insertSheetFile' sid ftype fs = do
 data CorrectorForm = CorrectorForm
   { cfUserId :: UserId
   , cfUserName :: Text
-  , cfResult :: FormResult Load
+  , cfResult :: FormResult (CorrectorState, Load)
-  , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
+  , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
   }
 
-type Loads = Map UserId Load
+type Loads = Map UserId (CorrectorState, Load)
 
 defaultLoads :: SheetId -> DB Loads
 -- ^ Generate `Loads` in such a way that minimal editing is required
@@ -526,10 +526,10 @@ defaultLoads shid = do
     
     E.orderBy [E.desc creationTime]
   
-    return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad)
+    return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
   where
-    toMap :: [(E.Value UserId, E.Value Load)] -> Loads
+    toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
-    toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
+    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
 
 
 correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
@@ -544,19 +544,19 @@ correctorForm shid = do
   formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
   let
     currentLoads :: DB Loads
-    currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
+    currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
   (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
-  loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
+  loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
     | Map.null currentLoads'
     , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted)
-    | otherwise              -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
+    | otherwise              -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'
 
   deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
 
   let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
       didDelete = any (flip Set.member deletions) formCIDs
 
-  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
+  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
   let
     tutorField :: Field Handler [UserEmail]
     tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
@@ -586,7 +586,7 @@ correctorForm shid = do
       case mUid of
         Nothing  -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
         Just uid
-          | not (Map.member uid loads') -> return $ Map.insert uid mempty loads''
+          | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
           | otherwise                   -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
     FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
     _ -> return loads''
@@ -598,8 +598,8 @@ correctorForm shid = do
     return $ (user E.^. UserId, user E.^. UserDisplayName)
     
   let
-    constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm
+    constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
-    constructFields (uid, uname, Load{..}) = do
+    constructFields (uid, uname, (state, Load{..})) = do
       cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
       let
         fs name = ""
@@ -607,12 +607,13 @@ correctorForm shid = do
           }
         rationalField = convertField toRational fromRational doubleField
 
+      (stateRes, cfViewState) <- mreq (selectField $ optionsFinite id) (fs "state") (Just state)
       (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
       (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
       (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
       let
-        cfResult :: FormResult Load
+        cfResult :: FormResult (CorrectorState, Load)
-        cfResult = Load <$> tutRes' <*> propRes
+        cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
         tutRes'
           | FormSuccess True <- byTutRes  = Just <$> countTutRes
           | otherwise                     = Nothing <$ byTutRes
@@ -629,6 +630,7 @@ correctorForm shid = do
   let
     corrColonnade = mconcat
       [ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
+      , headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
       , headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
       , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
       , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
@@ -637,7 +639,7 @@ correctorForm shid = do
       | FormSuccess (Just es) <- addTutRes
       , not $ null es = FormMissing
       | didDelete = FormMissing
-      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
+      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
                                                   | CorrectorForm{..} <- corrData
                                                   ]
     idField CorrectorForm{..} = do

src/Handler/Utils/Form.hs

@@ -345,7 +345,7 @@ utcTimeField = Field
     readTime t =
       case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
         (Just (LTUUnique time _))     -> Right time
-        (Just (LTUNone time _))       -> Right time -- FIXME: Should this be an error, too?
+        (Just (LTUNone _ _))          -> Left MsgIllDefinedUTCTime
         (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
         Nothing -> Left MsgInvalidDateTimeFormat
 
@@ -378,6 +378,18 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
                  , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                  }) cPairs
 
+optionsFinite :: ( MonadHandler m, Finite a, RenderMessage site msg, HandlerSite m ~ site, PathPiece a )
+              => (a -> msg) -> m (OptionList a)
+optionsFinite toMsg = do
+  mr <- getMessageRender
+  let
+    mkOption a = Option
+      { optionDisplay       = mr $ toMsg a
+      , optionInternalValue = a
+      , optionExternalValue = toPathPiece a
+      }
+  return . mkOptionList $ mkOption <$> universeF
+
 mforced :: (site ~ HandlerSite m, MonadHandler m)
         => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
 mforced Field{..} FieldSettings{..} val = do

src/Handler/Utils/Submission.hs

@@ -25,6 +25,7 @@ module Handler.Utils.Submission
   ) where
 
 import Import hiding ((.=), joinPath)
+import Prelude (lcm)
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
 import Control.Lens
@@ -32,9 +33,10 @@ import Control.Lens.Extras (is)
 import Utils.Lens
 
 import Control.Monad.State hiding (forM_, mapM_,foldM)
-import Control.Monad.Writer (MonadWriter(..))
+import Control.Monad.Writer (MonadWriter(..), execWriterT)
 import Control.Monad.RWS.Lazy (RWST)
 import qualified Control.Monad.Random as Rand
+import qualified System.Random.Shuffle as Rand (shuffleM)
 
 import Data.Maybe
 
@@ -45,11 +47,12 @@ import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 
 import qualified Data.Text as Text
+import Data.Ratio
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
-import Data.Monoid (Monoid, Any(..))
+import Data.Monoid (Monoid, Any(..), Sum(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
 import Handler.Utils.Rating hiding (extractRatings)
@@ -84,46 +87,128 @@ assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
                                      , Set SubmissionId -- ^ unassigend submissions (no tutors by load)
                                      )
 assignSubmissions sid restriction = do
-    correctors <- selectList [SheetCorrectorSheet ==. sid] []
+    Sheet{..} <- getJust sid
-    let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto
+    correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
-    let corrsProp  = filter hasPositiveLoad correctors
+    let
-    let countsToLoad' :: UserId -> Bool
+      byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
-        countsToLoad' uid = -- refactor by simply using Map.(!)
+      corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
-          fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $
+      corrsProp  = filter hasPositiveLoad correctors
-          Map.lookup uid loadMap
+      countsToLoad' :: UserId -> Bool
-        loadMap :: Map UserId Bool
+      countsToLoad' uid = Map.findWithDefault True uid loadMap
-        loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsGroup]
+      loadMap :: Map UserId Bool
+      loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]
 
-    subs <- E.select . E.from $ \(submission `E.LeftOuterJoin` user) -> do
+    currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor) -> do
         let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> 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.==. tutorialUser E.^. TutorialUserTutorial)
                 E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
-                E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup))
+                E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
                 return $ tutorial E.^. TutorialTutor
-        E.on $ user E.?. UserId `E.in_` E.justList tutors
+        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)
-        E.orderBy [E.rand] -- randomize for fair tutor distribution
+        return (submission E.^. SubmissionId, tutor)
-        return (submission E.^. SubmissionId, user) -- , listToMaybe tutors)
 
-    queue <- liftIO . Rand.evalRandIO . sequence . repeat $ Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp]
+    let subTutor' :: Map SubmissionId (Set UserId)
+        subTutor' = Map.fromListWith Set.union $ currentSubs
+          & mapped._2 %~ maybe Set.empty Set.singleton
+          & mapped._2 %~ Set.mapMonotonic entityKey
+          & mapped._1 %~ E.unValue
 
-    let subTutor' :: Map SubmissionId (Maybe UserId)
+    prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
-        subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs
+        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) -> do
+              E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial
+              E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser
+              E.where_ $ tutorial E.^. TutorialTutor 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))
 
-    subTutor <- fmap fst . flip execStateT (Map.empty, queue) . forM_ (Map.toList subTutor') $ \case
+    let
-      (smid, Just tutid) -> do
+      prevSubs' :: Map SheetId (Map UserId (Rational, Integer))
+      prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do
+        (Entity _ sc@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)
+
+      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
+        where
+          assigned' = getSum $ foldMap (Sum . snd) assignments
+          props = getSum $ foldMap (Sum . fst) assignments
+
+          toDeficit' (prop, assigned) = let
+              target = round $ fromInteger assigned' * (prop / props)
+            in target - assigned
+
+    $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs'
+    $logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit
+
+    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
+    
+    $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue
+    
+    queue <- liftIO . Rand.evalRandIO . execWriterT $ do
+      tell $ map Just detQueue
+      forever $
+        tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ]
+
+    $logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue)
+
+    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
-        when (any ((== tutid) . sheetCorrectorUser . entityVal) corrsProp && countsToLoad' tutid) $
+        _3 . at tutid %= assertM' (> 0) . maybe (-1) pred
+        when countsToLoad $
           _2 %= List.delete (Just tutid)
-      (smid, Nothing) -> do
+
-        (q:qs) <- use _2
+      maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId)
-        _2 .= qs
+      maximumDeficit = do
-        case q of
+        transposed <- uses _3 invertMap 
-          Just q  -> _1 %= Map.insert smid q
+        traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed)
-          Nothing -> return () -- NOTE: throwM NoCorrectorsByProportion
+
+    subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor'
+          
+    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
 
     forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
         

src/Model/Migration.hs

@@ -79,16 +79,27 @@ customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend
 customMigrations = Map.fromListWith (>>)
   [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
     , do -- New theme format
-        userThemes <- [sqlQQ| SELECT @{UserId}, @{UserTheme} FROM ^{User}; |]
+        haveUserTable <- [sqlQQ| SELECT to_regclass('user'); |]
-        forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
+
-          Just v
+        case haveUserTable :: [Maybe (Single Text)] of
-            | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
+          [Just _] -> do
-          other -> error $ "Could not parse theme: " <> show other
+            userThemes <- [sqlQQ| SELECT 'id', 'theme' FROM 'user'; |]
+            forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
+              Just v
+                | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
+              other -> error $ "Could not parse theme: " <> show other
+          _other -> return ()
     )
   , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
-    , [executeQQ| -- Better JSON encoding
+    , do -- Better JSON encoding
-        ALTER TABLE "sheet" ALTER COLUMN "type" TYPE json USING "type"::json;
+        haveSheetTable <- [sqlQQ| SELECT to_regclass('sheet'); |]
-        ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json;
+
-      |]
+        case haveSheetTable :: [Maybe (Single Text)] of
+          [Just _] ->
+            [executeQQ|
+              ALTER TABLE 'sheet' ALTER COLUMN 'type' TYPE json USING 'type'::json;
+              ALTER TABLE 'sheet' ALTER COLUMN 'grouping' TYPE json USING 'grouping'::json;
+            |]
+          _other -> return ()
     )
   ]

src/Model/Types.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
 {-# LANGUAGE ViewPatterns #-}
 {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Model.Types where
 
@@ -18,6 +17,7 @@ import Control.Lens
 
 import Data.Set (Set)
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 import Data.Fixed
 import Data.Monoid (Sum(..))
 import Data.Maybe (fromJust)
@@ -35,11 +35,11 @@ import Web.HttpApiData
 
 import Data.Text (Text)
 import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lens as Text
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive.Instances ()
 
 import Yesod.Core.Dispatch (PathPiece(..))
 import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
@@ -49,10 +49,6 @@ import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault)
 import Data.Typeable (Typeable)
 
-import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..))
-import Text.Blaze (ToMarkup(..))
-import Yesod.Core.Widget (ToWidget(..))
-
 
 type Points = Centi
 
@@ -135,18 +131,7 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan
 -- partitionFileType' = groupMap
 
 partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
-partitionFileType fts =
+partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
-    let (se,sh,ss,sm) = foldl' switchft (Set.empty,Set.empty,Set.empty,Set.empty) fts
-    in \case  SheetExercise -> se
-              SheetHint     -> sh
-              SheetSolution -> ss
-              SheetMarking  -> sm
-  where
-    switchft :: Ord a => (Set a, Set a, Set a, Set a) -> (SheetFileType,a) -> (Set a, Set a, Set a, Set a)
-    switchft (se,sh,ss,sm) (SheetExercise,x) = (Set.insert x se, sh, ss, sm)
-    switchft (se,sh,ss,sm) (SheetHint    ,x) = (se, Set.insert x sh, ss, sm)
-    switchft (se,sh,ss,sm) (SheetSolution,x) = (se, sh, Set.insert x ss, sm)
-    switchft (se,sh,ss,sm) (SheetMarking ,x) = (se, sh, ss, Set.insert x sm)
 
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
@@ -364,40 +349,22 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
 
 
-instance PersistField (CI Text) where
+data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
-  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
-  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
-  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
 
-instance PersistField (CI String) where
+deriveJSON defaultOptions
-  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
+  { constructorTagModifier = fromJust . stripPrefix "Corrector"
-  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
+  } ''CorrectorState
-  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
-  
-instance PersistFieldSql (CI Text) where
-  sqlType _ = SqlOther "citext"
 
-instance PersistFieldSql (CI String) where
+instance Universe CorrectorState where universe = universeDef
-  sqlType _ = SqlOther "citext"
+instance Finite CorrectorState
 
-instance ToJSON a => ToJSON (CI a) where
+instance PathPiece CorrectorState where
-  toJSON = toJSON . CI.original
+  toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+  fromPathPiece = finiteFromPathPiece
 
-instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
+derivePersistField "CorrectorState"
-  parseJSON = fmap CI.mk . parseJSON
 
-instance ToMessage a => ToMessage (CI a) where
-  toMessage = toMessage . CI.original
-
-instance ToMarkup a => ToMarkup (CI a) where
-  toMarkup = toMarkup . CI.original
-  preEscapedToMarkup = preEscapedToMarkup . CI.original
-
-instance ToWidget site a => ToWidget site (CI a) where
-  toWidget = toWidget . CI.original
-
-instance RenderMessage site a => RenderMessage site (CI a) where
-  renderMessage f ls msg = renderMessage f ls $ CI.original msg
 
 -- Type synonyms
 

src/Utils.hs

@@ -15,9 +15,7 @@ module Utils
 import ClassyPrelude.Yesod
 
 -- import Data.Double.Conversion.Text -- faster implementation for textPercent?
-import Data.List (foldl)
 import Data.Foldable as Fold
-import qualified Data.Char as Char
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
@@ -199,6 +197,9 @@ groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]
 partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
 partMap = Map.fromListWith mappend
 
+invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
+invertMap = groupMap . map swap . Map.toList
+
 -----------
 -- Maybe --
 -----------