biscuit-wai: allow authorizing tokens within the middleware

biscuit-wai/biscuit-wai.cabal

@@ -54,6 +54,7 @@ test-suite biscuit-wai-test
     , hspec
     , http-client
     , http-types
+    , text
     , wai
     , warp
   default-language: Haskell2010

biscuit-wai/src/Network/Wai/Middleware/Biscuit.hs

@@ -1,10 +1,20 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Network.Wai.Middleware.Biscuit (parseBiscuit, getBiscuit) where
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE OverloadedStrings     #-}
+module Network.Wai.Middleware.Biscuit
+  ( parseBiscuit
+  , parseBiscuitWith
+  , authorizeBiscuit'
+  , authorizeBiscuitWith
+  , getBiscuit
+  , getAuthorizedBiscuit
+  ) where
 
-import           Auth.Biscuit       (Biscuit, OpenOrSealed, ParseError,
-                                     PublicKey, Verified, parseB64)
+import           Auth.Biscuit       (AuthorizedBiscuit, Authorizer, Biscuit,
+                                     ExecutionError, OpenOrSealed, ParseError,
+                                     PublicKey, Verified, authorizeBiscuit,
+                                     parseB64)
 import           Control.Monad      ((<=<))
 import           Data.Bifunctor     (first)
 import           Data.ByteString    (ByteString)
@@ -22,9 +32,16 @@ import           Network.Wai        (Middleware, Request (..), Response,
 biscuitKey :: Vault.Key (Biscuit OpenOrSealed Verified)
 biscuitKey = unsafePerformIO Vault.newKey
 
+{-# NOINLINE  authorizedBiscuitKey #-}
+authorizedBiscuitKey :: Vault.Key (AuthorizedBiscuit OpenOrSealed)
+authorizedBiscuitKey = unsafePerformIO Vault.newKey
+
 getBiscuit :: Request -> Maybe (Biscuit OpenOrSealed Verified)
 getBiscuit = Vault.lookup biscuitKey . vault
 
+getAuthorizedBiscuit :: Request -> Maybe (AuthorizedBiscuit OpenOrSealed)
+getAuthorizedBiscuit = Vault.lookup authorizedBiscuitKey . vault
+
 parseBiscuit :: PublicKey -> Middleware
 parseBiscuit = parseBiscuitWith . defaultExtractionConfig
 
@@ -38,16 +55,39 @@ parseBiscuitWith config app req sendResponse = do
   eBiscuit <- either (pure . Left) parseToken =<< extractToken req
   either onError forward eBiscuit
 
+authorizeBiscuit' :: PublicKey -> (Request -> IO Authorizer) -> Middleware
+authorizeBiscuit' publicKey = authorizeBiscuitWith . defaultAuthorizationConfig publicKey
+
+authorizeBiscuitWith :: AuthorizationConfig e -> Middleware
+authorizeBiscuitWith config app req sendResponse = do
+  let AuthorizationConfig{extractToken,parseToken,authorizeToken,handleError} = config
+      onError = sendResponse <=< handleError
+      forward t = do
+         let newVault = Vault.insert authorizedBiscuitKey t (vault req)
+         app req { vault = newVault } sendResponse
+  eBiscuit <- either (pure . Left) parseToken =<< extractToken req
+  eResult <- either (pure . Left) (authorizeToken req) eBiscuit
+  either onError forward eResult
+
 data ExtractionConfig e
   = ExtractionConfig
   { extractToken :: Request -> IO (Either e ByteString)
   , parseToken   :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
   , handleError  :: e -> IO Response
   }
 
+data AuthorizationConfig e
+  = AuthorizationConfig
+  { extractToken :: Request -> IO (Either e ByteString)
+  , parseToken   :: ByteString -> IO (Either e (Biscuit OpenOrSealed Verified))
+  , authorizeToken :: Request -> Biscuit OpenOrSealed Verified -> IO (Either e (AuthorizedBiscuit OpenOrSealed))
+  , handleError  :: e -> IO Response
+  }
+
 data BiscuitError
   = NoToken
   | ParseError ParseError
+  | AuthorizationError ExecutionError
 
 defaultExtractionConfig :: PublicKey -> ExtractionConfig BiscuitError
 defaultExtractionConfig publicKey = ExtractionConfig
@@ -56,6 +96,14 @@ defaultExtractionConfig publicKey = ExtractionConfig
   , handleError = defaultHandleError
   }
 
+defaultAuthorizationConfig :: PublicKey -> (Request -> IO Authorizer) -> AuthorizationConfig BiscuitError
+defaultAuthorizationConfig publicKey mkAuthorizer = AuthorizationConfig
+  { extractToken = pure . maybe (Left NoToken) Right . defaultExtractToken
+  , parseToken = pure . Data.Bifunctor.first ParseError . parseB64 publicKey
+  , authorizeToken = \req token -> first AuthorizationError <$> (authorizeBiscuit token =<< mkAuthorizer req)
+  , handleError = defaultHandleError
+  }
+
 defaultExtractToken :: Request -> Maybe ByteString
 defaultExtractToken req = do
   (_, authHeader) <- List.find ((== hAuthorization) . fst) $ requestHeaders req
@@ -69,3 +117,6 @@ defaultHandleError = \case
   ParseError e -> do
     putStrLn $ "Parsing or verification error: " <> show e
     pure $ responseLBS forbidden403 mempty mempty
+  AuthorizationError e -> do
+    putStrLn $ "Authorization error: " <> show e
+    pure $ responseLBS forbidden403 mempty mempty

biscuit-wai/test/Spec.hs

@@ -1,22 +1,26 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
 module Main (main) where
 
-import           Auth.Biscuit                   (SecretKey, mkBiscuit,
-                                                 parseSecretKeyHex,
+import           Auth.Biscuit                   (SecretKey, authorizer, block,
+                                                 mkBiscuit, parseSecretKeyHex,
                                                  serializeB64, toPublic)
 import           Data.Maybe                     (fromMaybe)
+import           Data.Text.Encoding             (decodeUtf8)
 import           Network.HTTP.Client            (Response (responseStatus),
                                                  applyBearerAuth,
                                                  defaultManagerSettings,
                                                  httpLbs, newManager,
                                                  parseRequest)
 import           Network.HTTP.Types             (Status (..), badRequest400,
-                                                 ok200)
+                                                 notFound404, ok200)
 import           Network.Wai                    (Application,
-                                                 Request (pathInfo), ifRequest,
-                                                 responseLBS)
+                                                 Request (pathInfo, rawPathInfo),
+                                                 ifRequest, responseLBS)
 import qualified Network.Wai.Handler.Warp       as Warp
-import           Network.Wai.Middleware.Biscuit (getBiscuit, parseBiscuit)
+import           Network.Wai.Middleware.Biscuit (authorizeBiscuit',
+                                                 getAuthorizedBiscuit,
+                                                 getBiscuit, parseBiscuit)
 import           Test.Hspec                     (around, describe, hspec, it,
                                                  shouldBe)
 
@@ -28,12 +32,25 @@ otherSecretKey = fromMaybe (error "Failed parsing secret key") $ parseSecretKeyH
 
 app :: Application
 app =
-  let endpoint req sendResponse = case getBiscuit req of
-        Just _  -> sendResponse $ responseLBS ok200 mempty mempty
-        Nothing -> sendResponse $ responseLBS badRequest400 mempty mempty
+  let endpoint req sendResponse = case pathInfo req of
+        ["protected", "parsed"] ->
+          case getBiscuit req of
+            Just _  -> sendResponse $ responseLBS ok200 mempty mempty
+            Nothing -> sendResponse $ responseLBS badRequest400 mempty mempty
+        ["protected", "authed"] ->
+          case getAuthorizedBiscuit req of
+            Just _  -> sendResponse $ responseLBS ok200 mempty mempty
+            Nothing -> sendResponse $ responseLBS badRequest400 mempty mempty
+        [] -> sendResponse $ responseLBS ok200 mempty mempty
+        _ -> sendResponse $ responseLBS notFound404 mempty mempty
       checkBiscuit = parseBiscuit (toPublic secretKey)
-      isProtected = (== ["protected"]) . take 1 . pathInfo
-   in ifRequest isProtected checkBiscuit endpoint
+      checkBiscuit' = authorizeBiscuit' (toPublic secretKey) $ \req ->
+        let path = decodeUtf8 $ rawPathInfo req
+         in pure [authorizer|allow if right({path});|]
+      isProtectedParsed = (== ["protected", "parsed"]) . take 2 . pathInfo
+      isProtectedAuthed = (== ["protected", "authed"]) . take 2 . pathInfo
+   in ifRequest isProtectedParsed checkBiscuit $
+        ifRequest isProtectedAuthed checkBiscuit' endpoint
 
 withApp :: (Warp.Port -> IO ()) -> IO ()
 withApp =
@@ -48,30 +65,58 @@ main = do
   hspec $
     around withApp $
       describe "biscuit wai middleware" $ do
-        describe "on protected endpoints" $ do
+        describe "on open endpoints" $ do
+          it "accepts unauthenticated calls" $ \port -> do
+            req <- parseRequest $ "http://localhost:" <> show port
+            res <- httpLbs req manager
+            statusCode (responseStatus res) `shouldBe` 200
+        describe "on protected endpoints (parsing)" $ do
           it "rejects unauthenticated calls" $ \port -> do
-            req <- parseRequest $ "http://localhost:" <> show port <> "/protected"
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/parsed"
             res <- httpLbs req manager
             statusCode (responseStatus res) `shouldBe` 401
           it "rejects gibberish tokens" $ \port -> do
-            req <- parseRequest $ "http://localhost:" <> show port <> "/protected"
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/parsed"
             let withAuth = applyBearerAuth "whatevs" req
             res <- httpLbs withAuth manager
             statusCode (responseStatus res) `shouldBe` 403
           it "rejects tokens signed by the wrong keypair" $ \port -> do
             badToken <- mkBiscuit otherSecretKey mempty
-            req <- parseRequest $ "http://localhost:" <> show port <> "/protected"
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/parsed"
             let withAuth = applyBearerAuth (serializeB64 badToken) req
             res <- httpLbs withAuth manager
             statusCode (responseStatus res) `shouldBe` 403
           it "accepts properly signed tokens" $ \port -> do
             goodToken <- mkBiscuit secretKey mempty
-            req <- parseRequest $ "http://localhost:" <> show port <> "/protected"
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/parsed"
             let withAuth = applyBearerAuth (serializeB64 goodToken) req
             res <- httpLbs withAuth manager
             statusCode (responseStatus res) `shouldBe` 200
-        describe "on open endpoints" $ do
-          it "accepts unauthenticated calls, but doesn't provide a parsed token" $ \port -> do
-            req <- parseRequest $ "http://localhost:" <> show port
+        describe "on protected endpoints (auth)" $ do
+          it "rejects unauthenticated calls" $ \port -> do
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed"
             res <- httpLbs req manager
-            statusCode (responseStatus res) `shouldBe` 400
+            statusCode (responseStatus res) `shouldBe` 401
+          it "rejects gibberish tokens" $ \port -> do
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed"
+            let withAuth = applyBearerAuth "whatevs" req
+            res <- httpLbs withAuth manager
+            statusCode (responseStatus res) `shouldBe` 403
+          it "rejects tokens signed by the wrong keypair" $ \port -> do
+            badToken <- mkBiscuit otherSecretKey mempty
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed"
+            let withAuth = applyBearerAuth (serializeB64 badToken) req
+            res <- httpLbs withAuth manager
+            statusCode (responseStatus res) `shouldBe` 403
+          it "rejects properly signed tokens which fail authorization" $ \port -> do
+            badToken <- mkBiscuit secretKey mempty
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed"
+            let withAuth = applyBearerAuth (serializeB64 badToken) req
+            res <- httpLbs withAuth manager
+            statusCode (responseStatus res) `shouldBe` 403
+          it "accepts properly signed tokens which succeed authorization" $ \port -> do
+            goodToken <- mkBiscuit secretKey [block|right("/protected/authed");|]
+            req <- parseRequest $ "http://localhost:" <> show port <> "/protected/authed"
+            let withAuth = applyBearerAuth (serializeB64 goodToken) req
+            res <- httpLbs withAuth manager
+            statusCode (responseStatus res) `shouldBe` 200