Quiet hlint, one more split to Model.Types
This commit is contained in:
Steffen Jost
parent
05389fc27e
commit
81441717ce
@ -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
|
||||
|
||||
----
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
411
src/Model/Types/Security.hs
Normal file
411
src/Model/Types/Security.hs
Normal file
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user