diff --git a/package.yaml b/package.yaml index d0fc06ae8..098fb0bec 100644 --- a/package.yaml +++ b/package.yaml @@ -185,7 +185,7 @@ ghc-options: - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures - -fno-max-relevant-binds - - -j2 + - -j3 when: - condition: flag(pedantic) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d32195c58..4a18d3b79 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -531,7 +531,7 @@ postCorrectionsR = do optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def - & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") & defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ] -- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN diff --git a/src/Model/Types.hs b/src/Model/Types.hs index aa1c91037..b812d529c 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -3,8 +3,13 @@ #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + + module Model.Types ( module Model.Types + , module Model.Types.Sheet + , module Model.Types.DateTime + , module Model.Types.Misc , module Numeric.Natural , module Mail , module Utils.DateTime @@ -12,86 +17,31 @@ module Model.Types ) where import ClassyPrelude -import Utils -import Control.Lens hiding (universe) -import Utils.Lens.TH - -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) -import Data.Universe -import Data.Universe.Helpers -import Data.Universe.TH import Data.UUID.Types (UUID) import qualified Data.UUID.Types as UUID - import Data.NonNull.Instances () -import Data.Default - -import Text.Read (readMaybe) - -import Database.Persist.TH hiding (derivePersistFieldJSON) -import Model.Types.JSON -import Database.Persist.Class -import Database.Persist.Sql - -import Web.HttpApiData -import Web.PathPieces - -import Text.Blaze (Markup) import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.Lens as Text - -import qualified Data.HashMap.Strict as HashMap - import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI import Data.CaseInsensitive.Instances () -import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson -import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value()) -import Data.Aeson.Types (toJSONKeyText) -import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON) - -import GHC.Generics (Generic) -import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Data.Typeable (Typeable) - import Data.Universe.Instances.Reverse () +import Yesod.Core.Dispatch (PathPiece(..)) import qualified Yesod.Auth.Util.PasswordStore as PWStore +import Web.PathPieces import Mail (MailLanguages(..)) import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..)) - import Numeric.Natural -import Data.Word.Word24 (Word24) -import Data.Bits -import Data.Ix -import Data.List (genericIndex, elemIndex) -import System.Random (Random(..)) -import Data.Data (Data) -import Model.Types.Wordlist -import Data.Text.Metrics (damerauLevenshtein) - -import Data.Binary (Binary) -import qualified Data.Binary as Binary - -import Time.Types (WeekDay(..)) -import Data.Time.LocalTime (LocalTime, TimeOfDay) - -import Data.Semigroup (Min(..)) -import Control.Monad.Trans.Writer (execWriter) -import Control.Monad.Writer.Class (MonadWriter(..)) +import Model.Types.Sheet +import Model.Types.DateTime +import Model.Types.Misc +---- +-- Just bringing together the different Model.Types submodules. instance PathPiece UUID where fromPathPiece = UUID.fromString . unpack @@ -102,885 +52,6 @@ instance {-# OVERLAPS #-} PathMultiPiece FilePath where toPathMultiPiece = Text.splitOn "/" . pack -type Count = Sum Integer -type Points = Centi - -toPoints :: Integral a => a -> Points -- deprecated -toPoints = fromIntegral - -pToI :: Points -> Integer -- deprecated -pToI = fromPoints - -fromPoints :: Integral a => Points -> a -- deprecated -fromPoints = round - -instance DisplayAble Points - -instance DisplayAble a => DisplayAble (Sum a) where - display (Sum x) = display x - -data SheetGrading - = Points { maxPoints :: Points } - | PassPoints { maxPoints, passingPoints :: Points } - | PassBinary -- non-zero means passed - deriving (Eq, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel - , sumEncoding = TaggedObject "type" "data" - } ''SheetGrading -derivePersistFieldJSON ''SheetGrading - -makeLenses_ ''SheetGrading - -_passingBound :: Fold SheetGrading (Either () Points) -_passingBound = folding passPts - where - passPts :: SheetGrading -> Maybe (Either () Points) - passPts (Points{}) = Nothing - passPts (PassPoints{passingPoints}) = Just $ Right passingPoints - passPts (PassBinary) = Just $ Left () - -gradingPassed :: SheetGrading -> Points -> Maybe Bool -gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound - where pBinary _ = pts /= 0 - pPoints b = pts >= b - - -data SheetGradeSummary = SheetGradeSummary - { numSheets :: Count -- Total number of sheets, includes all - , numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses - , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd - , sumSheetsPoints :: Sum Points -- Total of all points in all sheets - -- Marking dependend - , numMarked :: Count -- Number of already marked sheets - , numMarkedPasses :: Count -- Number of already marked sheets with passes - , numMarkedPoints :: Count -- Number of already marked sheets with points - , sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets - -- - , achievedPasses :: Count -- Achieved passes (within marked sheets) - , achievedPoints :: Sum Points -- Achieved points (within marked sheets) - } deriving (Generic, Read, Show, Eq) - -instance Monoid SheetGradeSummary where - mempty = memptydefault - mappend = mappenddefault - -instance Semigroup SheetGradeSummary where - (<>) = mappend -- TODO: remove for GHC > 8.4.x - -makeLenses_ ''SheetGradeSummary - -sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary -sheetGradeSum gr Nothing = mempty - { numSheets = 1 - , numSheetsPasses = bool mempty 1 $ has _passingBound gr - , numSheetsPoints = bool mempty 1 $ has _maxPoints gr - , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints - } -sheetGradeSum gr (Just p) = - let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing - in unmarked - { numMarked = numSheets - , numMarkedPasses = numSheetsPasses - , numMarkedPoints = numSheetsPoints - , sumMarkedPoints = sumSheetsPoints - , achievedPasses = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p - , achievedPoints = bool mempty (Sum p) $ has _maxPoints gr - } - - -data SheetType - = NotGraded - | Normal { grading :: SheetGrading } - | Bonus { grading :: SheetGrading } - | Informational { grading :: SheetGrading } - deriving (Eq, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - , fieldLabelModifier = camelToPathPiece - , sumEncoding = TaggedObject "type" "data" - } ''SheetType -derivePersistFieldJSON ''SheetType - -data SheetTypeSummary = SheetTypeSummary - { normalSummary - , bonusSummary - , informationalSummary :: SheetGradeSummary - , numNotGraded :: Count - } deriving (Generic, Read, Show, Eq) - -instance Monoid SheetTypeSummary where - mempty = memptydefault - mappend = mappenddefault - -instance Semigroup SheetTypeSummary where - (<>) = mappend -- TODO: remove for GHC > 8.4.x - -makeLenses_ ''SheetTypeSummary - -sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary -sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps } -sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps } -sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } -sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 } - -data SheetGroup - = Arbitrary { maxParticipants :: Natural } - | RegisteredGroups - | NoGroups - deriving (Show, Read, Eq, Generic) -deriveJSON defaultOptions ''SheetGroup -derivePersistFieldJSON ''SheetGroup - -makeLenses_ ''SheetGroup - -data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) -derivePersistField "SheetFileType" - -instance Universe SheetFileType where universe = universeDef -instance Finite SheetFileType - -instance PathPiece SheetFileType where - toPathPiece SheetExercise = "file" - toPathPiece SheetHint = "hint" - toPathPiece SheetSolution = "solution" - toPathPiece SheetMarking = "marking" - fromPathPiece = finiteFromPathPiece - -sheetFile2markup :: SheetFileType -> Markup -sheetFile2markup SheetExercise = iconQuestion -sheetFile2markup SheetHint = iconHint -sheetFile2markup SheetSolution = iconSolution -sheetFile2markup SheetMarking = iconMarking - --- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) -instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation - display SheetExercise = "Aufgabenstellung" - display SheetHint = "Hinweise" - display SheetSolution = "Musterlösung" - display SheetMarking = "Korrekturhinweise" - --- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a) --- partitionFileType' = groupMap - -partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a -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, Generic) - -instance Universe SubmissionFileType where universe = universeDef -instance Finite SubmissionFileType - -submissionFileTypeIsUpdate :: SubmissionFileType -> Bool -submissionFileTypeIsUpdate SubmissionOriginal = False -submissionFileTypeIsUpdate SubmissionCorrected = True - -isUpdateSubmissionFileType :: Bool -> SubmissionFileType -isUpdateSubmissionFileType False = SubmissionOriginal -isUpdateSubmissionFileType True = SubmissionCorrected - -instance PathPiece SubmissionFileType where - toPathPiece SubmissionOriginal = "original" - toPathPiece SubmissionCorrected = "corrected" - fromPathPiece = finiteFromPathPiece - -instance DisplayAble SubmissionFileType where - display SubmissionOriginal = "Abgabe" - display SubmissionCorrected = "Korrektur" - -{- -data DA = forall a . (DisplayAble a) => DA a - -instance DisplayAble DA where - display (DA x) = display x --} - - -data UploadMode = NoUpload | Upload { unpackZips :: Bool } - deriving (Show, Read, Eq, Ord, Generic) - -deriveFinite ''UploadMode - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - , fieldLabelModifier = camelToPathPiece - , sumEncoding = TaggedObject "mode" "settings" - }''UploadMode -derivePersistFieldJSON ''UploadMode - -instance PathPiece UploadMode where - toPathPiece = \case - NoUpload -> "no-upload" - Upload True -> "unpack" - Upload False -> "no-unpack" - fromPathPiece = finiteFromPathPiece - -data SubmissionMode = SubmissionMode - { submissionModeCorrector :: Bool - , submissionModeUser :: Maybe UploadMode - } - deriving (Show, Read, Eq, Ord, Generic) - -deriveFinite ''SubmissionMode - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 2 - } ''SubmissionMode -derivePersistFieldJSON ''SubmissionMode - -finitePathPiece ''SubmissionMode - [ "no-submissions" - , "no-upload" - , "no-unpack" - , "unpack" - , "correctors" - , "correctors+no-upload" - , "correctors+no-unpack" - , "correctors+unpack" - ] - -data SubmissionModeDescr = SubmissionModeNone - | SubmissionModeCorrector - | SubmissionModeUser - | SubmissionModeBoth - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe SubmissionModeDescr -instance Finite SubmissionModeDescr - -finitePathPiece ''SubmissionModeDescr - [ "no-submissions" - , "correctors" - , "users" - , "correctors+users" - ] - -classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr -classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone -classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector -classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser -classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth - - -data ExamStatus = Attended | NoShow | Voided - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) -derivePersistField "ExamStatus" - --- | Specify a corrector's workload -data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } - = Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload - , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders - } - deriving (Show, Read, Eq, Ord, Generic) - -deriveJSON defaultOptions ''Load -derivePersistFieldJSON ''Load - -instance Hashable Load - -instance Semigroup Load where - (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') - where - byTut'' - | Nothing <- byTut = byTut' - | Nothing <- byTut' = byTut - | Just a <- byTut - , Just b <- byTut' = Just $ a || b - -instance Monoid Load where - mempty = Load Nothing 0 - mappend = (<>) - -{- Use (is _ByTutorial) instead of this unneeded definition: - isByTutorial :: Load -> Bool - isByTutorial (ByTutorial {}) = True - isByTutorial _ = False --} - -data Season = Summer | Winter - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) - -instance Binary Season - -seasonToChar :: Season -> Char -seasonToChar Summer = 'S' -seasonToChar Winter = 'W' - -seasonFromChar :: Char -> Either Text Season -seasonFromChar c - | c ~= 'S' = Right Summer - | c ~= 'W' = Right Winter - | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’" - where - (~=) = (==) `on` CI.mk - -instance DisplayAble Season - -data TermIdentifier = TermIdentifier - { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' - , season :: Season - } deriving (Show, Read, Eq, Ord, Generic, Typeable) - -instance Binary TermIdentifier - -instance Enum TermIdentifier where - -- ^ Do not use for conversion – Enumeration only - toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..} - fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season - --- Conversion TermId <-> TermIdentifier:: --- from_TermId_to_TermIdentifier = unTermKey --- from_TermIdentifier_to_TermId = TermKey - -shortened :: Iso' Integer Integer -shortened = iso shorten expand - where - century = ($currentYear `div` 100) * 100 - expand year - | 0 <= year - , year < 100 = let - options = [ expanded | offset <- [-1, 0, 1] - , let century' = century + offset * 100 - expanded = century' + year - , $currentYear - 50 <= expanded - , expanded < $currentYear + 50 - ] - in case options of - [unique] -> unique - failed -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed - | otherwise = year - shorten year - | $currentYear - 50 <= year - , year < $currentYear + 50 = year `mod` 100 - | otherwise = year - -termToText :: TermIdentifier -> Text -termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened) - --- also see Hander.Utils.tidFromText -termFromText :: Text -> Either Text TermIdentifier -termFromText t - | (s:ys) <- Text.unpack t - , Just (review shortened -> year) <- readMaybe ys - , Right season <- seasonFromChar s - = Right TermIdentifier{..} - | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number - -termToRational :: TermIdentifier -> Rational -termToRational TermIdentifier{..} = fromInteger year + seasonOffset - where - seasonOffset - | Summer <- season = 0 - | Winter <- season = 0.5 - -termFromRational :: Rational -> TermIdentifier -termFromRational n = TermIdentifier{..} - where - year = floor n - remainder = n - (fromInteger $ floor n) - season - | remainder == 0 = Summer - | otherwise = Winter - -instance PersistField TermIdentifier where - toPersistValue = PersistRational . termToRational - fromPersistValue (PersistRational t) = Right $ termFromRational t - fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x - -instance PersistFieldSql TermIdentifier where - sqlType _ = SqlNumeric 5 1 - -instance ToHttpApiData TermIdentifier where - toUrlPiece = termToText - -instance FromHttpApiData TermIdentifier where - parseUrlPiece = termFromText - -instance PathPiece TermIdentifier where - fromPathPiece = either (const Nothing) Just . termFromText - toPathPiece = termToText - -instance ToJSON TermIdentifier where - toJSON = Aeson.String . termToText - -instance FromJSON TermIdentifier where - parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText - -{- Must be defined in a later module: - termField :: Field (HandlerT UniWorX IO) TermIdentifier - termField = checkMMap (return . termFromText) termToText textField - See Handler.Utils.Form.termsField and termActiveField --} - - -withinTerm :: Day -> TermIdentifier -> Bool -time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 - where - timeYear = fst3 $ toGregorian time - termYear = year term - - -data StudyFieldType = FieldPrimary | FieldSecondary - deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) -derivePersistField "StudyFieldType" - -instance PersistField UUID where - toPersistValue = PersistDbSpecific . UUID.toASCIIBytes - fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t - fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x - -instance PersistFieldSql UUID where - sqlType _ = SqlOther "uuid" - -instance DisplayAble StudyFieldType - -data Theme - = ThemeDefault - | ThemeLavender - | ThemeNeutralBlue - | ThemeAberdeenReds - | ThemeMossGreen - | ThemeSkyLove - deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = fromJust . stripPrefix "Theme" - } ''Theme - -instance Universe Theme where universe = universeDef -instance Finite Theme - -nullaryPathPiece ''Theme (camelToPathPiece' 1) - -$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user - -derivePersistField "Theme" - - -newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj } - deriving (Show, Read, Eq, Ord, Generic, Typeable) - -instance PathPiece obj => PathPiece (ZIPArchiveName obj) where - fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" - toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName - - -data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = fromJust . stripPrefix "Corrector" - } ''CorrectorState - -instance Universe CorrectorState -instance Finite CorrectorState - -instance Hashable CorrectorState - -nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) - -derivePersistField "CorrectorState" - - -data AuthenticationMode = AuthLDAP - | AuthPWHash { authPWHash :: Text } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , sumEncoding = UntaggedValue - } ''AuthenticationMode - -derivePersistFieldJSON ''AuthenticationMode - - -derivePersistFieldJSON ''Value - - --- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ --- --- Could maybe be replaced with `Structure Notification` in the long term -data NotificationTrigger = NTSubmissionRatedGraded - | NTSubmissionRated - | NTSheetActive - | NTSheetSoonInactive - | NTSheetInactive - | NTCorrectionsAssigned - | NTCorrectionsNotDistributed - | NTUserRightsUpdate - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe NotificationTrigger -instance Finite NotificationTrigger - -instance Hashable NotificationTrigger - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - } ''NotificationTrigger - -instance ToJSONKey NotificationTrigger where - toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t - -instance FromJSONKey NotificationTrigger where - fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String - - -newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } - deriving (Generic, Typeable) - deriving newtype (Eq, Ord, Read, Show) - -instance Default NotificationSettings where - def = NotificationSettings $ \case - NTSubmissionRatedGraded -> True - NTSubmissionRated -> False - NTSheetActive -> True - NTSheetSoonInactive -> False - NTSheetInactive -> True - NTCorrectionsAssigned -> True - NTCorrectionsNotDistributed -> True - NTUserRightsUpdate -> True - -instance ToJSON NotificationSettings where - toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF - -instance FromJSON NotificationSettings where - parseJSON = withObject "NotificationSettings" $ \o -> do - o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) - return . NotificationSettings $ \n -> case HashMap.lookup n o' of - Nothing -> notificationAllowed def n - Just b -> b - -derivePersistFieldJSON ''NotificationSettings - - -instance ToBackendKey SqlBackend record => Hashable (Key record) where - hashWithSalt s key = s `hashWithSalt` fromSqlKey key - -derivePersistFieldJSON ''MailLanguages - - -type PseudonymWord = CI Text - -newtype Pseudonym = Pseudonym Word24 - deriving (Eq, Ord, Read, Show, Generic, Data) - deriving newtype (Bounded, Enum, Integral, Num, Real, Ix) - - -instance PersistField Pseudonym where - toPersistValue p = toPersistValue (fromIntegral p :: Word32) - fromPersistValue v = do - w <- fromPersistValue v :: Either Text Word32 - if - | 0 <= w - , w <= fromIntegral (maxBound :: Pseudonym) - -> return $ fromIntegral w - | otherwise - -> Left "Pseudonym out of range" - -instance PersistFieldSql Pseudonym where - sqlType _ = SqlInt32 - -instance Random Pseudonym where - randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen - random = randomR (minBound, maxBound) - -instance FromJSON Pseudonym where - parseJSON v@(Aeson.Number _) = do - w <- parseJSON v :: Aeson.Parser Word32 - if - | 0 <= w - , w <= fromIntegral (maxBound :: Pseudonym) - -> return $ fromIntegral w - | otherwise - -> fail "Pseudonym out auf range" - parseJSON (Aeson.String t) - = case t ^? _PseudonymText of - Just p -> return p - Nothing -> fail "Could not parse pseudonym" - parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do - ws' <- toList . map CI.mk <$> mapM parseJSON ws - case ws' ^? _PseudonymWords of - Just p -> return p - Nothing -> fail "Could not parse pseudonym words" - -instance ToJSON Pseudonym where - toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) - -pseudonymWordlist :: [PseudonymWord] -pseudonymCharacters :: Set (CI Char) -(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") - -_PseudonymWords :: Prism' [PseudonymWord] Pseudonym -_PseudonymWords = prism' pToWords pFromWords - where - pFromWords :: [PseudonymWord] -> Maybe Pseudonym - pFromWords [w1, w2] - | Just i1 <- elemIndex w1 pseudonymWordlist - , Just i2 <- elemIndex w2 pseudonymWordlist - , i1 <= maxWord, i2 <= maxWord - = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 - pFromWords _ = Nothing - - pToWords :: Pseudonym -> [PseudonymWord] - pToWords (Pseudonym p) - = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord - , genericIndex pseudonymWordlist $ p .&. maxWord - ] - - maxWord :: Num a => a - maxWord = 0b111111111111 - -_PseudonymText :: Prism' Text Pseudonym -_PseudonymText = prism' tToWords tFromWords . _PseudonymWords - where - tFromWords :: Text -> Maybe [PseudonymWord] - tFromWords input - | [result] <- input ^.. pseudonymFragments - = Just result - | otherwise - = Nothing - - tToWords :: [PseudonymWord] -> Text - tToWords = Text.unwords . map CI.original - -pseudonymWords :: Fold Text PseudonymWord -pseudonymWords = folding - $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist - where - distance = damerauLevenshtein `on` CI.foldedCase - -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 - distanceCutoff = 2 - -pseudonymFragments :: Fold Text [PseudonymWord] -pseudonymFragments = folding - $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) - - -data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer - = AuthAdmin - | AuthLecturer - | AuthCorrector - | AuthTutor - | AuthCourseRegistered - | AuthTutorialRegistered - | AuthParticipant - | AuthTime - | AuthMaterials - | AuthOwner - | AuthRated - | AuthUserSubmissions - | AuthCorrectorSubmissions - | AuthCapacity - | AuthRegisterGroup - | AuthEmpty - | AuthSelf - | AuthAuthentication - | AuthNoEscalation - | AuthRead - | AuthWrite - | AuthToken - | AuthDeprecated - | AuthDevelopment - | AuthFree - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - -instance Universe AuthTag -instance Finite AuthTag -instance Hashable AuthTag - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''AuthTag - -nullaryPathPiece ''AuthTag (camelToPathPiece' 1) - -instance ToJSONKey AuthTag where - toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t - -instance FromJSONKey AuthTag where - fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String - -instance Binary AuthTag - - -newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool } - deriving (Read, Show, Generic) - deriving newtype (Eq, Ord) - -instance Default AuthTagActive where - def = AuthTagActive $ \case - AuthAdmin -> False - _ -> True - -instance ToJSON AuthTagActive where - toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF - -instance FromJSON AuthTagActive where - parseJSON = withObject "AuthTagActive" $ \o -> do - o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) - return . AuthTagActive $ \n -> case HashMap.lookup n o' of - Nothing -> authTagIsActive def n - Just b -> b - -derivePersistFieldJSON ''AuthTagActive - - -data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Hashable a => Hashable (PredLiteral a) -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "val" "var" - } ''PredLiteral - -instance PathPiece a => PathPiece (PredLiteral a) where - toPathPiece PLVariable{..} = toPathPiece plVar - toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar - - fromPathPiece t = PLVariable <$> fromPathPiece t - <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece) - -instance Binary a => Binary (PredLiteral a) - - -newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (Semigroup, Monoid) - -$(return []) - -instance ToJSON a => ToJSON (PredDNF a) where - toJSON = $(mkToJSON predNFAesonOptions ''PredDNF) -instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where - parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF) - -instance (Ord a, Binary a) => Binary (PredDNF a) where - get = PredDNF <$> Binary.get - put = Binary.put . dnfTerms - -type AuthLiteral = PredLiteral AuthTag - -type AuthDNF = PredDNF AuthTag - - -data LecturerType = CourseLecturer | CourseAssistant - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe LecturerType -instance Finite LecturerType - -nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''LecturerType -derivePersistFieldJSON ''LecturerType - -instance Hashable LecturerType - - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - } ''WeekDay - -data OccurenceSchedule = ScheduleWeekly - { scheduleDayOfWeek :: WeekDay - , scheduleStart :: TimeOfDay - , scheduleEnd :: TimeOfDay - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - , tagSingleConstructors = True - , sumEncoding = TaggedObject "repeat" "schedule" - } ''OccurenceSchedule - -data OccurenceException = ExceptOccur - { exceptDay :: Day - , exceptStart :: TimeOfDay - , exceptEnd :: TimeOfDay - } - | ExceptNoOccur - { exceptTime :: LocalTime - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "exception" "for" - } ''OccurenceException - -data Occurences = Occurences - { occurencesScheduled :: Set OccurenceSchedule - , occurencesExceptions :: Set OccurenceException - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''Occurences -derivePersistFieldJSON ''Occurences - - -data HealthReport = HealthReport - { healthMatchingClusterConfig :: Bool - -- ^ Is the database-stored configuration we're running under still up to date? - , healthHTTPReachable :: Maybe Bool - -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? - -- - -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings - , healthLDAPAdmins :: Maybe Rational - -- ^ Proportion of school admins that could be found in LDAP - -- - -- Is `Nothing` if LDAP is not configured or no users are school admins - , healthSMTPConnect :: Maybe Bool - -- ^ Can we connect to the SMTP server and say @NOOP@? - , healthWidgetMemcached :: Maybe Bool - -- ^ Can we store values in memcached and retrieve them via HTTP? - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , omitNothingFields = True - } ''HealthReport - --- | `HealthReport` classified (`classifyHealthReport`) by badness --- --- > a < b = a `worseThan` b --- --- Currently all consumers of this type check for @(== HealthSuccess)@; this --- needs to be adjusted on a case-by-case basis if new constructors are added -data HealthStatus = HealthFailure | HealthSuccess - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe HealthStatus -instance Finite HealthStatus - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''HealthStatus -nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 - -classifyHealthReport :: HealthReport -> HealthStatus --- ^ Classify `HealthReport` by badness -classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point - unless healthMatchingClusterConfig . tell $ Min HealthFailure - unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure - unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure - unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure - unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure - - -- Type synonyms type Email = Text diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs new file mode 100644 index 000000000..05fe00594 --- /dev/null +++ b/src/Model/Types/DateTime.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , UndecidableInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + +module Model.Types.DateTime where + + +import ClassyPrelude +import GHC.Generics (Generic) +import Utils +import Control.Lens hiding (universe) +import Data.NonNull.Instances () +import Data.Typeable (Typeable) +import Data.Universe.Instances.Reverse () +import Data.Binary (Binary) + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () +import Text.Read (readMaybe) + +import Database.Persist.Class +import Database.Persist.Sql + +import Web.HttpApiData + +import Yesod.Core.Dispatch (PathPiece(..)) +import qualified Data.Aeson as Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), withText) + + +---- +-- Terms, Seaons, anything loosely related to time + +data Season = Summer | Winter + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) + +instance Binary Season + +seasonToChar :: Season -> Char +seasonToChar Summer = 'S' +seasonToChar Winter = 'W' + +seasonFromChar :: Char -> Either Text Season +seasonFromChar c + | c ~= 'S' = Right Summer + | c ~= 'W' = Right Winter + | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’" + where + (~=) = (==) `on` CI.mk + +instance DisplayAble Season + +data TermIdentifier = TermIdentifier + { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' + , season :: Season + } deriving (Show, Read, Eq, Ord, Generic, Typeable) + +instance Binary TermIdentifier + +instance Enum TermIdentifier where + -- ^ Do not use for conversion – Enumeration only + toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..} + fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season + +-- Conversion TermId <-> TermIdentifier:: +-- from_TermId_to_TermIdentifier = unTermKey +-- from_TermIdentifier_to_TermId = TermKey + +shortened :: Iso' Integer Integer +shortened = iso shorten expand + where + century = ($currentYear `div` 100) * 100 + expand year + | 0 <= year + , year < 100 = let + options = [ expanded | offset <- [-1, 0, 1] + , let century' = century + offset * 100 + expanded = century' + year + , $currentYear - 50 <= expanded + , expanded < $currentYear + 50 + ] + in case options of + [unique] -> unique + failed -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed + | otherwise = year + shorten year + | $currentYear - 50 <= year + , year < $currentYear + 50 = year `mod` 100 + | otherwise = year + +termToText :: TermIdentifier -> Text +termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened) + +-- also see Hander.Utils.tidFromText +termFromText :: Text -> Either Text TermIdentifier +termFromText t + | (s:ys) <- Text.unpack t + , Just (review shortened -> year) <- readMaybe ys + , Right season <- seasonFromChar s + = Right TermIdentifier{..} + | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number + +termToRational :: TermIdentifier -> Rational +termToRational TermIdentifier{..} = fromInteger year + seasonOffset + where + seasonOffset + | Summer <- season = 0 + | Winter <- season = 0.5 + +termFromRational :: Rational -> TermIdentifier +termFromRational n = TermIdentifier{..} + where + year = floor n + remainder = n - (fromInteger $ floor n) + season + | remainder == 0 = Summer + | otherwise = Winter + +instance PersistField TermIdentifier where + toPersistValue = PersistRational . termToRational + fromPersistValue (PersistRational t) = Right $ termFromRational t + fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x + +instance PersistFieldSql TermIdentifier where + sqlType _ = SqlNumeric 5 1 + +instance ToHttpApiData TermIdentifier where + toUrlPiece = termToText + +instance FromHttpApiData TermIdentifier where + parseUrlPiece = termFromText + +instance PathPiece TermIdentifier where + fromPathPiece = either (const Nothing) Just . termFromText + toPathPiece = termToText + +instance ToJSON TermIdentifier where + toJSON = Aeson.String . termToText + +instance FromJSON TermIdentifier where + parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText + +{- Must be defined in a later module: + termField :: Field (HandlerT UniWorX IO) TermIdentifier + termField = checkMMap (return . termFromText) termToText textField + See Handler.Utils.Form.termsField and termActiveField +-} + + +withinTerm :: Day -> TermIdentifier -> Bool +time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 + where + timeYear = fst3 $ toGregorian time + termYear = year term + diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs new file mode 100644 index 000000000..226665e63 --- /dev/null +++ b/src/Model/Types/Misc.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , UndecidableInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + +module Model.Types.Misc where + + +import ClassyPrelude +import Utils +import Control.Lens hiding (universe) + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Maybe (fromJust) +import Data.Universe +import Data.Universe.Helpers +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID + +import Data.NonNull.Instances () + +import Data.Default + +import Database.Persist.TH hiding (derivePersistFieldJSON) +import Model.Types.JSON +import Database.Persist.Class +import Database.Persist.Sql + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lens as Text + +import qualified Data.HashMap.Strict as HashMap + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () + +import Yesod.Core.Dispatch (PathPiece(..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject, Value()) +import Data.Aeson.Types (toJSONKeyText) +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON) + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) + +import Data.Universe.Instances.Reverse () + +import Mail (MailLanguages(..)) + +import Data.Word.Word24 (Word24) +import Data.Bits +import Data.Ix +import Data.List (genericIndex, elemIndex) +import System.Random (Random(..)) +import Data.Data (Data) + +import Model.Types.Wordlist +import Data.Text.Metrics (damerauLevenshtein) + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + +import Time.Types (WeekDay(..)) +import Data.Time.LocalTime (LocalTime, TimeOfDay) + +import Data.Semigroup (Min(..)) +import Control.Monad.Trans.Writer (execWriter) +import Control.Monad.Writer.Class (MonadWriter(..)) + + + + +data StudyFieldType = FieldPrimary | FieldSecondary + deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) +derivePersistField "StudyFieldType" + +instance PersistField UUID where + toPersistValue = PersistDbSpecific . UUID.toASCIIBytes + fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t + fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "uuid" + +instance DisplayAble StudyFieldType + +data Theme + = ThemeDefault + | ThemeLavender + | ThemeNeutralBlue + | ThemeAberdeenReds + | ThemeMossGreen + | ThemeSkyLove + deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Theme" + } ''Theme + +instance Universe Theme where universe = universeDef +instance Finite Theme + +nullaryPathPiece ''Theme (camelToPathPiece' 1) + +$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user + +derivePersistField "Theme" + + +newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj } + deriving (Show, Read, Eq, Ord, Generic, Typeable) + +instance PathPiece obj => PathPiece (ZIPArchiveName obj) where + fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" + toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName + + +data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Corrector" + } ''CorrectorState + +instance Universe CorrectorState +instance Finite CorrectorState + +instance Hashable CorrectorState + +nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) + +derivePersistField "CorrectorState" + + +data AuthenticationMode = AuthLDAP + | AuthPWHash { authPWHash :: Text } + deriving (Eq, Ord, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel + , sumEncoding = UntaggedValue + } ''AuthenticationMode + +derivePersistFieldJSON ''AuthenticationMode + + +derivePersistFieldJSON ''Value + + +-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ +-- +-- Could maybe be replaced with `Structure Notification` in the long term +data NotificationTrigger = NTSubmissionRatedGraded + | NTSubmissionRated + | NTSheetActive + | NTSheetSoonInactive + | NTSheetInactive + | NTCorrectionsAssigned + | NTCorrectionsNotDistributed + | NTUserRightsUpdate + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe NotificationTrigger +instance Finite NotificationTrigger + +instance Hashable NotificationTrigger + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''NotificationTrigger + +instance ToJSONKey NotificationTrigger where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey NotificationTrigger where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + + +newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance Default NotificationSettings where + def = NotificationSettings $ \case + NTSubmissionRatedGraded -> True + NTSubmissionRated -> False + NTSheetActive -> True + NTSheetSoonInactive -> False + NTSheetInactive -> True + NTCorrectionsAssigned -> True + NTCorrectionsNotDistributed -> True + NTUserRightsUpdate -> True + +instance ToJSON NotificationSettings where + toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF + +instance FromJSON NotificationSettings where + parseJSON = withObject "NotificationSettings" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) + return . NotificationSettings $ \n -> case HashMap.lookup n o' of + Nothing -> notificationAllowed def n + Just b -> b + +derivePersistFieldJSON ''NotificationSettings + + +instance ToBackendKey SqlBackend record => Hashable (Key record) where + hashWithSalt s key = s `hashWithSalt` fromSqlKey key + +derivePersistFieldJSON ''MailLanguages + + +type PseudonymWord = CI Text + +newtype Pseudonym = Pseudonym Word24 + deriving (Eq, Ord, Read, Show, Generic, Data) + deriving newtype (Bounded, Enum, Integral, Num, Real, Ix) + + +instance PersistField Pseudonym where + toPersistValue p = toPersistValue (fromIntegral p :: Word32) + fromPersistValue v = do + w <- fromPersistValue v :: Either Text Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> Left "Pseudonym out of range" + +instance PersistFieldSql Pseudonym where + sqlType _ = SqlInt32 + +instance Random Pseudonym where + randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen + random = randomR (minBound, maxBound) + +instance FromJSON Pseudonym where + parseJSON v@(Aeson.Number _) = do + w <- parseJSON v :: Aeson.Parser Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> fail "Pseudonym out auf range" + parseJSON (Aeson.String t) + = case t ^? _PseudonymText of + Just p -> return p + Nothing -> fail "Could not parse pseudonym" + parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do + ws' <- toList . map CI.mk <$> mapM parseJSON ws + case ws' ^? _PseudonymWords of + Just p -> return p + Nothing -> fail "Could not parse pseudonym words" + +instance ToJSON Pseudonym where + toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) + +pseudonymWordlist :: [PseudonymWord] +pseudonymCharacters :: Set (CI Char) +(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") + +_PseudonymWords :: Prism' [PseudonymWord] Pseudonym +_PseudonymWords = prism' pToWords pFromWords + where + pFromWords :: [PseudonymWord] -> Maybe Pseudonym + pFromWords [w1, w2] + | Just i1 <- elemIndex w1 pseudonymWordlist + , Just i2 <- elemIndex w2 pseudonymWordlist + , i1 <= maxWord, i2 <= maxWord + = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 + pFromWords _ = Nothing + + pToWords :: Pseudonym -> [PseudonymWord] + pToWords (Pseudonym p) + = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord + , genericIndex pseudonymWordlist $ p .&. maxWord + ] + + maxWord :: Num a => a + maxWord = 0b111111111111 + +_PseudonymText :: Prism' Text Pseudonym +_PseudonymText = prism' tToWords tFromWords . _PseudonymWords + where + tFromWords :: Text -> Maybe [PseudonymWord] + tFromWords input + | [result] <- input ^.. pseudonymFragments + = Just result + | otherwise + = Nothing + + tToWords :: [PseudonymWord] -> Text + tToWords = Text.unwords . map CI.original + +pseudonymWords :: Fold Text PseudonymWord +pseudonymWords = folding + $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist + where + distance = damerauLevenshtein `on` CI.foldedCase + -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 + distanceCutoff = 2 + +pseudonymFragments :: Fold Text [PseudonymWord] +pseudonymFragments = folding + $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) + + +data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer + = AuthAdmin + | AuthLecturer + | AuthCorrector + | AuthTutor + | AuthCourseRegistered + | AuthTutorialRegistered + | AuthParticipant + | AuthTime + | AuthMaterials + | AuthOwner + | AuthRated + | AuthUserSubmissions + | AuthCorrectorSubmissions + | AuthCapacity + | AuthRegisterGroup + | AuthEmpty + | AuthSelf + | AuthAuthentication + | AuthNoEscalation + | AuthRead + | AuthWrite + | AuthToken + | AuthDeprecated + | AuthDevelopment + | AuthFree + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe AuthTag +instance Finite AuthTag +instance Hashable AuthTag + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''AuthTag + +nullaryPathPiece ''AuthTag (camelToPathPiece' 1) + +instance ToJSONKey AuthTag where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey AuthTag where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + +instance Binary AuthTag + + +newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool } + deriving (Read, Show, Generic) + deriving newtype (Eq, Ord) + +instance Default AuthTagActive where + def = AuthTagActive $ \case + AuthAdmin -> False + _ -> True + +instance ToJSON AuthTagActive where + toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF + +instance FromJSON AuthTagActive where + parseJSON = withObject "AuthTagActive" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) + return . AuthTagActive $ \n -> case HashMap.lookup n o' of + Nothing -> authTagIsActive def n + Just b -> b + +derivePersistFieldJSON ''AuthTagActive + + +data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Hashable a => Hashable (PredLiteral a) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "val" "var" + } ''PredLiteral + +instance PathPiece a => PathPiece (PredLiteral a) where + toPathPiece PLVariable{..} = toPathPiece plVar + toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar + + fromPathPiece t = PLVariable <$> fromPathPiece t + <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece) + +instance Binary a => Binary (PredLiteral a) + + +newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Semigroup, Monoid) + +$(return []) + +instance ToJSON a => ToJSON (PredDNF a) where + toJSON = $(mkToJSON predNFAesonOptions ''PredDNF) +instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where + parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF) + +instance (Ord a, Binary a) => Binary (PredDNF a) where + get = PredDNF <$> Binary.get + put = Binary.put . dnfTerms + +type AuthLiteral = PredLiteral AuthTag + +type AuthDNF = PredDNF AuthTag + + +data LecturerType = CourseLecturer | CourseAssistant + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe LecturerType +instance Finite LecturerType + +nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''LecturerType +derivePersistFieldJSON ''LecturerType + +instance Hashable LecturerType + + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + } ''WeekDay + +data OccurenceSchedule = ScheduleWeekly + { scheduleDayOfWeek :: WeekDay + , scheduleStart :: TimeOfDay + , scheduleEnd :: TimeOfDay + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = True + , sumEncoding = TaggedObject "repeat" "schedule" + } ''OccurenceSchedule + +data OccurenceException = ExceptOccur + { exceptDay :: Day + , exceptStart :: TimeOfDay + , exceptEnd :: TimeOfDay + } + | ExceptNoOccur + { exceptTime :: LocalTime + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "exception" "for" + } ''OccurenceException + +data Occurences = Occurences + { occurencesScheduled :: Set OccurenceSchedule + , occurencesExceptions :: Set OccurenceException + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''Occurences +derivePersistFieldJSON ''Occurences + + +data HealthReport = HealthReport + { healthMatchingClusterConfig :: Bool + -- ^ Is the database-stored configuration we're running under still up to date? + , healthHTTPReachable :: Maybe Bool + -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? + -- + -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings + , healthLDAPAdmins :: Maybe Rational + -- ^ Proportion of school admins that could be found in LDAP + -- + -- Is `Nothing` if LDAP is not configured or no users are school admins + , healthSMTPConnect :: Maybe Bool + -- ^ Can we connect to the SMTP server and say @NOOP@? + , healthWidgetMemcached :: Maybe Bool + -- ^ Can we store values in memcached and retrieve them via HTTP? + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + } ''HealthReport + +-- | `HealthReport` classified (`classifyHealthReport`) by badness +-- +-- > a < b = a `worseThan` b +-- +-- Currently all consumers of this type check for @(== HealthSuccess)@; this +-- needs to be adjusted on a case-by-case basis if new constructors are added +data HealthStatus = HealthFailure | HealthSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe HealthStatus +instance Finite HealthStatus + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''HealthStatus +nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 + +classifyHealthReport :: HealthReport -> HealthStatus +-- ^ Classify `HealthReport` by badness +classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point + unless healthMatchingClusterConfig . tell $ Min HealthFailure + unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure + unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure + unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure + unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure + diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs new file mode 100644 index 000000000..825c07e9f --- /dev/null +++ b/src/Model/Types/Sheet.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , UndecidableInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) + +module Model.Types.Sheet where + +import ClassyPrelude +import Utils +import Numeric.Natural + +import Control.Lens hiding (universe) +import Utils.Lens.TH +import GHC.Generics (Generic) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) +import Data.Typeable (Typeable) +import Data.Universe +import Data.Universe.Helpers +import Data.Universe.TH +import Data.Universe.Instances.Reverse () + +import Data.NonNull.Instances () +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.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) + +import Data.CaseInsensitive.Instances () +import Text.Blaze (Markup) + +import Database.Persist.TH hiding (derivePersistFieldJSON) +import Model.Types.JSON +import Yesod.Core.Dispatch (PathPiece(..)) + + +---- +-- Sheet and Submission realted Model.Types + +type Count = Sum Integer +type Points = Centi + +toPoints :: Integral a => a -> Points -- deprecated +toPoints = fromIntegral + +pToI :: Points -> Integer -- deprecated +pToI = fromPoints + +fromPoints :: Integral a => Points -> a -- deprecated +fromPoints = round + +instance DisplayAble Points + +instance DisplayAble a => DisplayAble (Sum a) where + display (Sum x) = display x + +data SheetGrading + = Points { maxPoints :: Points } + | PassPoints { maxPoints, passingPoints :: Points } + | PassBinary -- non-zero means passed + deriving (Eq, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel + , sumEncoding = TaggedObject "type" "data" + } ''SheetGrading +derivePersistFieldJSON ''SheetGrading + +makeLenses_ ''SheetGrading + +_passingBound :: Fold SheetGrading (Either () Points) +_passingBound = folding passPts + where + passPts :: SheetGrading -> Maybe (Either () Points) + passPts (Points{}) = Nothing + passPts (PassPoints{passingPoints}) = Just $ Right passingPoints + passPts (PassBinary) = Just $ Left () + +gradingPassed :: SheetGrading -> Points -> Maybe Bool +gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound + where pBinary _ = pts /= 0 + pPoints b = pts >= b + + +data SheetGradeSummary = SheetGradeSummary + { numSheets :: Count -- Total number of sheets, includes all + , numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses + , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd + , sumSheetsPoints :: Sum Points -- Total of all points in all sheets + -- Marking dependend + , numMarked :: Count -- Number of already marked sheets + , numMarkedPasses :: Count -- Number of already marked sheets with passes + , numMarkedPoints :: Count -- Number of already marked sheets with points + , sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets + -- + , achievedPasses :: Count -- Achieved passes (within marked sheets) + , achievedPoints :: Sum Points -- Achieved points (within marked sheets) + } deriving (Generic, Read, Show, Eq) + +instance Monoid SheetGradeSummary where + mempty = memptydefault + mappend = mappenddefault + +instance Semigroup SheetGradeSummary where + (<>) = mappend -- TODO: remove for GHC > 8.4.x + +makeLenses_ ''SheetGradeSummary + +sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary +sheetGradeSum gr Nothing = mempty + { numSheets = 1 + , numSheetsPasses = bool mempty 1 $ has _passingBound gr + , numSheetsPoints = bool mempty 1 $ has _maxPoints gr + , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints + } +sheetGradeSum gr (Just p) = + let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing + in unmarked + { numMarked = numSheets + , numMarkedPasses = numSheetsPasses + , numMarkedPoints = numSheetsPoints + , sumMarkedPoints = sumSheetsPoints + , achievedPasses = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p + , achievedPoints = bool mempty (Sum p) $ has _maxPoints gr + } + + +data SheetType + = NotGraded + | Normal { grading :: SheetGrading } + | Bonus { grading :: SheetGrading } + | Informational { grading :: SheetGrading } + deriving (Eq, Read, Show, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = camelToPathPiece + , sumEncoding = TaggedObject "type" "data" + } ''SheetType +derivePersistFieldJSON ''SheetType + +data SheetTypeSummary = SheetTypeSummary + { normalSummary + , bonusSummary + , informationalSummary :: SheetGradeSummary + , numNotGraded :: Count + } deriving (Generic, Read, Show, Eq) + +instance Monoid SheetTypeSummary where + mempty = memptydefault + mappend = mappenddefault + +instance Semigroup SheetTypeSummary where + (<>) = mappend -- TODO: remove for GHC > 8.4.x + +makeLenses_ ''SheetTypeSummary + +sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary +sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps } +sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps } +sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } +sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 } + +data SheetGroup + = Arbitrary { maxParticipants :: Natural } + | RegisteredGroups + | NoGroups + deriving (Show, Read, Eq, Generic) +deriveJSON defaultOptions ''SheetGroup +derivePersistFieldJSON ''SheetGroup + +makeLenses_ ''SheetGroup + +data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) +derivePersistField "SheetFileType" + +instance Universe SheetFileType where universe = universeDef +instance Finite SheetFileType + +instance PathPiece SheetFileType where + toPathPiece SheetExercise = "file" + toPathPiece SheetHint = "hint" + toPathPiece SheetSolution = "solution" + toPathPiece SheetMarking = "marking" + fromPathPiece = finiteFromPathPiece + +sheetFile2markup :: SheetFileType -> Markup +sheetFile2markup SheetExercise = iconQuestion +sheetFile2markup SheetHint = iconHint +sheetFile2markup SheetSolution = iconSolution +sheetFile2markup SheetMarking = iconMarking + +-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) +instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation + display SheetExercise = "Aufgabenstellung" + display SheetHint = "Hinweise" + display SheetSolution = "Musterlösung" + display SheetMarking = "Korrekturhinweise" + +-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a) +-- partitionFileType' = groupMap + +partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a +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, Generic) + +instance Universe SubmissionFileType where universe = universeDef +instance Finite SubmissionFileType + +submissionFileTypeIsUpdate :: SubmissionFileType -> Bool +submissionFileTypeIsUpdate SubmissionOriginal = False +submissionFileTypeIsUpdate SubmissionCorrected = True + +isUpdateSubmissionFileType :: Bool -> SubmissionFileType +isUpdateSubmissionFileType False = SubmissionOriginal +isUpdateSubmissionFileType True = SubmissionCorrected + +instance PathPiece SubmissionFileType where + toPathPiece SubmissionOriginal = "original" + toPathPiece SubmissionCorrected = "corrected" + fromPathPiece = finiteFromPathPiece + +instance DisplayAble SubmissionFileType where + display SubmissionOriginal = "Abgabe" + display SubmissionCorrected = "Korrektur" + +{- +data DA = forall a . (DisplayAble a) => DA a + +instance DisplayAble DA where + display (DA x) = display x +-} + + +data UploadMode = NoUpload | Upload { unpackZips :: Bool } + deriving (Show, Read, Eq, Ord, Generic) + +deriveFinite ''UploadMode + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = camelToPathPiece + , sumEncoding = TaggedObject "mode" "settings" + }''UploadMode +derivePersistFieldJSON ''UploadMode + +instance PathPiece UploadMode where + toPathPiece = \case + NoUpload -> "no-upload" + Upload True -> "unpack" + Upload False -> "no-unpack" + fromPathPiece = finiteFromPathPiece + +data SubmissionMode = SubmissionMode + { submissionModeCorrector :: Bool + , submissionModeUser :: Maybe UploadMode + } + deriving (Show, Read, Eq, Ord, Generic) + +deriveFinite ''SubmissionMode + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''SubmissionMode +derivePersistFieldJSON ''SubmissionMode + +finitePathPiece ''SubmissionMode + [ "no-submissions" + , "no-upload" + , "no-unpack" + , "unpack" + , "correctors" + , "correctors+no-upload" + , "correctors+no-unpack" + , "correctors+unpack" + ] + +data SubmissionModeDescr = SubmissionModeNone + | SubmissionModeCorrector + | SubmissionModeUser + | SubmissionModeBoth + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe SubmissionModeDescr +instance Finite SubmissionModeDescr + +finitePathPiece ''SubmissionModeDescr + [ "no-submissions" + , "correctors" + , "users" + , "correctors+users" + ] + +classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr +classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone +classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector +classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser +classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth + + +data ExamStatus = Attended | NoShow | Voided + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) +derivePersistField "ExamStatus" + +-- | Specify a corrector's workload +data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } + = Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload + , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders + } + deriving (Show, Read, Eq, Ord, Generic) + +deriveJSON defaultOptions ''Load +derivePersistFieldJSON ''Load + +instance Hashable Load + +instance Semigroup Load where + (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') + where + byTut'' + | Nothing <- byTut = byTut' + | Nothing <- byTut' = byTut + | Just a <- byTut + , Just b <- byTut' = Just $ a || b + +instance Monoid Load where + mempty = Load Nothing 0 + mappend = (<>) + +{- Use (is _ByTutorial) instead of this unneeded definition: + isByTutorial :: Load -> Bool + isByTutorial (ByTutorial {}) = True + isByTutorial _ = False +-} \ No newline at end of file