From 13cc4195c8c903e245e0b7c518101e380697b6d3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 14 Aug 2018 20:35:18 +0200 Subject: [PATCH 1/5] Fix database migrations for empty db Fixes #159 --- src/Model/Migration.hs | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 98652d070..30614eaae 100644 --- a/src/Model/Migration.hs +++ b/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}; |] - 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 () ) ] From ceb1191a28b4d1683a997e9dbe4d799716a91658 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 14 Aug 2018 20:35:45 +0200 Subject: [PATCH 2/5] Fix #117 --- messages/uniworx/de.msg | 1 + src/Handler/Utils/Form.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 411cdb696..2f7bda32d 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -253,6 +253,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} diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index f405a6dd7..0d5e5e9f8 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -344,7 +344,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 From 7686996214094a5519b7e2961a188b3b8e582680 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 16 Aug 2018 13:00:03 +0200 Subject: [PATCH 3/5] Cleanup --- src/Data/CaseInsensitive/Instances.hs | 56 +++++++++++++++++++++++++++ src/Model/Types.hs | 56 ++------------------------- 2 files changed, 59 insertions(+), 53 deletions(-) create mode 100644 src/Data/CaseInsensitive/Instances.hs diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs new file mode 100644 index 000000000..ea5253f44 --- /dev/null +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 21d89735e..f84c0cde0 100644 --- a/src/Model/Types.hs +++ b/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 = - 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,41 +349,6 @@ 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 - -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 - -- Type synonyms type SheetName = CI Text From 508ed2ecd94bd42679976de96deb274369ab65d8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 17 Aug 2018 16:57:57 +0200 Subject: [PATCH 4/5] More sophisticated submission distribution Fixes #77 --- db.hs | 4 +- messages/uniworx/de.msg | 5 ++ models | 1 + package.yaml | 1 + src/Foundation.hs | 15 ++++ src/Handler/Sheet.hs | 34 ++++---- src/Handler/Utils/Form.hs | 12 +++ src/Handler/Utils/Submission.hs | 139 +++++++++++++++++++++++++------- src/Model/Types.hs | 17 ++++ src/Utils.hs | 5 +- 10 files changed, 185 insertions(+), 48 deletions(-) diff --git a/db.hs b/db.hs index 54f0466f4..5cac10dfa 100755 --- a/db.hs +++ b/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" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2f7bda32d..202bde31c 100644 --- a/messages/uniworx/de.msg +++ b/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 @@ -264,3 +265,7 @@ SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe LDAPLoginTitle: Campus-Login DummyLoginTitle: Development-Login + +CorrectorNormal: Normal +CorrectorMissing: Abwesend +CorrectorExcused: Entschuldigt \ No newline at end of file diff --git a/models b/models index d146f2f5b..a0e82edcd 100644 --- a/models +++ b/models @@ -115,6 +115,7 @@ SheetCorrector user UserId sheet SheetId load Load + state CorrectorState default='Normal' UniqueSheetCorrector user sheet deriving Show Eq Ord SheetFile diff --git a/package.yaml b/package.yaml index 5cecac14d..b6d579e8d 100644 --- a/package.yaml +++ b/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. diff --git a/src/Foundation.hs b/src/Foundation.hs index e94b8950e..a17a74f1d 100644 --- a/src/Foundation.hs +++ b/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" diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c27ee142a..1335a25d0 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0d5e5e9f8..4ae07b06f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -377,6 +377,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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 097a505d8..2e866c46f 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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,126 @@ 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 =<< Rand.shuffleM 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 <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ (Map.toList 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] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index f84c0cde0..14bd4308a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -349,6 +349,23 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime deriving (Eq, Ord, Read, Show, Enum, Bounded) +data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused + deriving (Eq, Ord, Read, Show, Enum, Bounded) + +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Corrector" + } ''CorrectorState + +instance Universe CorrectorState where universe = universeDef +instance Finite CorrectorState + +instance PathPiece CorrectorState where + toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) + fromPathPiece = finiteFromPathPiece + +derivePersistField "CorrectorState" + + -- Type synonyms type SheetName = CI Text diff --git a/src/Utils.hs b/src/Utils.hs index ee0ffee23..67dfbdd18 100644 --- a/src/Utils.hs +++ b/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 -- ----------- From 32da6b5585b6f3f4255207f2f0723ce07d7594d5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 17 Aug 2018 17:03:29 +0200 Subject: [PATCH 5/5] Traverse submissions in random order --- src/Handler/Utils/Submission.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 2e866c46f..06f8ec024 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -166,7 +166,7 @@ assignSubmissions sid restriction = do $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue queue <- liftIO . Rand.evalRandIO . execWriterT $ do - tell . map Just =<< Rand.shuffleM detQueue + tell $ map Just detQueue forever $ tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ] @@ -184,8 +184,10 @@ assignSubmissions sid restriction = do 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_ (Map.toList subTutor') $ \(smid, tuts) -> do + subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do let restrictTuts | Set.null tuts = id