Prototype of !token
This commit is contained in:
Gregor Kleen
parent
680b674b09
commit
cc8823c7ca
13
haddock.sh
13
haddock.sh
@ -1,3 +1,14 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
|
||||
move-back() {
|
||||
mv -v .stack-work .stack-work-doc
|
||||
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
|
||||
}
|
||||
|
||||
if [[ -d .stack-work-doc ]]; then
|
||||
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
|
||||
mv -v .stack-work-doc .stack-work
|
||||
trap move-back EXIT
|
||||
fi
|
||||
|
||||
stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
|
||||
|
||||
@ -203,6 +203,10 @@ CorrectorAssignTitle: Korrektor zuweisen
|
||||
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
|
||||
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
|
||||
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
|
||||
UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
|
||||
UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
|
||||
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
|
||||
UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
|
||||
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
|
||||
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
|
||||
UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
|
||||
@ -698,6 +702,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate
|
||||
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
|
||||
AuthTagFree: Seite ist universell zugänglich
|
||||
AuthTagAdmin: Nutzer ist Administrator
|
||||
AuthTagToken: Nutzer präsentiert Authorisierungs-Token
|
||||
AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
|
||||
AuthTagDeprecated: Seite ist nicht überholt
|
||||
AuthTagDevelopment: Seite ist nicht in Entwicklung
|
||||
|
||||
@ -15,6 +15,7 @@ import Auth.LDAP
|
||||
import Auth.PWHash
|
||||
import Auth.Dummy
|
||||
import Jobs.Types
|
||||
import Model.Token
|
||||
|
||||
import qualified Network.Wai as W (pathInfo)
|
||||
|
||||
@ -43,6 +44,7 @@ import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map, (!?))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.List (nubBy)
|
||||
|
||||
@ -396,6 +398,17 @@ appLanguagesOpts = do
|
||||
|
||||
|
||||
-- Access Control
|
||||
newtype InvalidAuthTag = InvalidAuthTag Text
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
instance Exception InvalidAuthTag
|
||||
|
||||
data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
instance Universe SessionAuthTags
|
||||
instance Finite SessionAuthTags
|
||||
nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
|
||||
|
||||
|
||||
data AccessPredicate
|
||||
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
|
||||
@ -460,6 +473,26 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
|
||||
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
|
||||
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ do
|
||||
jwt <- maybeTMExceptT (unauthorizedI MsgUnauthorizedNoToken) $ asum
|
||||
[ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
|
||||
, MaybeT $ lookupGlobalPostParam PostToken
|
||||
, MaybeT $ lookupGlobalGetParam GetToken
|
||||
]
|
||||
BearerToken{..} <- catch (decodeToken jwt) $ \case
|
||||
BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
|
||||
BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
|
||||
other -> throwM other
|
||||
unless (maybe True (HashSet.member route) tokenRoutes) $
|
||||
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidRoute
|
||||
authorityVal <- evalAccessFor (Just tokenAuthority) route isWrite
|
||||
unless (is _Authorized authorityVal) $
|
||||
throwError authorityVal
|
||||
whenIsJust tokenAddAuth $ \addDNF -> do
|
||||
additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) addDNF mAuthId route isWrite
|
||||
unless (is _Authorized additionalVal) $
|
||||
throwError additionalVal
|
||||
return Authorized
|
||||
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
|
||||
AdminHijackUserR cID -> exceptT return return $ do
|
||||
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
@ -714,27 +747,21 @@ tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorize
|
||||
tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
|
||||
|
||||
|
||||
newtype InvalidAuthTag = InvalidAuthTag Text
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
instance Exception InvalidAuthTag
|
||||
defaultAuthDNF :: AuthDNF
|
||||
defaultAuthDNF = PredDNF $ Set.fromList
|
||||
[ impureNonNull . Set.singleton $ PLVariable AuthAdmin
|
||||
, impureNonNull . Set.singleton $ PLVariable AuthToken
|
||||
]
|
||||
|
||||
type DNF a = Set (NonNull (Set a))
|
||||
|
||||
data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
instance Universe SessionAuthTags
|
||||
instance Finite SessionAuthTags
|
||||
nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
|
||||
|
||||
routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
|
||||
routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
|
||||
-- ^ DNF up to entailment:
|
||||
--
|
||||
-- > (A_1 && A_2 && ...) OR' B OR' ...
|
||||
--
|
||||
-- > A OR' B := ((A |- B) ==> A) && (A || B)
|
||||
routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs
|
||||
routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
|
||||
where
|
||||
partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
|
||||
partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
|
||||
partition' prev t
|
||||
| Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
|
||||
= if
|
||||
@ -745,9 +772,9 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p
|
||||
| otherwise
|
||||
= Left $ InvalidAuthTag t
|
||||
|
||||
evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
|
||||
evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
|
||||
-- ^ `tell`s disabled predicates, identified as pivots
|
||||
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) mAuthId route isWrite
|
||||
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite
|
||||
= do
|
||||
mr <- getMsgRenderer
|
||||
let
|
||||
@ -760,23 +787,31 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toN
|
||||
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
|
||||
evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
|
||||
|
||||
evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
|
||||
evalAuthLiteral PLVariable{..} = evalAuthTag plVar
|
||||
evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case
|
||||
Unauthorized _ -> return Authorized
|
||||
AuthenticationRequired -> return AuthenticationRequired
|
||||
Authorized -> unauthorizedI plVar
|
||||
|
||||
orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
|
||||
orAR' = shortCircuitM (is _Authorized) (orAR mr)
|
||||
andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
|
||||
|
||||
evalDNF :: [[AuthTag]] -> WriterT (Set AuthTag) m AuthResult
|
||||
evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
|
||||
evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
|
||||
evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
|
||||
|
||||
$logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
|
||||
$logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive . plVar) authDNF
|
||||
|
||||
result <- evalDNF $ filter (all authTagIsActive) authDNF
|
||||
result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF
|
||||
|
||||
unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj ->
|
||||
whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
|
||||
let pivots = filter authTagIsInactive conj
|
||||
whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
|
||||
$logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
|
||||
tell $ Set.fromList pivots
|
||||
unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
|
||||
whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
|
||||
let pivots = filter (authTagIsInactive . plVar) conj
|
||||
whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
|
||||
let pivots' = plVar <$> pivots
|
||||
$logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
|
||||
tell $ Set.fromList pivots'
|
||||
|
||||
return result
|
||||
|
||||
|
||||
@ -13,6 +13,7 @@ instance PathPiece Jwt where
|
||||
toPathPiece (Jwt bytes) = decodeUtf8 bytes
|
||||
fromPathPiece = Just . Jwt . encodeUtf8
|
||||
|
||||
deriving instance Generic JwtError
|
||||
deriving instance Typeable JwtError
|
||||
|
||||
instance Exception JwtError
|
||||
|
||||
@ -3,28 +3,26 @@
|
||||
module Model.Token
|
||||
( BearerToken(..)
|
||||
, bearerToken
|
||||
, encodeToken, decodeToken
|
||||
, tokenToJSON, tokenParseJSON
|
||||
, encodeToken, BearerTokenException(..), decodeToken
|
||||
, tokenToJSON, tokenParseJSON, tokenParseJSON'
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Model
|
||||
import Settings
|
||||
import Utils (NTop(..))
|
||||
import Utils.Lens hiding ((.=))
|
||||
|
||||
import Yesod.Auth (AuthId)
|
||||
|
||||
-- import qualified Jose.Jwa as Jose
|
||||
import Jose.Jwk (JwkSet)
|
||||
-- import qualified Jose.Jwk as Jose
|
||||
import Jose.Jwt (Jwt, JwtError, IntDate(..))
|
||||
import qualified Jose.Jwa as Jose
|
||||
import Jose.Jwk (JwkSet(..))
|
||||
import Jose.Jwt (Jwt(..), IntDate(..))
|
||||
import qualified Jose.Jwt as Jose
|
||||
|
||||
import Jose.Jwt.Instances ()
|
||||
import Data.Aeson.Types.Instances ()
|
||||
|
||||
import qualified Crypto.Random as Crypto (MonadRandom)
|
||||
|
||||
import Data.HashSet (HashSet)
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
@ -32,6 +30,9 @@ import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Aeson.Types (Parser, (.:?), (.:))
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Types as JSON
|
||||
import qualified Data.Aeson.Parser as JSON
|
||||
import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
|
||||
import qualified Data.Aeson.Internal as JSON (iparse, formatError)
|
||||
|
||||
import CryptoID
|
||||
|
||||
@ -42,10 +43,10 @@ import Control.Monad.Random (MonadRandom(..))
|
||||
|
||||
|
||||
data BearerToken site = BearerToken
|
||||
{ tokenIdentifier :: TokenId
|
||||
, tokenAuthority :: AuthId site
|
||||
, tokenRoutes :: Maybe (HashSet (Route site))
|
||||
, tokenAddAuth :: AuthCNF
|
||||
{ tokenIdentifier :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
|
||||
, tokenAuthority :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
|
||||
, tokenRoutes :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
|
||||
, tokenAddAuth :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
|
||||
, tokenIssuedAt :: UTCTime
|
||||
, tokenIssuedBy :: InstanceId
|
||||
, tokenExpiresAt
|
||||
@ -73,10 +74,11 @@ tokenToJSON BearerToken{..} = do
|
||||
, jwtJti = Just $ toPathPiece tokenIdentifier
|
||||
}
|
||||
return . JSON.object $
|
||||
[ "authority" .= cID
|
||||
, "routes" .= tokenRoutes
|
||||
, "add-auth" .= tokenAddAuth
|
||||
] ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
|
||||
catMaybes [ Just $ "authority" .= cID
|
||||
, ("routes" .=) <$> tokenRoutes
|
||||
, ("add-auth" .=) <$> tokenAddAuth
|
||||
]
|
||||
++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
|
||||
|
||||
tokenParseJSON :: forall site.
|
||||
( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
|
||||
@ -90,7 +92,7 @@ tokenParseJSON v@(Object o) = do
|
||||
tokenAuthority <- decrypt tokenAuthority'
|
||||
|
||||
tokenRoutes <- lift $ o .:? "routes"
|
||||
tokenAddAuth <- lift $ o .: "add-auth"
|
||||
tokenAddAuth <- lift $ o .:? "add-auth"
|
||||
Jose.JwtClaims{..} <- lift $ parseJSON v
|
||||
|
||||
let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
|
||||
@ -104,6 +106,19 @@ tokenParseJSON v@(Object o) = do
|
||||
return BearerToken{..}
|
||||
tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
|
||||
|
||||
tokenParseJSON' :: forall m.
|
||||
( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
|
||||
, ParseRoute (HandlerSite m)
|
||||
, Hashable (Route (HandlerSite m))
|
||||
, MonadHandler m
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
)
|
||||
=> m (Value -> Parser (BearerToken (HandlerSite m)))
|
||||
tokenParseJSON' = do
|
||||
cidKey <- cryptoIDKey return
|
||||
return $ flip runReaderT cidKey . tokenParseJSON
|
||||
|
||||
|
||||
bearerToken :: forall m.
|
||||
( MonadHandler m
|
||||
@ -113,7 +128,7 @@ bearerToken :: forall m.
|
||||
)
|
||||
=> AuthId (HandlerSite m)
|
||||
-> Maybe (HashSet (Route (HandlerSite m)))
|
||||
-> AuthCNF
|
||||
-> Maybe AuthDNF
|
||||
-> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
|
||||
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
|
||||
-> m (BearerToken (HandlerSite m))
|
||||
@ -135,9 +150,12 @@ bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsA
|
||||
return BearerToken{..}
|
||||
|
||||
|
||||
jwtEncoding :: Jose.JwtEncoding
|
||||
jwtEncoding = Jose.JwsEncoding Jose.HS256
|
||||
|
||||
|
||||
encodeToken :: forall m.
|
||||
( Crypto.MonadRandom m
|
||||
, MonadHandler m
|
||||
( MonadHandler m
|
||||
, HasJSONWebKeySet (HandlerSite m) JwkSet
|
||||
, HasInstanceID (HandlerSite m) InstanceId
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) m
|
||||
@ -145,14 +163,43 @@ encodeToken :: forall m.
|
||||
)
|
||||
=> BearerToken (HandlerSite m) -> m Jwt
|
||||
encodeToken token = do
|
||||
_payload <- tokenToJSON token
|
||||
error "Not implemented"
|
||||
payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
|
||||
|
||||
|
||||
data BearerTokenException
|
||||
= BearerTokenJwtError Jose.JwtError
|
||||
| BearerTokenUnsecured
|
||||
| BearerTokenInvalidFormat String
|
||||
| BearerTokenExpired | BearerTokenNotStarted
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
instance Exception BearerTokenException
|
||||
|
||||
decodeToken :: forall m.
|
||||
( Crypto.MonadRandom m
|
||||
, MonadHandler m
|
||||
( MonadHandler m
|
||||
, HasJSONWebKeySet (HandlerSite m) JwkSet
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) m
|
||||
, HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCrypto m
|
||||
, MonadThrow m
|
||||
, ParseRoute (HandlerSite m)
|
||||
, Hashable (Route (HandlerSite m))
|
||||
)
|
||||
=> Jwt -> m (Either JwtError (BearerToken (HandlerSite m)))
|
||||
decodeToken = error "Not implemented"
|
||||
=> Jwt -> m (BearerToken (HandlerSite m))
|
||||
decodeToken (Jwt bs) = do
|
||||
JwkSet jwks <- getsYesod $ view jsonWebKeySet
|
||||
content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
|
||||
content' <- case content of
|
||||
Jose.Unsecured _ -> throwM BearerTokenUnsecured
|
||||
Jose.Jws (_header, payload) -> return payload
|
||||
Jose.Jwe (_header, payload) -> return payload
|
||||
parser <- tokenParseJSON'
|
||||
token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
|
||||
now <- liftIO getCurrentTime
|
||||
unless (NTop tokenExpiresAt > NTop (Just now)) $
|
||||
throwM BearerTokenExpired
|
||||
unless (tokenStartsAt <= Just now) $
|
||||
throwM BearerTokenNotStarted
|
||||
return token
|
||||
|
||||
@ -714,6 +714,7 @@ pseudonymFragments = folding
|
||||
|
||||
data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
|
||||
= AuthAdmin
|
||||
| AuthToken
|
||||
| AuthLecturer
|
||||
| AuthCorrector
|
||||
| AuthRegistered
|
||||
@ -786,28 +787,27 @@ deriveJSON defaultOptions
|
||||
, unwrapUnaryRecords = True
|
||||
} ''PredLiteral
|
||||
|
||||
instance PathPiece a => PathPiece (PredLiteral a) where
|
||||
toPathPiece PLVariable{..} = toPathPiece plVar
|
||||
toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
|
||||
|
||||
newtype PredCNF a = PredCNF (Set (NonNull (Set (PredLiteral a))))
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
fromPathPiece t = PLVariable <$> fromPathPiece t
|
||||
<|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
|
||||
|
||||
newtype PredDNF a = PredDNF (Set (NonNull (Set (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 (Ord a, ToJSON a) => ToJSON (PredCNF a) where
|
||||
toJSON = $(mkToJSON predNFAesonOptions ''PredCNF)
|
||||
instance (Ord a, FromJSON a) => FromJSON (PredCNF a) where
|
||||
parseJSON = $(mkParseJSON predNFAesonOptions ''PredCNF)
|
||||
|
||||
instance (Ord a, ToJSON a) => ToJSON (PredDNF a) where
|
||||
toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
|
||||
instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
|
||||
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
|
||||
|
||||
type AuthCNF = PredCNF AuthTag
|
||||
type AuthLiteral = PredLiteral AuthTag
|
||||
|
||||
type AuthDNF = PredDNF AuthTag
|
||||
|
||||
|
||||
|
||||
@ -490,6 +490,12 @@ maybeExceptT err act = lift act >>= maybe (throwE err) return
|
||||
maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
|
||||
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
|
||||
|
||||
maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
|
||||
maybeTExceptT err act = maybeExceptT err $ runMaybeT act
|
||||
|
||||
maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
|
||||
maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act
|
||||
|
||||
whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
|
||||
whenExceptT b err = when b $ throwE err
|
||||
|
||||
|
||||
@ -20,7 +20,7 @@ import Data.Universe
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
|
||||
data GlobalGetParam = GetReferer
|
||||
data GlobalGetParam = GetReferer | GetToken
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe GlobalGetParam
|
||||
@ -51,6 +51,7 @@ globalGetParamField ident Field{fieldParse} = runMaybeT $ do
|
||||
data GlobalPostParam = PostFormIdentifier
|
||||
| PostDeleteTarget
|
||||
| PostMassInputShape
|
||||
| PostToken
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
instance Universe GlobalPostParam
|
||||
|
||||
@ -68,6 +68,9 @@ instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
|
||||
put = Binary.put . toPathPiece
|
||||
get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
|
||||
|
||||
instance RenderRoute site => Hashable (Route site) where
|
||||
hashWithSalt s = hashWithSalt s . routeToPathPiece
|
||||
|
||||
|
||||
instance Monad FormResult where
|
||||
(FormSuccess a) >>= f = f a
|
||||
|
||||
@ -24,7 +24,7 @@ import qualified Data.ByteString as BS
|
||||
|
||||
import Data.Time
|
||||
|
||||
import Utils.Lens (review)
|
||||
import Utils.Lens (review, view)
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
|
||||
|
||||
@ -82,7 +82,7 @@ insertFile fileTitle = do
|
||||
|
||||
fillDb :: DB ()
|
||||
fillDb = do
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
|
||||
now <- liftIO getCurrentTime
|
||||
let
|
||||
insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user