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-unrecognised-pragmas
|
||||||
- -fno-warn-partial-type-signatures
|
- -fno-warn-partial-type-signatures
|
||||||
- -fno-max-relevant-binds
|
- -fno-max-relevant-binds
|
||||||
- -j2
|
- -j3
|
||||||
|
|
||||||
when:
|
when:
|
||||||
- condition: flag(pedantic)
|
- condition: flag(pedantic)
|
||||||
|
|||||||
@ -531,7 +531,7 @@ postCorrectionsR = do
|
|||||||
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
||||||
|
|
||||||
psValidator = def
|
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")
|
& restrictSorting (\name _ -> name /= "corrector")
|
||||||
& defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
|
& defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
|
||||||
-- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN
|
-- & 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)
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
module Model.Types
|
module Model.Types
|
||||||
( module Model.Types
|
( module Model.Types
|
||||||
|
, module Model.Types.Sheet
|
||||||
|
, module Model.Types.DateTime
|
||||||
|
, module Model.Types.Misc
|
||||||
, module Numeric.Natural
|
, module Numeric.Natural
|
||||||
, module Mail
|
, module Mail
|
||||||
, module Utils.DateTime
|
, module Utils.DateTime
|
||||||
@ -12,86 +17,31 @@ module Model.Types
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import ClassyPrelude
|
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 Data.UUID.Types (UUID)
|
||||||
import qualified Data.UUID.Types as UUID
|
import qualified Data.UUID.Types as UUID
|
||||||
|
|
||||||
import Data.NonNull.Instances ()
|
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 Data.Text (Text)
|
||||||
import qualified Data.Text as 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 Data.CaseInsensitive (CI)
|
||||||
import qualified Data.CaseInsensitive as CI
|
|
||||||
import Data.CaseInsensitive.Instances ()
|
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 Data.Universe.Instances.Reverse ()
|
||||||
|
|
||||||
|
import Yesod.Core.Dispatch (PathPiece(..))
|
||||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||||
|
import Web.PathPieces
|
||||||
|
|
||||||
import Mail (MailLanguages(..))
|
import Mail (MailLanguages(..))
|
||||||
import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
|
import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
|
||||||
|
|
||||||
import Numeric.Natural
|
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 Model.Types.Sheet
|
||||||
import Data.Text.Metrics (damerauLevenshtein)
|
import Model.Types.DateTime
|
||||||
|
import Model.Types.Misc
|
||||||
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(..))
|
|
||||||
|
|
||||||
|
----
|
||||||
|
-- Just bringing together the different Model.Types submodules.
|
||||||
|
|
||||||
instance PathPiece UUID where
|
instance PathPiece UUID where
|
||||||
fromPathPiece = UUID.fromString . unpack
|
fromPathPiece = UUID.fromString . unpack
|
||||||
@ -102,885 +52,6 @@ instance {-# OVERLAPS #-} PathMultiPiece FilePath where
|
|||||||
toPathMultiPiece = Text.splitOn "/" . pack
|
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 synonyms
|
||||||
|
|
||||||
type Email = Text
|
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
|
||||||
|
-}
|
||||||
Reference in New Issue
Block a user