Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
SJost
commit
d153024e64
4
db.hs
4
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 gkleen sh1 (Load (Just True) 1)
|
||||
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"
|
||||
h103 <- insertFile "H10-3.hs"
|
||||
pdf10 <- insertFile "ProMo_Uebung10.pdf"
|
||||
|
||||
@ -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
|
||||
1
models
1
models
@ -115,6 +115,7 @@ SheetCorrector
|
||||
user UserId
|
||||
sheet SheetId
|
||||
load Load
|
||||
state CorrectorState default='Normal'
|
||||
UniqueSheetCorrector user sheet
|
||||
deriving Show Eq Ord
|
||||
SheetFile
|
||||
|
||||
@ -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.
|
||||
|
||||
56
src/Data/CaseInsensitive/Instances.hs
Normal file
56
src/Data/CaseInsensitive/Instances.hs
Normal file
@ -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
|
||||
@ -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"
|
||||
|
||||
@ -502,11 +502,11 @@ insertSheetFile' sid ftype fs = do
|
||||
data CorrectorForm = CorrectorForm
|
||||
{ cfUserId :: UserId
|
||||
, cfUserName :: Text
|
||||
, cfResult :: FormResult Load
|
||||
, cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
|
||||
, cfResult :: FormResult (CorrectorState, Load)
|
||||
, 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 = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
|
||||
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
|
||||
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 (uid, uname, Load{..}) = do
|
||||
constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
|
||||
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 = Load <$> tutRes' <*> propRes
|
||||
cfResult :: FormResult (CorrectorState, Load)
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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] []
|
||||
let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto
|
||||
let corrsProp = filter hasPositiveLoad correctors
|
||||
let countsToLoad' :: UserId -> Bool
|
||||
countsToLoad' uid = -- refactor by simply using Map.(!)
|
||||
fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $
|
||||
Map.lookup uid loadMap
|
||||
loadMap :: Map UserId Bool
|
||||
loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsGroup]
|
||||
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]
|
||||
|
||||
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, user) -- , listToMaybe tutors)
|
||||
return (submission E.^. SubmissionId, tutor)
|
||||
|
||||
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)
|
||||
subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs
|
||||
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) -> 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
|
||||
(smid, Just tutid) -> do
|
||||
let
|
||||
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
|
||||
_2 .= qs
|
||||
case q of
|
||||
Just q -> _1 %= Map.insert smid q
|
||||
Nothing -> return () -- NOTE: throwM NoCorrectorsByProportion
|
||||
|
||||
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)
|
||||
|
||||
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]
|
||||
|
||||
|
||||
@ -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}; |]
|
||||
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
|
||||
haveUserTable <- [sqlQQ| SELECT to_regclass('user'); |]
|
||||
|
||||
case haveUserTable :: [Maybe (Single Text)] of
|
||||
[Just _] -> do
|
||||
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
|
||||
ALTER TABLE "sheet" ALTER COLUMN "type" TYPE json USING "type"::json;
|
||||
ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json;
|
||||
|]
|
||||
, do -- Better JSON encoding
|
||||
haveSheetTable <- [sqlQQ| SELECT to_regclass('sheet'); |]
|
||||
|
||||
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 ()
|
||||
)
|
||||
]
|
||||
|
||||
@ -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 =
|
||||
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)
|
||||
partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
|
||||
|
||||
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
|
||||
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
|
||||
data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
|
||||
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"
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = fromJust . stripPrefix "Corrector"
|
||||
} ''CorrectorState
|
||||
|
||||
instance PersistFieldSql (CI String) where
|
||||
sqlType _ = SqlOther "citext"
|
||||
instance Universe CorrectorState where universe = universeDef
|
||||
instance Finite CorrectorState
|
||||
|
||||
instance ToJSON a => ToJSON (CI a) where
|
||||
toJSON = toJSON . CI.original
|
||||
instance PathPiece CorrectorState where
|
||||
toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
|
||||
parseJSON = fmap CI.mk . parseJSON
|
||||
derivePersistField "CorrectorState"
|
||||
|
||||
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
|
||||
|
||||
|
||||
@ -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 --
|
||||
-----------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user