Quiet hlint, one more split to Model.Types

src/Model/Types.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving
+{-# LANGUAGE UndecidableInstances #-}
-           , UndecidableInstances
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
 
@@ -9,6 +7,7 @@ module Model.Types
   ( module Model.Types
   , module Model.Types.Sheet
   , module Model.Types.DateTime
+  , module Model.Types.Security
   , module Model.Types.Misc
   , module Numeric.Natural
   , module Mail
@@ -38,6 +37,7 @@ import Numeric.Natural
 
 import Model.Types.Sheet
 import Model.Types.DateTime
+import Model.Types.Security
 import Model.Types.Misc
 
 ----

src/Model/Types/DateTime.hs

@@ -9,7 +9,7 @@ module Model.Types.DateTime where
 import ClassyPrelude
 import GHC.Generics (Generic)
 import Utils
-import Control.Lens hiding (universe)
+import Control.Lens
 import Data.NonNull.Instances ()
 import Data.Typeable (Typeable)
 import Data.Universe.Instances.Reverse ()
@@ -51,7 +51,7 @@ seasonFromChar c
   where
     (~=) = (==) `on` CI.mk
 
-instance DisplayAble Season
+-- instance DisplayAble Season
 
 data TermIdentifier = TermIdentifier
   { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
@@ -114,7 +114,7 @@ termFromRational :: Rational -> TermIdentifier
 termFromRational n = TermIdentifier{..}
   where
     year = floor n
-    remainder = n - (fromInteger $ floor n)
+    remainder = n - fromInteger (floor n)
     season
       | remainder == 0 = Summer
       | otherwise      = Winter

src/Model/Types/Misc.hs

@@ -8,87 +8,45 @@ module Model.Types.Misc where
 
 import ClassyPrelude
 import Utils
-import Control.Lens hiding (universe)
+import Control.Lens
 
+import Data.NonNull.Instances ()
 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 Database.Persist.TH hiding (derivePersistFieldJSON)
+import Model.Types.JSON
+
 import Yesod.Core.Dispatch (PathPiece(..))
-import qualified Data.Aeson as Aeson
+import Data.Aeson (Value())
-import qualified Data.Aeson.Types as Aeson
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
-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 Time.Types (WeekDay(..))
-import Data.Semigroup (Min(..))
-import Control.Monad.Trans.Writer (execWriter)
-import Control.Monad.Writer.Class (MonadWriter(..))
 
 
+-----
+-- Miscellaneous Model.Types
 
+derivePersistFieldJSON ''Value
 
 data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
 derivePersistField "StudyFieldType"
 
-instance PersistField UUID where
+-- instance DisplayAble StudyFieldType
-  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
@@ -138,290 +96,6 @@ 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)
 
@@ -481,52 +155,3 @@ deriveJSON defaultOptions
   } ''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
-

src/Model/Types/Security.hs

@@ -0,0 +1,411 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving
+           , UndecidableInstances
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
+
+module Model.Types.Security where
+
+
+import ClassyPrelude
+import Utils
+import Control.Lens hiding (universe)
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Universe
+import Data.UUID.Types (UUID)
+import qualified Data.UUID.Types as UUID
+
+import Data.NonNull.Instances ()
+
+import Data.Default
+
+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.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)
+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 Data.Semigroup (Min(..))
+import Control.Monad.Trans.Writer (execWriter)
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+
+----
+-- Security, Authentification, Notification Stuff
+
+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"
+
+
+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
+
+
+
+-- ^ `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 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
+

src/Model/Types/Sheet.hs

@@ -9,7 +9,7 @@ import ClassyPrelude
 import Utils
 import Numeric.Natural
 
-import Control.Lens hiding (universe)
+import Control.Lens
 import Utils.Lens.TH
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@@ -35,6 +35,7 @@ import Model.Types.JSON
 import Yesod.Core.Dispatch (PathPiece(..))
 
 
+
 ----
 -- Sheet and Submission realted Model.Types
 
@@ -53,7 +54,7 @@ fromPoints = round
 instance DisplayAble Points
 
 instance DisplayAble a => DisplayAble (Sum a) where
-  display (Sum x) = display x
+   display (Sum x) = display x
 
 data SheetGrading
   = Points     { maxPoints :: Points }
@@ -74,9 +75,9 @@ _passingBound :: Fold SheetGrading (Either () Points)
 _passingBound = folding passPts
   where
     passPts :: SheetGrading -> Maybe (Either () Points)
-    passPts (Points{}) = Nothing
+    passPts Points{}                  = Nothing
-    passPts (PassPoints{passingPoints}) = Just $ Right passingPoints
+    passPts PassPoints{passingPoints} = Just $ Right passingPoints
-    passPts (PassBinary) = Just $ Left ()
+    passPts PassBinary                = Just $ Left ()
 
 gradingPassed :: SheetGrading -> Points -> Maybe Bool
 gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound
@@ -122,7 +123,7 @@ sheetGradeSum gr (Just p) =
         , numMarkedPasses = numSheetsPasses
         , numMarkedPoints = numSheetsPoints
         , sumMarkedPoints = sumSheetsPoints
-        , achievedPasses  = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p
+        , achievedPasses  = maybe mempty (bool 0 1) (gradingPassed gr p)
         , achievedPoints  = bool mempty (Sum p) $ has _maxPoints gr
         }
 
@@ -194,11 +195,11 @@ sheetFile2markup SheetSolution = iconSolution
 sheetFile2markup SheetMarking  = iconMarking
 
 -- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
-instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
+-- instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
-  display SheetExercise = "Aufgabenstellung"
+--   display SheetExercise = "Aufgabenstellung"
-  display SheetHint     = "Hinweise"
+--   display SheetHint     = "Hinweise"
-  display SheetSolution = "Musterlösung"
+--   display SheetSolution = "Musterlösung"
-  display SheetMarking  = "Korrekturhinweise"
+--   display SheetMarking  = "Korrekturhinweise"
 
 -- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
 -- partitionFileType' = groupMap
@@ -225,9 +226,9 @@ instance PathPiece SubmissionFileType where
   toPathPiece SubmissionCorrected = "corrected"
   fromPathPiece = finiteFromPathPiece
 
-instance DisplayAble SubmissionFileType where
+-- instance DisplayAble SubmissionFileType where
-  display SubmissionOriginal  = "Abgabe"
+--   display SubmissionOriginal  = "Abgabe"
-  display SubmissionCorrected = "Korrektur"
+--   display SubmissionCorrected = "Korrektur"
 
 {-
 data DA = forall a . (DisplayAble a) => DA a