Skip to content

Commit

Permalink
servant: update library and examples for biscuit v2
Browse files Browse the repository at this point in the history
  • Loading branch information
divarvel committed Sep 7, 2021
1 parent 872da70 commit 5b7dc59
Showing 4 changed files with 57 additions and 61 deletions.
58 changes: 26 additions & 32 deletions biscuit-servant/src/Auth/Biscuit/Servant.hs
Original file line number Diff line number Diff line change
@@ -33,11 +33,8 @@ module Auth.Biscuit.Servant
, withPriorityVerifierM
) where

import Auth.Biscuit (Biscuit, PublicKey,
ValidBiscuit, Verifier,
checkBiscuitSignature,
parseB64, validBiscuit,
verifyValidBiscuit)
import Auth.Biscuit (Biscuit, PublicKey, Verifier,
parseB64, verifyBiscuit)
import Control.Applicative (liftA2)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -80,7 +77,7 @@ import Servant.Server.Experimental.Auth
-- > -- and parsed using 'parsePublicKeyHex' for instance.
-- > server
-- >
-- > server :: Server API -- ValidBiscuit -> Server ProtectedAPI
-- > server :: Server API -- Biscuit -> Server ProtectedAPI
-- > server biscuit = … -- this will be detailed later
--
-- This will instruct servant to extract the biscuit from the requests and
@@ -89,7 +86,7 @@ import Servant.Server.Experimental.Auth
--
-- $singleEndpointVerifier
--
-- The corresponding @Server API@ value will be a @ValidBiscuit -> Server ProtectedAPI@.
-- The corresponding @Server API@ value will be a @Biscuit -> Server ProtectedAPI@.
-- The next step is to provide a 'Verifier' so that the biscuit datalog can be
-- verified. For that, you can use 'checkBiscuit' (or 'checkBiscuitM').
--
@@ -98,22 +95,22 @@ import Servant.Server.Experimental.Auth
-- > :<|> h2 biscuit
-- > :<|> h3 biscuit
-- >
-- > h1 :: ValidBiscuit -> Handler Int
-- > h1 :: Biscuit -> Handler Int
-- > h1 biscuit =
-- > checkBiscuit biscuit
-- > [verifier|allow if right(#authority,#one);|]
-- > -- ^ only allow biscuits granting access to the endpoint tagged `#one`
-- > (pure 1)
-- >
-- > h2 :: ValidBiscuit -> Int -> Handler Int
-- > h2 :: Biscuit -> Int -> Handler Int
-- > h2 biscuit value =
-- > checkBiscuit biscuit
-- > [verifier|allow if right(#authority,#two, ${value});|]
-- > -- ^ only allow biscuits granting access to the endpoint tagged `#two`
-- > -- AND for the provided int value.
-- > (pure 2)
-- >
-- > h3 :: ValidBiscuit -> Handler Int
-- > h3 :: Biscuit -> Handler Int
-- > h3 biscuit =
-- > checkBiscuit biscuit
-- > [verifier|deny if true;|]
@@ -177,7 +174,7 @@ import Servant.Server.Experimental.Auth
-- be performed separately with either 'checkBiscuit' (for simple
-- use-cases) or 'handleBiscuit' (for more complex use-cases).
type RequireBiscuit = AuthProtect "biscuit"
type instance AuthServerData RequireBiscuit = ValidBiscuit
type instance AuthServerData RequireBiscuit = Biscuit

-- | Wrapper for a servant handler, equipped with a biscuit 'Verifier'
-- that will be used to authorize the request. If the authorization
@@ -336,34 +333,31 @@ noVerifier_ = noVerifier . lift
-- - the biscuit is b64-encoded
-- - prefixed with the @Bearer @ string
-- - in the @Authorization@ header
extractBiscuit :: Request -> Either String Biscuit
extractBiscuit req = do
extractBiscuit :: PublicKey -> Request -> Either String Biscuit
extractBiscuit pk req = do
let note e = maybe (Left e) Right
authHeader <- note "Missing Authorization header" . lookup "Authorization" $ requestHeaders req
b64Token <- note "Not a Bearer token" $ BS.stripPrefix "Bearer " authHeader
first (const "Not a B64-encoded biscuit") $ parseB64 b64Token
first (const "Not a B64-encoded biscuit") $ parseB64 pk b64Token

-- | Servant authorization handler. This extracts the biscuit from the request,
-- checks its signature (but not the datalog part) and returns a 'ValidBiscuit'
-- checks its signature (but not the datalog part) and returns a 'Biscuit'
-- upon success.
authHandler :: PublicKey -> AuthHandler Request ValidBiscuit
authHandler :: PublicKey -> AuthHandler Request Biscuit
authHandler publicKey = mkAuthHandler handler
where
authError s = err401 { errBody = LBS.fromStrict (C8.pack s) }
orError = either (throwError . authError) pure
handler req = do
biscuit <- orError $ extractBiscuit req
result <- liftIO $ checkBiscuitSignature biscuit publicKey
case result of
Nothing -> throwError $ authError "Invalid signature"
Just vb -> pure vb
biscuit <- orError $ extractBiscuit publicKey req
pure biscuit

-- | Helper function generating a servant context containing the authorization
-- handler.
genBiscuitCtx :: PublicKey -> Context '[AuthHandler Request ValidBiscuit]
genBiscuitCtx :: PublicKey -> Context '[AuthHandler Request Biscuit]
genBiscuitCtx pk = authHandler pk :. EmptyContext

-- | Given a 'ValidBiscuit' (provided by the servant authorization mechanism),
-- | Given a 'Biscuit' (provided by the servant authorization mechanism),
-- verify its validity (with the provided 'Verifier').
--
-- If you need to perform effects in the verification phase (eg to get the current time,
@@ -374,18 +368,18 @@ genBiscuitCtx pk = authHandler pk :. EmptyContext
-- (on endpoints), 'withFallbackVerifier' and 'withPriorityVerifier' (on API sub-trees)
-- and 'handleBiscuit' (on the whole API).
checkBiscuit :: (MonadIO m, MonadError ServerError m)
=> ValidBiscuit
=> Biscuit
-> Verifier
-> m a
-> m a
checkBiscuit vb v h = do
res <- liftIO $ verifyValidBiscuit vb v
res <- liftIO $ verifyBiscuit vb v
case res of
Left e -> do liftIO $ print e
throwError $ err401 { errBody = "Biscuit failed checks" }
Right _ -> h

-- | Given a 'ValidBiscuit' (provided by the servant authorization mechanism),
-- | Given a 'Biscuit' (provided by the servant authorization mechanism),
-- verify its validity (with the provided 'Verifier', which can be effectful).
--
-- If you don't need to run any effects in the verifying phase, you can use 'checkBiscuit'
@@ -396,13 +390,13 @@ checkBiscuit vb v h = do
-- 'withFallbackVerifier' and 'withPriorityVerifier' (on API sub-trees) and 'handleBiscuit'
-- (on the whole API).
checkBiscuitM :: (MonadIO m, MonadError ServerError m)
=> ValidBiscuit
=> Biscuit
-> m Verifier
-> m a
-> m a
checkBiscuitM vb mv h = do
v <- mv
res <- liftIO $ verifyValidBiscuit vb v
res <- liftIO $ verifyBiscuit vb v
case res of
Left e -> do liftIO $ print e
throwError $ err401 { errBody = "Biscuit failed checks" }
@@ -414,9 +408,9 @@ checkBiscuitM vb mv h = do
-- For simpler use cases, consider using 'checkBiscuit' instead, which works on regular
-- servant handlers.
handleBiscuit :: (MonadIO m, MonadError ServerError m)
=> ValidBiscuit
=> Biscuit
-> WithVerifier m a
-> m a
handleBiscuit vb WithVerifier{verifier_, handler_} =
let h = runReaderT handler_ (validBiscuit vb)
in checkBiscuitM vb verifier_ h
handleBiscuit b WithVerifier{verifier_, handler_} =
let h = runReaderT handler_ b
in checkBiscuitM b verifier_ h
10 changes: 5 additions & 5 deletions biscuit-servant/test/AppWithVerifier.hs
Original file line number Diff line number Diff line change
@@ -46,21 +46,21 @@ server :: Server API
server b =
let nowFact = do
now <- liftIO getCurrentTime
pure [verifier|now(#ambient, ${now});|]
pure [verifier|time(${now});|]
handleAuth :: WithVerifier Handler x -> Handler x
handleAuth =
handleBiscuit b
. withPriorityVerifierM nowFact
. withPriorityVerifier [verifier|allow if right(#authority, #admin);|]
. withFallbackVerifier [verifier|allow if right(#authority, #anon);|]
. withPriorityVerifier [verifier|allow if right("admin");|]
. withFallbackVerifier [verifier|allow if right("anon");|]
handlers = handler1 :<|> handler2 :<|> handler3
in hoistServer @ProtectedAPI Proxy handleAuth handlers

handler1 :: H Int
handler1 = withVerifier [verifier|allow if right(#authority, #one);|] $ pure 1
handler1 = withVerifier [verifier|allow if right("one");|] $ pure 1

handler2 :: Int -> H Int
handler2 v = withVerifier [verifier|allow if right(#authority, #two, ${v});|] $ pure 2
handler2 v = withVerifier [verifier|allow if right("two", ${v});|] $ pure 2

handler3 :: H Int
handler3 = withVerifier [verifier|deny if true;|] $ pure 3
45 changes: 22 additions & 23 deletions biscuit-servant/test/Spec.hs
Original file line number Diff line number Diff line change
@@ -18,17 +18,16 @@ import ClientHelpers (runC, withApp)

main :: IO ()
main = do
keypair <- fromPrivateKey appPrivateKey
let appPk = toPublic appSecretKey
later <- addUTCTime (60*5) <$> getCurrentTime
earlier <- addUTCTime (-60) <$> getCurrentTime
let appPk = publicKey keypair
adminB <- toText <$> mkAdminBiscuit keypair
anonB <- toText <$> mkAnonBiscuit keypair
e1 <- toText <$> mkE1Biscuit keypair
e21 <- toText <$> mkE2Biscuit 1 keypair
e22 <- toText <$> mkE2Biscuit 2 keypair
ttld <- toText <$> (addTtl later =<< mkAdminBiscuit keypair)
expd <- toText <$> (addTtl earlier =<< mkAdminBiscuit keypair)
adminB <- toText <$> mkAdminBiscuit appSecretKey
anonB <- toText <$> mkAnonBiscuit appSecretKey
e1 <- toText <$> mkE1Biscuit appSecretKey
e21 <- toText <$> mkE2Biscuit 1 appSecretKey
e22 <- toText <$> mkE2Biscuit 2 appSecretKey
ttld <- toText <$> (addTtl later =<< mkAdminBiscuit appSecretKey)
expd <- toText <$> (addTtl earlier =<< mkAdminBiscuit appSecretKey)
print adminB
hspec $
around (withApp $ app appPk) $
@@ -50,24 +49,24 @@ main = do
runC port (call1 ttld) `shouldReturn` Right 1
runC port (call1 expd) `shouldReturn` Left (Just "Biscuit failed checks")

appPrivateKey :: PrivateKey
appPrivateKey = fromJust . parsePrivateKeyHex $ "c2b7507af4f849fd028d0f7e90b04a4e74d9727b358fca18b65beffd86c47209"
appSecretKey :: SecretKey
appSecretKey = fromJust . parseSecretKeyHex $ "c2b7507af4f849fd028d0f7e90b04a4e74d9727b358fca18b65beffd86c47209"

toText :: Biscuit -> Text
toText = decodeUtf8 . serializeB64
toText :: OpenBiscuit -> Text
toText = decodeUtf8 . serializeB64 . fromOpen

mkAdminBiscuit :: Keypair -> IO Biscuit
mkAdminBiscuit kp = mkBiscuit kp [block|right(#authority, #admin);|]
mkAdminBiscuit :: SecretKey -> IO OpenBiscuit
mkAdminBiscuit sk = mkBiscuit sk [block|right("admin");|]

mkAnonBiscuit :: Keypair -> IO Biscuit
mkAnonBiscuit kp = mkBiscuit kp [block|right(#authority, #anon);|]
mkAnonBiscuit :: SecretKey -> IO OpenBiscuit
mkAnonBiscuit sk = mkBiscuit sk [block|right("anon");|]

mkE1Biscuit :: Keypair -> IO Biscuit
mkE1Biscuit kp = mkBiscuit kp [block|right(#authority, #one);|]
mkE1Biscuit :: SecretKey -> IO OpenBiscuit
mkE1Biscuit sk = mkBiscuit sk [block|right("one");|]

mkE2Biscuit :: Int -> Keypair -> IO Biscuit
mkE2Biscuit v kp = mkBiscuit kp [block|right(#authority, #two, ${v});|]
mkE2Biscuit :: Int -> SecretKey -> IO OpenBiscuit
mkE2Biscuit v sk = mkBiscuit sk [block|right("two", ${v});|]

addTtl :: UTCTime -> Biscuit -> IO Biscuit
addTtl :: UTCTime -> OpenBiscuit -> IO OpenBiscuit
addTtl expiration =
addBlock [block|check if now(#ambient,$now), $now < ${expiration};|]
addBlock [block|check if time($now), $now < ${expiration};|]
5 changes: 4 additions & 1 deletion biscuit/src/Auth/Biscuit.hs
Original file line number Diff line number Diff line change
@@ -36,6 +36,8 @@ module Auth.Biscuit
, fromOpen
, fromSealed
, Biscuit
, OpenBiscuit
, SealedBiscuit
, Block
-- ** Parsing and serializing biscuits
, serializeB64
@@ -70,7 +72,8 @@ import Auth.Biscuit.Datalog.AST (Block, Verifier, bContext)
import Auth.Biscuit.Datalog.Executor (ExecutionError (..),
Limits (..), defaultLimits)
import Auth.Biscuit.Datalog.Parser (block, verifier)
import Auth.Biscuit.Token2 (Biscuit, ParseError (..),
import Auth.Biscuit.Token2 (Biscuit, OpenBiscuit,
ParseError (..), SealedBiscuit,
addBlock, fromOpen, fromSealed,
mkBiscuit, parseBiscuit,
serializeBiscuit, verifyBiscuit,

0 comments on commit 5b7dc59

Please sign in to comment.