{-# LANGUAGE OverloadedStrings #-}
-- | This module defines the kinds of permissions used in icepeak and provides
-- functions checking for sufficient permissions for certain operations.
module AccessControl
       ( AccessMode (..)
       , AuthPath (..)
       , IcepeakClaim (..)
       , Path
       , allowEverything
       , accessModeToText
       , textToAccessMode
       , isAuthorizedByClaim
       ) where

import           Data.Aeson ((.:), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.List  as List
import           Data.Text  (Text)

import           Store      (Path)

-- * Claim datatypes

-- | Defines the structure of a JWT claim for Icepeak.
data IcepeakClaim = IcepeakClaim
  { IcepeakClaim -> [AuthPath]
icepeakClaimWhitelist :: [AuthPath]
    -- ^ The whitelist containing all authorizations.
  } deriving (ReadPrec [IcepeakClaim]
ReadPrec IcepeakClaim
Int -> ReadS IcepeakClaim
ReadS [IcepeakClaim]
(Int -> ReadS IcepeakClaim)
-> ReadS [IcepeakClaim]
-> ReadPrec IcepeakClaim
-> ReadPrec [IcepeakClaim]
-> Read IcepeakClaim
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IcepeakClaim]
$creadListPrec :: ReadPrec [IcepeakClaim]
readPrec :: ReadPrec IcepeakClaim
$creadPrec :: ReadPrec IcepeakClaim
readList :: ReadS [IcepeakClaim]
$creadList :: ReadS [IcepeakClaim]
readsPrec :: Int -> ReadS IcepeakClaim
$creadsPrec :: Int -> ReadS IcepeakClaim
Read, Int -> IcepeakClaim -> ShowS
[IcepeakClaim] -> ShowS
IcepeakClaim -> String
(Int -> IcepeakClaim -> ShowS)
-> (IcepeakClaim -> String)
-> ([IcepeakClaim] -> ShowS)
-> Show IcepeakClaim
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IcepeakClaim] -> ShowS
$cshowList :: [IcepeakClaim] -> ShowS
show :: IcepeakClaim -> String
$cshow :: IcepeakClaim -> String
showsPrec :: Int -> IcepeakClaim -> ShowS
$cshowsPrec :: Int -> IcepeakClaim -> ShowS
Show, IcepeakClaim -> IcepeakClaim -> Bool
(IcepeakClaim -> IcepeakClaim -> Bool)
-> (IcepeakClaim -> IcepeakClaim -> Bool) -> Eq IcepeakClaim
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IcepeakClaim -> IcepeakClaim -> Bool
$c/= :: IcepeakClaim -> IcepeakClaim -> Bool
== :: IcepeakClaim -> IcepeakClaim -> Bool
$c== :: IcepeakClaim -> IcepeakClaim -> Bool
Eq, Eq IcepeakClaim
Eq IcepeakClaim
-> (IcepeakClaim -> IcepeakClaim -> Ordering)
-> (IcepeakClaim -> IcepeakClaim -> Bool)
-> (IcepeakClaim -> IcepeakClaim -> Bool)
-> (IcepeakClaim -> IcepeakClaim -> Bool)
-> (IcepeakClaim -> IcepeakClaim -> Bool)
-> (IcepeakClaim -> IcepeakClaim -> IcepeakClaim)
-> (IcepeakClaim -> IcepeakClaim -> IcepeakClaim)
-> Ord IcepeakClaim
IcepeakClaim -> IcepeakClaim -> Bool
IcepeakClaim -> IcepeakClaim -> Ordering
IcepeakClaim -> IcepeakClaim -> IcepeakClaim
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IcepeakClaim -> IcepeakClaim -> IcepeakClaim
$cmin :: IcepeakClaim -> IcepeakClaim -> IcepeakClaim
max :: IcepeakClaim -> IcepeakClaim -> IcepeakClaim
$cmax :: IcepeakClaim -> IcepeakClaim -> IcepeakClaim
>= :: IcepeakClaim -> IcepeakClaim -> Bool
$c>= :: IcepeakClaim -> IcepeakClaim -> Bool
> :: IcepeakClaim -> IcepeakClaim -> Bool
$c> :: IcepeakClaim -> IcepeakClaim -> Bool
<= :: IcepeakClaim -> IcepeakClaim -> Bool
$c<= :: IcepeakClaim -> IcepeakClaim -> Bool
< :: IcepeakClaim -> IcepeakClaim -> Bool
$c< :: IcepeakClaim -> IcepeakClaim -> Bool
compare :: IcepeakClaim -> IcepeakClaim -> Ordering
$ccompare :: IcepeakClaim -> IcepeakClaim -> Ordering
$cp1Ord :: Eq IcepeakClaim
Ord)

data AuthPath = AuthPath
  { AuthPath -> Path
authPathPrefix :: Path
    -- ^ The prefix of all the paths to which this authorization applies.
  , AuthPath -> [AccessMode]
authPathModes  :: [AccessMode]
    -- ^ The modes that are authorized on this path prefix.
  } deriving (ReadPrec [AuthPath]
ReadPrec AuthPath
Int -> ReadS AuthPath
ReadS [AuthPath]
(Int -> ReadS AuthPath)
-> ReadS [AuthPath]
-> ReadPrec AuthPath
-> ReadPrec [AuthPath]
-> Read AuthPath
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AuthPath]
$creadListPrec :: ReadPrec [AuthPath]
readPrec :: ReadPrec AuthPath
$creadPrec :: ReadPrec AuthPath
readList :: ReadS [AuthPath]
$creadList :: ReadS [AuthPath]
readsPrec :: Int -> ReadS AuthPath
$creadsPrec :: Int -> ReadS AuthPath
Read, Int -> AuthPath -> ShowS
[AuthPath] -> ShowS
AuthPath -> String
(Int -> AuthPath -> ShowS)
-> (AuthPath -> String) -> ([AuthPath] -> ShowS) -> Show AuthPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthPath] -> ShowS
$cshowList :: [AuthPath] -> ShowS
show :: AuthPath -> String
$cshow :: AuthPath -> String
showsPrec :: Int -> AuthPath -> ShowS
$cshowsPrec :: Int -> AuthPath -> ShowS
Show, AuthPath -> AuthPath -> Bool
(AuthPath -> AuthPath -> Bool)
-> (AuthPath -> AuthPath -> Bool) -> Eq AuthPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthPath -> AuthPath -> Bool
$c/= :: AuthPath -> AuthPath -> Bool
== :: AuthPath -> AuthPath -> Bool
$c== :: AuthPath -> AuthPath -> Bool
Eq, Eq AuthPath
Eq AuthPath
-> (AuthPath -> AuthPath -> Ordering)
-> (AuthPath -> AuthPath -> Bool)
-> (AuthPath -> AuthPath -> Bool)
-> (AuthPath -> AuthPath -> Bool)
-> (AuthPath -> AuthPath -> Bool)
-> (AuthPath -> AuthPath -> AuthPath)
-> (AuthPath -> AuthPath -> AuthPath)
-> Ord AuthPath
AuthPath -> AuthPath -> Bool
AuthPath -> AuthPath -> Ordering
AuthPath -> AuthPath -> AuthPath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AuthPath -> AuthPath -> AuthPath
$cmin :: AuthPath -> AuthPath -> AuthPath
max :: AuthPath -> AuthPath -> AuthPath
$cmax :: AuthPath -> AuthPath -> AuthPath
>= :: AuthPath -> AuthPath -> Bool
$c>= :: AuthPath -> AuthPath -> Bool
> :: AuthPath -> AuthPath -> Bool
$c> :: AuthPath -> AuthPath -> Bool
<= :: AuthPath -> AuthPath -> Bool
$c<= :: AuthPath -> AuthPath -> Bool
< :: AuthPath -> AuthPath -> Bool
$c< :: AuthPath -> AuthPath -> Bool
compare :: AuthPath -> AuthPath -> Ordering
$ccompare :: AuthPath -> AuthPath -> Ordering
$cp1Ord :: Eq AuthPath
Ord)

-- | Different modes for accessing the JSON store
data AccessMode = ModeRead | ModeWrite
  deriving (ReadPrec [AccessMode]
ReadPrec AccessMode
Int -> ReadS AccessMode
ReadS [AccessMode]
(Int -> ReadS AccessMode)
-> ReadS [AccessMode]
-> ReadPrec AccessMode
-> ReadPrec [AccessMode]
-> Read AccessMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AccessMode]
$creadListPrec :: ReadPrec [AccessMode]
readPrec :: ReadPrec AccessMode
$creadPrec :: ReadPrec AccessMode
readList :: ReadS [AccessMode]
$creadList :: ReadS [AccessMode]
readsPrec :: Int -> ReadS AccessMode
$creadsPrec :: Int -> ReadS AccessMode
Read, Int -> AccessMode -> ShowS
[AccessMode] -> ShowS
AccessMode -> String
(Int -> AccessMode -> ShowS)
-> (AccessMode -> String)
-> ([AccessMode] -> ShowS)
-> Show AccessMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccessMode] -> ShowS
$cshowList :: [AccessMode] -> ShowS
show :: AccessMode -> String
$cshow :: AccessMode -> String
showsPrec :: Int -> AccessMode -> ShowS
$cshowsPrec :: Int -> AccessMode -> ShowS
Show, AccessMode -> AccessMode -> Bool
(AccessMode -> AccessMode -> Bool)
-> (AccessMode -> AccessMode -> Bool) -> Eq AccessMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AccessMode -> AccessMode -> Bool
$c/= :: AccessMode -> AccessMode -> Bool
== :: AccessMode -> AccessMode -> Bool
$c== :: AccessMode -> AccessMode -> Bool
Eq, Eq AccessMode
Eq AccessMode
-> (AccessMode -> AccessMode -> Ordering)
-> (AccessMode -> AccessMode -> Bool)
-> (AccessMode -> AccessMode -> Bool)
-> (AccessMode -> AccessMode -> Bool)
-> (AccessMode -> AccessMode -> Bool)
-> (AccessMode -> AccessMode -> AccessMode)
-> (AccessMode -> AccessMode -> AccessMode)
-> Ord AccessMode
AccessMode -> AccessMode -> Bool
AccessMode -> AccessMode -> Ordering
AccessMode -> AccessMode -> AccessMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AccessMode -> AccessMode -> AccessMode
$cmin :: AccessMode -> AccessMode -> AccessMode
max :: AccessMode -> AccessMode -> AccessMode
$cmax :: AccessMode -> AccessMode -> AccessMode
>= :: AccessMode -> AccessMode -> Bool
$c>= :: AccessMode -> AccessMode -> Bool
> :: AccessMode -> AccessMode -> Bool
$c> :: AccessMode -> AccessMode -> Bool
<= :: AccessMode -> AccessMode -> Bool
$c<= :: AccessMode -> AccessMode -> Bool
< :: AccessMode -> AccessMode -> Bool
$c< :: AccessMode -> AccessMode -> Bool
compare :: AccessMode -> AccessMode -> Ordering
$ccompare :: AccessMode -> AccessMode -> Ordering
$cp1Ord :: Eq AccessMode
Ord, Int -> AccessMode
AccessMode -> Int
AccessMode -> [AccessMode]
AccessMode -> AccessMode
AccessMode -> AccessMode -> [AccessMode]
AccessMode -> AccessMode -> AccessMode -> [AccessMode]
(AccessMode -> AccessMode)
-> (AccessMode -> AccessMode)
-> (Int -> AccessMode)
-> (AccessMode -> Int)
-> (AccessMode -> [AccessMode])
-> (AccessMode -> AccessMode -> [AccessMode])
-> (AccessMode -> AccessMode -> [AccessMode])
-> (AccessMode -> AccessMode -> AccessMode -> [AccessMode])
-> Enum AccessMode
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: AccessMode -> AccessMode -> AccessMode -> [AccessMode]
$cenumFromThenTo :: AccessMode -> AccessMode -> AccessMode -> [AccessMode]
enumFromTo :: AccessMode -> AccessMode -> [AccessMode]
$cenumFromTo :: AccessMode -> AccessMode -> [AccessMode]
enumFromThen :: AccessMode -> AccessMode -> [AccessMode]
$cenumFromThen :: AccessMode -> AccessMode -> [AccessMode]
enumFrom :: AccessMode -> [AccessMode]
$cenumFrom :: AccessMode -> [AccessMode]
fromEnum :: AccessMode -> Int
$cfromEnum :: AccessMode -> Int
toEnum :: Int -> AccessMode
$ctoEnum :: Int -> AccessMode
pred :: AccessMode -> AccessMode
$cpred :: AccessMode -> AccessMode
succ :: AccessMode -> AccessMode
$csucc :: AccessMode -> AccessMode
Enum, AccessMode
AccessMode -> AccessMode -> Bounded AccessMode
forall a. a -> a -> Bounded a
maxBound :: AccessMode
$cmaxBound :: AccessMode
minBound :: AccessMode
$cminBound :: AccessMode
Bounded)


-- | A claim that allows all operations.
allowEverything :: IcepeakClaim
allowEverything :: IcepeakClaim
allowEverything = [AuthPath] -> IcepeakClaim
IcepeakClaim [Path -> [AccessMode] -> AuthPath
AuthPath [] [AccessMode
forall a. Bounded a => a
minBound..AccessMode
forall a. Bounded a => a
maxBound]]

-- * Authorization

-- | Check whether accessing the given path with the given mode is authorized by
-- the supplied claim.
isAuthorizedByClaim :: IcepeakClaim -> Path -> AccessMode -> Bool
isAuthorizedByClaim :: IcepeakClaim -> Path -> AccessMode -> Bool
isAuthorizedByClaim IcepeakClaim
claim Path
path AccessMode
mode = (AuthPath -> Bool) -> [AuthPath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any AuthPath -> Bool
allows (IcepeakClaim -> [AuthPath]
icepeakClaimWhitelist IcepeakClaim
claim) where
  allows :: AuthPath -> Bool
allows (AuthPath Path
prefix [AccessMode]
modes) = Path -> Path -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf Path
prefix Path
path Bool -> Bool -> Bool
&& AccessMode
mode AccessMode -> [AccessMode] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AccessMode]
modes


-- * JSON encoding and decoding

accessModeToText :: AccessMode -> Text
accessModeToText :: AccessMode -> Text
accessModeToText AccessMode
mode = case AccessMode
mode of
    AccessMode
ModeRead  -> Text
"read"
    AccessMode
ModeWrite -> Text
"write"

textToAccessMode :: Text -> Maybe AccessMode
textToAccessMode :: Text -> Maybe AccessMode
textToAccessMode Text
mode
  | Text
mode Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"read" = AccessMode -> Maybe AccessMode
forall a. a -> Maybe a
Just AccessMode
ModeRead
  | Text
mode Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"write" = AccessMode -> Maybe AccessMode
forall a. a -> Maybe a
Just AccessMode
ModeWrite
  | Bool
otherwise = Maybe AccessMode
forall a. Maybe a
Nothing

instance Aeson.ToJSON AccessMode where
  toJSON :: AccessMode -> Value
toJSON = Text -> Value
Aeson.String (Text -> Value) -> (AccessMode -> Text) -> AccessMode -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessMode -> Text
accessModeToText

instance Aeson.FromJSON AccessMode where
  parseJSON :: Value -> Parser AccessMode
parseJSON = String -> (Text -> Parser AccessMode) -> Value -> Parser AccessMode
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"mode string" ((Text -> Parser AccessMode) -> Value -> Parser AccessMode)
-> (Text -> Parser AccessMode) -> Value -> Parser AccessMode
forall a b. (a -> b) -> a -> b
$ \Text
txt -> case Text -> Maybe AccessMode
textToAccessMode Text
txt of
    Maybe AccessMode
Nothing -> String -> Parser AccessMode
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid mode value."
    Just AccessMode
m  -> AccessMode -> Parser AccessMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure AccessMode
m

instance Aeson.ToJSON AuthPath where
  toJSON :: AuthPath -> Value
toJSON (AuthPath Path
prefix [AccessMode]
modes) = [Pair] -> Value
Aeson.object
    [ Text
"prefix" Text -> Path -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Path
prefix
    , Text
"modes" Text -> [AccessMode] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [AccessMode]
modes ]

instance Aeson.FromJSON AuthPath where
  parseJSON :: Value -> Parser AuthPath
parseJSON = String -> (Object -> Parser AuthPath) -> Value -> Parser AuthPath
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"path and modes" ((Object -> Parser AuthPath) -> Value -> Parser AuthPath)
-> (Object -> Parser AuthPath) -> Value -> Parser AuthPath
forall a b. (a -> b) -> a -> b
$ \Object
v -> Path -> [AccessMode] -> AuthPath
AuthPath
    (Path -> [AccessMode] -> AuthPath)
-> Parser Path -> Parser ([AccessMode] -> AuthPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Path
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"prefix"
    Parser ([AccessMode] -> AuthPath)
-> Parser [AccessMode] -> Parser AuthPath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser [AccessMode]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"modes"

instance Aeson.ToJSON IcepeakClaim where
  toJSON :: IcepeakClaim -> Value
toJSON IcepeakClaim
claim = [Pair] -> Value
Aeson.object
    [ Text
"version"   Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Int
1 :: Int)
    , Text
"whitelist" Text -> [AuthPath] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= IcepeakClaim -> [AuthPath]
icepeakClaimWhitelist IcepeakClaim
claim
    ]

instance Aeson.FromJSON IcepeakClaim where
  parseJSON :: Value -> Parser IcepeakClaim
parseJSON = String
-> (Object -> Parser IcepeakClaim) -> Value -> Parser IcepeakClaim
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"icepeak claim" ((Object -> Parser IcepeakClaim) -> Value -> Parser IcepeakClaim)
-> (Object -> Parser IcepeakClaim) -> Value -> Parser IcepeakClaim
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    Int
version <- Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"version"
    if Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1 :: Int)
      then [AuthPath] -> IcepeakClaim
IcepeakClaim ([AuthPath] -> IcepeakClaim)
-> Parser [AuthPath] -> Parser IcepeakClaim
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser [AuthPath]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"whitelist"
      else String -> Parser IcepeakClaim
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unsupported version"