{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Main (main) where
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,
notFound404, ok200)
import Network.Wai (Application,
Request (pathInfo, rawPathInfo),
ifRequest, responseLBS)
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.Biscuit (authorizeBiscuit',
getAuthorizedBiscuit,
getBiscuit, parseBiscuit,
parseOptionalBiscuit)
import Test.Hspec (around, describe, hspec, it,
shouldBe)
secretKey :: SecretKey
secretKey = fromMaybe (error "Failed parsing secret key") $ parseSecretKeyHex "ac40d48ac474b6d41a58cbb91facc6317e32afdc21edfe23b9967e9d07c039be"
otherSecretKey :: SecretKey
otherSecretKey = fromMaybe (error "Failed parsing secret key") $ parseSecretKeyHex "1b53545e9ca6d1368bb222cb4c2183aac3304d8a3d0fea53173bca82f57b95a8"
app :: Application
app =
let endpoint req sendResponse = case pathInfo req of
["protected", "optional"] ->
case getBiscuit req of
Just _ -> sendResponse $ responseLBS ok200 mempty mempty
Nothing -> sendResponse $ responseLBS ok200 mempty mempty
["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 = parseOptionalBiscuit (toPublic secretKey)
checkBiscuit' = parseBiscuit (toPublic secretKey)
checkBiscuit'' = authorizeBiscuit' (toPublic secretKey) $ \req ->
let path = decodeUtf8 $ rawPathInfo req
in pure [authorizer|allow if right({path});|]
isProtectedOptional = (== ["protected", "optional"]) . take 2 . pathInfo
isProtectedParsed = (== ["protected", "parsed"]) . take 2 . pathInfo
isProtectedAuthed = (== ["protected", "authed"]) . take 2 . pathInfo
in ifRequest isProtectedOptional checkBiscuit $
ifRequest isProtectedParsed checkBiscuit' $
ifRequest isProtectedAuthed checkBiscuit'' endpoint
withApp :: (Warp.Port -> IO ()) -> IO ()
withApp =
--testWithApplication makes sure the action is executed after the server has
-- started and is being properly shutdown.
-- exceptions thrown by the app are bubbled up to the test suite.
Warp.testWithApplication (pure app)
main :: IO ()
main = do
manager <- newManager defaultManagerSettings
hspec $
around withApp $
describe "biscuit wai middleware" $ 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 (optional)" $ do
it "accepts unauthenticated calls" $ \port -> do
req <- parseRequest $ "http://localhost:" <> show port
res <- httpLbs req manager
statusCode (responseStatus res) `shouldBe` 200
it "rejects gibberish tokens" $ \port -> do
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/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/parsed"
let withAuth = applyBearerAuth (serializeB64 goodToken) req
res <- httpLbs withAuth 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/parsed"
res <- httpLbs req manager
statusCode (responseStatus res) `shouldBe` 401
it "rejects gibberish tokens" $ \port -> do
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/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/parsed"
let withAuth = applyBearerAuth (serializeB64 goodToken) req
res <- httpLbs withAuth manager
statusCode (responseStatus res) `shouldBe` 200
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` 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