From 81441717ce44adf7e3d547ef80e691d037bd678c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 May 2019 22:33:57 +0200 Subject: [PATCH] Quiet hlint, one more split to Model.Types --- src/Model/Types.hs | 6 +- src/Model/Types/DateTime.hs | 6 +- src/Model/Types/Misc.hs | 399 ++-------------------------------- src/Model/Types/Security.hs | 411 ++++++++++++++++++++++++++++++++++++ src/Model/Types/Sheet.hs | 29 +-- 5 files changed, 444 insertions(+), 407 deletions(-) create mode 100644 src/Model/Types/Security.hs diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b812d529c..b1692283c 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} +{-# LANGUAGE 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 ---- diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 05fe00594..cb7b2999d 100644 --- a/src/Model/Types/DateTime.hs +++ b/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 diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 226665e63..0affd8b70 100644 --- a/src/Model/Types/Misc.hs +++ b/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 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 Data.Aeson (Value()) +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) 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(..)) +import Time.Types (WeekDay(..)) +----- +-- Miscellaneous Model.Types +derivePersistFieldJSON ''Value 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 +-- 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 - diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs new file mode 100644 index 000000000..27be35f81 --- /dev/null +++ b/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 + diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 825c07e9f..a754d0d0b 100644 --- a/src/Model/Types/Sheet.hs +++ b/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 (PassPoints{passingPoints}) = Just $ Right passingPoints - passPts (PassBinary) = Just $ Left () + 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 @@ -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 - display SheetExercise = "Aufgabenstellung" - display SheetHint = "Hinweise" - display SheetSolution = "Musterlösung" - display SheetMarking = "Korrekturhinweise" +-- 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 @@ -225,9 +226,9 @@ instance PathPiece SubmissionFileType where toPathPiece SubmissionCorrected = "corrected" fromPathPiece = finiteFromPathPiece -instance DisplayAble SubmissionFileType where - display SubmissionOriginal = "Abgabe" - display SubmissionCorrected = "Korrektur" +-- instance DisplayAble SubmissionFileType where +-- display SubmissionOriginal = "Abgabe" +-- display SubmissionCorrected = "Korrektur" {- data DA = forall a . (DisplayAble a) => DA a