wai-hmac-auth (empty) → 1.0.0

raw patch · 7 files changed

+740/−0 lines, 7 filesdep +basedep +base64-bytestringdep +bifunctorssetup-changed

Dependencies added: base, base64-bytestring, bifunctors, byteable, bytestring, containers, cryptohash, hspec, http-types, monad-loops, mtl, transformers, wai, wai-extra, wai-hmac-auth

Files

• CHANGELOG.md +6/−0
• LICENSE +30/−0
• README.md +87/−0
• Setup.hs +2/−0
• src/Network/Wai/Auth/HMAC.hs +276/−0
• tests/tests.hs +272/−0
• wai-hmac-auth.cabal +67/−0

@@ -0,0 +1,6 @@+changelog+=========++1.0.0+-----+first release.

@@ -0,0 +1,30 @@+Copyright (c) 2014, aidan coyne++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of aidan coyne nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,87 @@+wai-hmac-auth [![Build Status](https://travis-ci.org/raptros/wai-hmac-auth.svg?branch=master)](https://travis-ci.org/raptros/wai-hmac-auth)+=============+this library provides functions for authenticating HMAC-signed requests in WAI+apps. in particular, it provides a function for extracting an api key from a+request according to configuration, and a function for verifying that a request+is correctly signed by a secret key, according to the configuration. it is+designed to be compatible with the Java library+[jersey-hmac-auth](https://github.com/bazaarvoice/jersey-hmac-auth), though+possibly more flexible.++how it signs+------------+the authenticate function (as well as the included signRequest function) in+effect extracts several elements from the request and concatentates them, and+hashes/signs the resulting value. i.e. it constructs the following value from+the request, and signs that value.++```+valueToSign = method + '\n' + +              timestamp + '\n' + +              (apiKey + '\n')? + +              path + ('?' + query) + '\n' ++              body+```++* the method is added directly from the request record.+* the header name used to get the timestamp value can be configured. note that+  for now, no validation is done on this value; it is only required to be+  present in the request.+* the api key is only included explicitly if the configuration specifies that+  the api key is in a header. otherwise (if the api key is in a query+  parameter), it will be included anyway.+* the value of the path is whatever the application receives in the request+  record. this means that e.g. if the application is run in the context of a+  CGI executable, this may not be the same path that the client made the+  request to. the client will have to account for this when generating the+  signature.+* the query string is rendered from the queryString using the http-types+  function renderQuery. the wai-hmac-auth library does not modify these values,+  but the values received by the app may depend on the server and the+  middleware. the client will have to account for this properly.+* the entire request body is read, which is why authenticate produces a Request+  value when successful - this Request value has a requestBody value that will+  produce the same chunk sequence as the input request value.++the authenticate function also extracts the configured signature header and+attempts to decode it as a base64 url-encoded hash digest value as produced by+the configured hash function. this represents two possible authentication+failures.++finally, the authenticate function compares the passed signature to the+signature it generated and fails if they do not match.++how to use+----------+there are basically four steps for using this in your app.++* set up the configuration for how requests to your app will be signed+* when a request comes in, use getApiKey with your spec to find out who the+  requester is claiming to be+* load up the secret key associated with that identity (api key)+* use that secret key to run the authenticate function on the request+* send back appropriate responses for errors, otherwise continue with the+  transformed and authenticated request++for example:++```haskell+-- this would throw an error, i guess+demandApiKey :: IO a++-- +informClientOfAuthenticationFailure :: AuthFailure -> IO a++-- imagine a function like this+getSecretOrFail :: ApiKey -> IO SecretKey++handleReq req = do+    apiKey <- getApiKey defaultApiKeySpec req >>= maybe demandApiKey return+    -- either get a caller reference or fail the request+    secretKey <- getSecretOrFail apiKey+    authRes <- authenticate defaultRequestConfig req secretKey+    req' <- either informClientOfAuthenticationFailure return authRes+    -- continue processing using the new request value.+```++

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,276 @@+{-|+Description: HMAC authentication tools++you should only need the contents of the types and tools sections, but all the functions in this module are exported just in case.+-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+module Network.Wai.Auth.HMAC where++import Control.Applicative+import Data.Foldable (Foldable, for_)+import Control.Monad (join, (>=>))+import Control.Monad.IO.Class+import qualified Data.ByteString as BS+import Data.IORef+import Data.Monoid+import Control.Monad.Trans.Reader (runReaderT)+import Control.Monad.Trans.Except (runExceptT)+import Control.Monad.Trans.State.Strict (execStateT)+import Control.Monad.Trans.Writer.Strict (runWriterT)+import qualified Control.Monad.Reader.Class as Mtl +import qualified Control.Monad.Writer.Class as Mtl+import qualified Control.Monad.Error.Class as Mtl+import qualified Control.Monad.State.Class as Mtl+import qualified Data.ByteString.Base64.URL as B64+import Control.Monad.Loops (whileJust_)+import Crypto.Hash+import Crypto.MAC+import qualified Data.Sequence as S+import Data.Byteable (toBytes)++import Network.Wai+import Network.HTTP.Types.Header+import Network.HTTP.Types.URI (renderQuery)++-- * types++-- | a newtype wrapper for api keys+newtype ApiKey = ApiKey BS.ByteString deriving (Eq, Show)++-- | newtype wrapper for secret keys+newtype SecretKey = SecretKey BS.ByteString deriving (Eq, Show)++-- | specification for how the api key should be found in the request+data ApiKeySpec = +    -- | look for a query parameter with the specified name+    QueryParamKey BS.ByteString |+    -- | look for the header with this name+    HeaderKey HeaderName+    deriving (Eq, Show)++-- | request configuration specifies how to perform hmac signing and+-- authentication on the request - i.e. where the api key will be found,+-- where the timestamp is stored, how the signature is added to the+-- request, and the hash algorithm to use.+data RequestConfig alg = RequestConfig {+    keySpec :: ApiKeySpec,+    timestampHeader :: HeaderName,+    signatureHeader :: HeaderName,+    hashAlgorithm :: alg+} deriving (Eq, Show)++-- | all of the way that signing or authentication can fail.+data AuthFailure =+    -- | the request does not have an api key value that fits the spec+    MissingApiKey ApiKeySpec |+    -- | the request does not have a timestamp header+    MissingTimestampHeader HeaderName |+    -- | the request does not have a signature header ('authenticate' only)+    MissingSignatureHeader HeaderName |+    -- | the signature was not url-safe base 64 encoded properly+    -- (authenticate only)+    SignatureBase64DecodeFailed String |+    -- | the signature was not a properly encoded hash digest (e.g. for the+    -- hash algorithm being used) (authenticate only)+    SignatureToDigestFailed |+    -- | the signature generated from the request did not match the+    -- signature contained within the reqest (authenticate only)+    HashMismatch+    deriving (Eq, Show)++-- ** default setup++-- | default request configuration+--+-- @+-- defaultRequestConfig = 'RequestConfig' 'defaultApiKeySpec' "x-auth-timestamp" "x-auth-signature" 'SHA256'+-- @+defaultRequestConfig :: RequestConfig SHA256+defaultRequestConfig = RequestConfig defaultApiKeySpec "x-auth-timestamp" "x-auth-signature" SHA256+++-- | default spec for getting the api key+--+-- @+-- defaultApiKeySpec = 'QueryParamKey' "apiKey"+-- @+defaultApiKeySpec :: ApiKeySpec+defaultApiKeySpec = QueryParamKey "apiKey"++-- * the tools ++-- | use this to get the api key from the request according to spec+getApiKey :: ApiKeySpec -> Request -> Maybe ApiKey+getApiKey (QueryParamKey k) = fmap ApiKey . join . lookup k . queryString+getApiKey (HeaderKey k) = fmap ApiKey . lookup k . requestHeaders++-- | authenticate the request according to the configuration and secret+-- key. if it succeeds, produces a request with a requestBody that will+-- produce the same chunk sequence as the original. if it fails, it will+-- explain why.+authenticate :: HashAlgorithm alg => RequestConfig alg -> Request -> SecretKey -> IO (Either AuthFailure Request)+authenticate conf req k = runReaderT (runExceptT (checkRequestHmac req k)) conf++-- | signs a request in accordance with the config. mostly for testing.+signRequest :: HashAlgorithm alg => RequestConfig alg -> Request -> SecretKey -> IO (Either AuthFailure Request)+signRequest conf req k = runReaderT (runExceptT (addSignatureToRequest req k)) conf++-- * internals++-- | the operation performed by 'authenticate'+checkRequestHmac :: (MonadIO m, HasReqConf alg m, AuthErrorsM m) => Request -> SecretKey -> m Request+checkRequestHmac req key = do+    tsig <- getBase64DecodedSignature req+    p <- runWriterT $ hmacRequest req key+    sigCheck tsig p+    where+    sigCheck targetSig (actualSig, chunks)+        | targetSig == actualSig = rerunRequestBody req chunks+        | otherwise = Mtl.throwError HashMismatch++-- | the operation performed by 'signRequest'+addSignatureToRequest :: (MonadIO m, HasReqConf alg m, AuthErrorsM m) => Request -> SecretKey -> m Request+addSignatureToRequest req key = do+    (genSig, chunks) <- runWriterT $ hmacRequest req key+    hname <- Mtl.reader signatureHeader+    let encSig = B64.encode (toBytes genSig)+        r' = addHeader req (hname, encSig)+    rerunRequestBody r' chunks++-- ** constraint aliases++-- | a constraint alias for functions that need to access request+-- configuration+type HasReqConf alg m = (HashAlgorithm alg, Mtl.MonadReader (RequestConfig alg) m, Functor m)++-- | a constrain alias for functions that can fail+type AuthErrorsM m = (Mtl.MonadError AuthFailure m)++-- | a constraint alias for functions that save chunks of the request body+type WriteChunks m = (Mtl.MonadWriter (S.Seq BS.ByteString) m)++-- | a constrain alias for functions that perform incremental updates to+-- the hash value+type HmacState alg m = (Functor m, Applicative m, HashAlgorithm alg, Mtl.MonadState (HMACContext alg) m)++-- ** manipulate the request ++-- | constructs a new request with a 'requestBody' function that will+-- produce each item in the input sequence until the sequence is empty.+rerunRequestBody :: (Functor m, MonadIO m) => Request -> S.Seq BS.ByteString -> m Request+rerunRequestBody req = fmap (setRequestBody req . produceChunked) . liftIO . newIORef++-- | sets the request body to the IO action.+setRequestBody :: Request -> IO BS.ByteString -> Request+setRequestBody r b = r { requestBody = b }++-- | gets the next chunk from the referenced sequence, returning mempty if+-- it is already empty. (if it is not, then the IORef is updated to point+-- to the next item in the sequence).+produceChunked :: (Monoid a) => IORef (S.Seq a) -> IO a+produceChunked ref = readIORef ref >>= (handleChunks . S.viewl)+    where+    handleChunks S.EmptyL = pure mempty+    handleChunks (h S.:< t) = writeIORef ref t *> pure h++-- | add a header to a request (without checking for pre-existing headers)+addHeader :: Request -> (HeaderName, BS.ByteString) -> Request+addHeader r h = r { requestHeaders = h : requestHeaders r }++-- ** computing the request signature++-- | performs the full incremental hash/sign algorithm on the request and+-- returns the signature.+hmacRequest :: (MonadIO m, HasReqConf alg m, AuthErrorsM m, WriteChunks m) => Request -> SecretKey -> m (HMAC alg)+hmacRequest req = hmacRequestInit >=> execStateT (addHashComponents req) >=> return . hmacFinalize++-- | sets up the hash algorithm with the secret key+hmacRequestInit :: HasReqConf alg m => SecretKey -> m (HMACContext alg)+hmacRequestInit (SecretKey k) = flip hmacInitAlg k <$> Mtl.reader hashAlgorithm++-- *** adding stuff to the hash++-- | add all of the important components of the request to the hash +-- +-- - request method (newline)+-- - timestamp header (newline)+-- - api key (if necessary)+-- - raw path info +-- - query params (with a question mark to separate from the path info)+-- - (newline)+-- - the body of the request+addHashComponents :: (MonadIO m, HasReqConf alg m, AuthErrorsM m, WriteChunks m, HmacState alg m) => Request -> m ()+addHashComponents = allRead [ +    addToHash . requestMethod, addSep,+    addTimestampHeader, addSep, +    ensureApiKeyIsAdded,+    addToHash . rawPathInfo,+    addToHash . renderQuery True . queryString, addSep,+    addBodyToHash+    ]+    where+    addSep = const (addToHash "\n")+    addTimestampHeader = getTimestampHeader >=> addToHash++-- | ensure the hash/signature will include the api key value according to+-- the spec - i.e. in either spec, this will fail the computation if the+-- key is not present according to spec; this function will have no further+-- effect for a query parameter key, but for a header key, it will add it+-- to the hash.+ensureApiKeyIsAdded :: (AuthErrorsM m, HasReqConf alg m, HmacState alg m) => Request -> m ()+ensureApiKeyIsAdded req =  Mtl.reader keySpec >>= (maybe <$> Mtl.throwError . MissingApiKey <*> actionForSpec <*> flip getApiKey req)+    where+    actionForSpec (QueryParamKey _) _ = return ()+    actionForSpec (HeaderKey _) (ApiKey k) = addToHash k >> addToHash "\n"++-- | keep getting chunks from the request and appending them to the hash+-- (and also storing them in the writer value) until there are no more chunks+addBodyToHash :: (MonadIO m, HmacState alg m, WriteChunks m) => Request -> m ()+addBodyToHash req = whileJust_ (getNextChunkForHash req) $ \c -> addToHash c *> Mtl.tell (S.singleton c)++-- | get the next chunk from the request body, if there is one+getNextChunkForHash :: (MonadIO m, Functor m) => Request -> m (Maybe BS.ByteString)+getNextChunkForHash = fmap (justUnless BS.null) . liftIO . requestBody++-- | add a value to the incremental hash+addToHash :: HmacState alg m => BS.ByteString -> m ()+addToHash = Mtl.modify . flip hmacUpdate++-- ** getting headers++-- | get the signature header value, decode it from base64 url encoding,+-- and then read it as a digest+getBase64DecodedSignature :: (HasReqConf alg m, AuthErrorsM m) => Request -> m (HMAC alg)+getBase64DecodedSignature = getSignatureHeader >=> +                            either (Mtl.throwError . SignatureBase64DecodeFailed) return . B64.decode >=>+                            maybe (Mtl.throwError SignatureToDigestFailed) return . digestFromByteString >=>+                            return . HMAC++-- | get the header that should contain the timestamp+getTimestampHeader :: (AuthErrorsM m, HasReqConf alg m) => Request -> m BS.ByteString+getTimestampHeader = getHeader timestampHeader MissingTimestampHeader++-- | get the header that should contain the signature+getSignatureHeader :: (AuthErrorsM m, HasReqConf alg m) => Request -> m BS.ByteString+getSignatureHeader = getHeader signatureHeader MissingSignatureHeader++-- | get a header from the request; throw an error if it can't be found+getHeader :: (AuthErrorsM m, HasReqConf alg m) => (RequestConfig alg -> HeaderName) -> (HeaderName -> AuthFailure) -> Request -> m BS.ByteString+getHeader targetHeader err req = Mtl.reader targetHeader >>= \header ->+    maybe (Mtl.throwError (err header)) return $ lookup header (requestHeaders req)++-- ** utility functions++-- | return the value if the predicate of it is true+justWhen :: (a -> Bool) -> a -> Maybe a+justWhen p a = if p a then Just a else Nothing++-- | return the value if the predicate of it is false+justUnless :: (a -> Bool) -> a -> Maybe a+justUnless p a = if p a then Nothing else Just a++-- | calls every function in the data structure, and then traverses/folds+-- the contained actions.+allRead :: (Applicative m, Foldable t) => t (a -> m b) -> a -> m ()+allRead l v = for_ l  ($ v)

@@ -0,0 +1,272 @@+module Main where++import Control.Applicative+import Data.Byteable (toBytes)+import Crypto.Hash+import Test.Hspec+import Network.Wai +import Network.Wai.Test (setPath)+import qualified Network.HTTP.Types as H+import qualified Data.ByteString as BS+import qualified Data.Sequence as S+import Network.Wai.Auth.HMAC+import Data.Maybe+import Data.Either+import qualified Data.ByteString.Base64.URL as B64++infixl 1 &+(&) :: a -> (a -> b) -> b+a & f = f a+{-# INLINE (&) #-}++setRequestMethod :: Request -> H.Method -> Request+setRequestMethod req method = req { requestMethod = method }++setRequestHeaders :: Request -> H.RequestHeaders -> Request+setRequestHeaders req headers = req { requestHeaders = headers }++removeRequestHeader :: H.HeaderName -> Request -> Request+removeRequestHeader targ req = setRequestHeaders req hdrs'+    where+    hdrs' = filter (not . (== targ) . fst) (requestHeaders req)++changeRequestHeader :: H.HeaderName -> BS.ByteString -> Request -> Request+changeRequestHeader targ newval req = setRequestHeaders req hdrs'+    where+    hdrs' = replacer <$> requestHeaders req+    replacer (n, v) = if n == targ then (n, newval) else (n, v)+++mkRequest :: H.Method -> BS.ByteString -> H.RequestHeaders -> S.Seq BS.ByteString -> IO Request+mkRequest method path headers bodyChunks = defaultRequest `setRequestMethod` method `setRequestHeaders` headers `setPath` path `rerunRequestBody` bodyChunks++shouldBeLeft :: (Eq e, Show e, Show a) => Either e a -> e -> Expectation+shouldBeLeft e v = either (`shouldBe` v) (\r -> expectationFailure $ "expected: Left (" ++ show v ++ ")\n but got: " ++ show r) e++shouldJustSatisfy :: Show a => Maybe a -> (a -> Bool) -> Expectation+shouldJustSatisfy Nothing _ = expectationFailure "expected: Just a value\nbut got: Nothing"+shouldJustSatisfy (Just a) p = a `shouldSatisfy` p++failLeftOr :: Show e => Either e a -> (a -> Expectation) -> Expectation+failLeftOr e f = either (\l -> expectationFailure $ "expected: a Right value\nbut got: Left (" ++ show l ++ ")") f e++failNothing :: Maybe a -> (a -> Expectation) -> Expectation+failNothing m f = maybe (expectationFailure "expected: Just a value\nbut got: Nothing") f m+++withSignedRequest :: HashAlgorithm alg => RequestConfig alg -> SecretKey -> IO Request -> (Request -> Expectation) -> Expectation+withSignedRequest conf k actReq f = do+    req <- actReq+    signRes <- signRequest conf req k+    failLeftOr signRes f++main :: IO ()+main = hspec $ do+    testGetApiKey+    testSignRequest+    testAuthenticate++testGetApiKey :: Spec+testGetApiKey = describe "getApiKey" $ do+    context "when using query param spec" $ do+        let spec = QueryParamKey "apiKey"+            getKey = getApiKey spec++        it "fails when no key is added" $ do+            req <- mkRequest H.methodGet "/" [] $ S.singleton "chunk"+            getKey req `shouldBe` Nothing++        it "won't get key in header" $ do+            req <- mkRequest H.methodGet "/" [("apiKey", "somekey")] $ S.singleton "chunk"+            getKey req `shouldBe` Nothing++        it "won't get key in different query param" $ do+            req <- mkRequest H.methodGet "/?passkey=somepass" [] $ S.singleton "chunk"+            getKey req `shouldBe` Nothing++        it "is case sensitive" $ do+            req <- mkRequest H.methodGet "/?apikey=somepass" [] $ S.singleton "chunk"+            getKey req `shouldBe` Nothing++        it "will get key in specified query param" $ do+            req <- mkRequest H.methodGet "/?apiKey=somepass" [] $ S.singleton "chunk"+            getKey req `shouldBe` Just (ApiKey "somepass")++    context "when using header spec" $ do+        let spec = HeaderKey "x-auth-apikey"+            getKey = getApiKey spec++        it "fails when no key is present" $ do+            req <- mkRequest H.methodGet "/" [] $ S.singleton "chunk"+            getKey req `shouldBe` Nothing++        it "won't get key in query param" $ do+            req <- mkRequest H.methodGet "/?x-auth-apikey=somekey" [] $ S.singleton "chunk"+            getKey req `shouldBe` Nothing++        it "won't get key in different header" $ do+            req <- mkRequest H.methodGet "/" [("x-auth-passkey", "somekey")] $ S.singleton "chunk"+            getKey req `shouldBe` Nothing++        it "will get key in specified header" $ do+            req <- mkRequest H.methodGet "/" [("x-auth-apikey", "somekey")] $ S.singleton "chunk"+            getKey req `shouldBe` Just (ApiKey "somekey")++        it "is NOT case sensitive" $ do+            req <- mkRequest H.methodGet "/" [("X-AUTH-APIKEY", "somekey")] $ S.singleton "chunk"+            getKey req `shouldBe` Just (ApiKey "somekey")++testSignRequest :: Spec+testSignRequest = describe "sign request" $ do+    context "when using a header api key" $ do+        let spec = HeaderKey "x-auth-apikey"+            conf = RequestConfig spec "x-auth-timestamp" "x-auth-signature" SHA256+            secretKey = SecretKey "test-key"+            confSign req = signRequest conf req secretKey++        it "demands the api key" $ do+            req <- mkRequest H.methodGet "/" [("x-auth-timestamp", "2012-12-21T00:00:00Z")] $ S.singleton "chunk"+            signRes <- confSign req+            signRes `shouldBeLeft` MissingApiKey spec++        it "demands the timestamp" $ do+            req <- mkRequest H.methodGet "/" [("x-auth-apikey", "somekey")] $ S.singleton "chunk"+            signRes <- confSign req+            signRes `shouldBeLeft` MissingTimestampHeader "x-auth-timestamp"++        it "produces a signed request" $ do+            req <- mkRequest H.methodGet "/" [("x-auth-apikey", "somekey"), ("x-auth-timestamp", "2012-12-21T00:00:00Z")] $ S.singleton "chunk" S.|> "1 chunk2"+            signRes <- confSign req+            failLeftOr signRes $ \res -> +                lookup "x-auth-signature" (requestHeaders res) `shouldSatisfy` isJust++        it "creates a base64-url encoded signature" $ do+            req <- mkRequest H.methodGet "/" [("x-auth-apikey", "somekey"), ("x-auth-timestamp", "2012-12-21T00:00:00Z")] $ S.singleton "chunk" S.|> "1 chunk2"+            signRes <- confSign req+            failLeftOr signRes $ \res -> +                failNothing (lookup "x-auth-signature" (requestHeaders res)) $ \hdr -> +                    B64.decode hdr `shouldSatisfy` isRight++    context "when using a query param api key" $ do+        let spec = QueryParamKey "apiKey"+            conf = RequestConfig spec "x-auth-timestamp" "x-auth-signature" SHA256+            secretKey = SecretKey "test-key"+            confSign req = signRequest conf req secretKey++        it "demands the api key" $ do+            req <- mkRequest H.methodGet "/" [("x-auth-timestamp", "2012-12-21T00:00:00Z")] $ S.singleton "chunk"+            signRes <- confSign req+            signRes `shouldBeLeft` MissingApiKey spec++        it "demands the timestamp" $ do+            req <- mkRequest H.methodGet "/path?apiKey=somekey" [] $ S.singleton "chunk"+            signRes <- confSign req+            signRes `shouldBeLeft` MissingTimestampHeader "x-auth-timestamp"++        it "produces a signed request" $ do+            req <- mkRequest H.methodGet "/path?apiKey=somekey" [("x-auth-timestamp", "2012-12-21T00:00:00Z")] $ S.singleton "chunk"+            signRes <- confSign req+            failLeftOr signRes $ \res -> +                lookup "x-auth-signature" (requestHeaders res) `shouldSatisfy` isJust++testAuthenticate :: Spec+testAuthenticate = describe "authenticate" $ do+    context "when using a query param api key" $ do+        let spec = QueryParamKey "apiKey"+            conf = RequestConfig spec "x-auth-timestamp" "x-auth-signature" SHA256+            secretKey = SecretKey "test-key"+            withSigned = withSignedRequest conf secretKey+            confAuthenticate req = authenticate conf req secretKey++        let simpleReq = mkRequest H.methodGet "/loc?apiKey=somekey" [("x-auth-timestamp", "2012-12-21T00:00:00Z")] (S.singleton "chunk" S.|> "1 chunk2")+        it "works with a simple signed request" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate sreq+            ares `shouldSatisfy` isRight++        it "complains about missing api key" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ setPath sreq "/loc"+            ares `shouldBeLeft` MissingApiKey spec++        it "complains about missing timestamp" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ removeRequestHeader "x-auth-timestamp" sreq+            ares `shouldBeLeft` MissingTimestampHeader "x-auth-timestamp"++        it "complains about missing signature" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ removeRequestHeader "x-auth-signature" sreq+            ares `shouldBeLeft` MissingSignatureHeader "x-auth-signature"++        it "complains about incorrectly-encoded signature" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ changeRequestHeader "x-auth-signature" "fake.it" sreq+            putStrLn (show ares)+            ares `shouldBeLeft` SignatureBase64DecodeFailed "invalid padding"+            ares2 <- confAuthenticate $ changeRequestHeader "x-auth-signature" (B64.encode "invalid") sreq+            ares2 `shouldBeLeft` SignatureToDigestFailed++        it "complains if the signature does not match" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ changeRequestHeader "x-auth-signature" (B64.encode $ toBytes $ (hash "what" :: Digest SHA256)) sreq+            ares `shouldBeLeft` HashMismatch++        context "when a request is already signed" $ do+            it "fails if the api key param changes" $ withSigned simpleReq $ \sreq -> do+                ares <- confAuthenticate $ setPath sreq "/loc?apiKey=otherkey"+                ares `shouldBeLeft` HashMismatch++    context "when using a header api key" $ do+        let spec = HeaderKey "x-auth-apikey"+            conf = RequestConfig spec "x-auth-timestamp" "x-auth-signature" SHA256+            secretKey = SecretKey "test-key"+            withSigned = withSignedRequest conf secretKey+            confAuthenticate req = authenticate conf req secretKey++        let simpleReq = mkRequest H.methodGet "/loc" [("x-auth-apikey", "somekey"), ("x-auth-timestamp", "2012-12-21T00:00:00Z")] (S.singleton "chunk" S.|> "1 chunk2")+        it "works with a simple signed request" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate sreq+            ares `shouldSatisfy` isRight++        it "complains about missing api key header" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ removeRequestHeader "x-auth-apikey" sreq+            ares `shouldBeLeft` MissingApiKey spec++        it "complains about missing timestamp" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ removeRequestHeader "x-auth-timestamp" sreq+            ares `shouldBeLeft` MissingTimestampHeader "x-auth-timestamp"++        it "complains about missing signature" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ removeRequestHeader "x-auth-signature" sreq+            ares `shouldBeLeft` MissingSignatureHeader "x-auth-signature"++        it "complains about incorrectly-encoded signature" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ changeRequestHeader "x-auth-signature" "fake.it" sreq+            putStrLn (show ares)+            ares `shouldBeLeft` SignatureBase64DecodeFailed "invalid padding"+            ares2 <- confAuthenticate $ changeRequestHeader "x-auth-signature" (B64.encode "invalid") sreq+            ares2 `shouldBeLeft` SignatureToDigestFailed++        it "complains if the signature does not match" $ withSigned simpleReq $ \sreq -> do+            ares <- confAuthenticate $ changeRequestHeader "x-auth-signature" (B64.encode $ toBytes $ (hash "what" :: Digest SHA256)) sreq+            ares `shouldBeLeft` HashMismatch++        context "when a request is already signed" $ do+            it "fails if the method changes" $ withSigned simpleReq $ \sreq -> do+                ares <- confAuthenticate $ setRequestMethod sreq "PUT" +                ares `shouldBeLeft` HashMismatch++            it "fails if the path changes" $ withSigned simpleReq $ \sreq -> do+                ares <- confAuthenticate $ setPath sreq "/pathnew"+                ares `shouldBeLeft` HashMismatch++            it "fails if the query string changes" $ withSigned simpleReq $ \sreq -> do+                ares <- confAuthenticate $ setPath sreq "/loc?query=value"+                ares `shouldBeLeft` HashMismatch++            it "fails if the timestamp changes" $ withSigned simpleReq $ \sreq -> do+                ares <- confAuthenticate $ changeRequestHeader "x-auth-timestamp" "faketime" sreq+                ares `shouldBeLeft` HashMismatch++            it "fails if the api key header changes" $ withSigned simpleReq $ \sreq -> do+                ares <- confAuthenticate $ changeRequestHeader "x-auth-apikey" "otherkey" sreq+                ares `shouldBeLeft` HashMismatch++            it "fails if the body changes" $ withSigned simpleReq $ \sreq -> do+                ares <- confAuthenticate =<< rerunRequestBody sreq (S.singleton "chunk0 ")+                ares `shouldBeLeft` HashMismatch

@@ -0,0 +1,67 @@+name:                wai-hmac-auth+version:             1.0.0+synopsis:            hmac authentication tools for WAI apps+description:         authenticate requests made to your WAI apps using HMAC.+homepage:            https://github.com/raptros/wai-hmac-auth+license:             BSD3+license-file:        LICENSE+author:              aidan coyne+maintainer:          coynea90@gmail.com+copyright:           2014, aidan coyne+category:            Web+build-type:          Simple+bug-reports:         https://github.com/raptros/wai-hmac-auth/issues+extra-source-files:  README.md, CHANGELOG.md+cabal-version:       >=1.10++source-repository head+    type:     git+    location: https://github.com/raptros/wai-hmac-auth.git++library+    default-language:    Haskell2010+    ghc-options:+        -Wall+    default-extensions:+        OverloadedStrings+    hs-source-dirs:+        src+    exposed-modules:     +        Network.Wai.Auth.HMAC+    build-depends: +        base            >= 4.7 && < 4.8+        , wai           >= 3.0 && < 4.0+        , http-types    >= 0.8 && < 0.9+        , bytestring    >= 0.10 && < 0.11+        , transformers  == 0.4.*+        , bifunctors    >= 4.1 && <= 4.3+        , mtl           >= 2.2 && < 2.3+        , cryptohash    >= 0.11.6 && < 0.12+        , containers    == 0.5.5.*+        , monad-loops   >= 0.4 && < 0.5+        , base64-bytestring >= 1.0 && < 1.1+        , byteable      >= 0.1.1 && < 0.1.2++test-suite tests+    ghc-options: -Wall+    type: exitcode-stdio-1.0+    main-is: tests.hs+    hs-source-dirs: tests+    default-extensions:+        OverloadedStrings+    build-depends: +        base            >= 4.7 && < 4.8+        , wai           >= 3.0 && < 4.0+        , wai-extra     >= 3.0 && < 4.0+        , wai-hmac-auth+        , http-types    >= 0.8 && < 0.9+        , bytestring    >= 0.10 && < 0.11+        , transformers  == 0.4.*+        , bifunctors    >= 4.1 && <= 4.3+        , mtl           >= 2.2 && < 2.3+        , cryptohash    >= 0.11.6 && < 0.12+        , containers    == 0.5.5.*+        , monad-loops   >= 0.4 && < 0.5+        , base64-bytestring >= 1.0 && < 1.1+        , hspec         >= 2.1 && < 2.2+        , byteable      >= 0.1.1 && < 0.1.2