Splitting Model.Types into three parts
This commit is contained in:
Steffen Jost
parent
3dcb5a2b19
commit
05389fc27e
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
158
src/Model/Types/DateTime.hs
Normal file
158
src/Model/Types/DateTime.hs
Normal file
@ -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
|
||||
|
||||
532
src/Model/Types/Misc.hs
Normal file
532
src/Model/Types/Misc.hs
Normal file
@ -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
|
||||
|
||||
338
src/Model/Types/Sheet.hs
Normal file
338
src/Model/Types/Sheet.hs
Normal file
@ -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
|
||||
-}
|
||||
Loading…
Reference in New Issue
Block a user