diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,24 @@ -# Change log +# Changelog `servant-hmac-auth` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. -0.0.0 -===== +## Unreleased: 0.1.0 + +* Introduce whitelisted headers. +* **Breaking change:** `HmacSettings` now containt post-sign hook for request. + `hmacClientSign` function accepts `HmacSettings`. + + _Migration guide:_ use `defaultHmacSettings` for `runHmacClient` function. +* Add `hmacAuthHandlerMap` function that allows to perform monadic actions on + every incoming request for HMAC server. +* [#28](https://github.com/Holmusk/servant-hmac-auth/issues/28): + Added type alias `HmacAuthHandler` for `AuthHandler Wai.Request ()` +* [#37](https://github.com/Holmusk/servant-hmac-auth/issues/37): + Upgrade `servant-*` libraries to `0.16-*` +* Use `Cabal-2.4` + +## 0.0.0 — Sep 6, 2018 * Initially created. diff --git a/README.lhs b/README.lhs deleted file mode 100644 --- a/README.lhs +++ /dev/null @@ -1,127 +0,0 @@ -# servant-hmac-auth - -[![Hackage](https://img.shields.io/hackage/v/servant-hmac-auth.svg)](https://hackage.haskell.org/package/servant-hmac-auth) -[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) -[![Stackage Lts](http://stackage.org/package/servant-hmac-auth/badge/lts)](http://stackage.org/lts/package/servant-hmac-auth) -[![Stackage Nightly](http://stackage.org/package/servant-hmac-auth/badge/nightly)](http://stackage.org/nightly/package/servant-hmac-auth) - -Servant authentication with HMAC - -## Example - -In this section, we will introduce the client-server example. -To run it locally you can: - -```shell -$ cabal new-build -$ cabal new-exec readme -``` - -So,it will run this on your machine. - -### Setting up - -Since this tutorial is written using Literate Haskell, first, let's write all necessary pragmas and imports. - -```haskell -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -import Control.Concurrent (forkIO, threadDelay) -import Data.Aeson (FromJSON, ToJSON) -import Data.Proxy (Proxy (..)) -import GHC.Generics (Generic) -import Network.HTTP.Client (defaultManagerSettings, newManager) -import Network.Wai.Handler.Warp (run) -import Servant.API ((:>), Get, JSON) -import Servant.Client (BaseUrl (..), Scheme (..), ServantError, mkClientEnv) -import Servant.Server (Application, Server, serveWithContext) - -import Servant.Auth.Hmac (HmacAuth, HmacClientM, SecretKey (..), hmacAuthServerContext, hmacClient, - runHmacClient, signSHA256) -``` - -### Server - -Let's define our `TheAnswer` data type with the necessary instances for it. - -```haskell -newtype TheAnswer = TheAnswer Int - deriving (Show, Generic, FromJSON, ToJSON) - -getTheAnswer :: TheAnswer -getTheAnswer = TheAnswer 42 -``` - -Now, let's introduce a very simple protected endpoint. The value of `TheAnswer` -data type will be the value that our API endpoint returns. It our case we want -it to return the number `42` for all signed requests. - -```haskell -type TheAnswerToEverythingUnprotectedAPI = "answer" :> Get '[JSON] TheAnswer -type TheAnswerToEverythingAPI = HmacAuth :> TheAnswerToEverythingUnprotectedAPI -``` - -As you can see this endpoint is protected by `HmacAuth`. - -And now our server: - -```haskell -server42 :: Server TheAnswerToEverythingAPI -server42 = \_ -> pure getTheAnswer -``` - -Now we can turn `server` into an actual webserver: - -```haskell -topSecret :: SecretKey -topSecret = SecretKey "top-secret" - -app42 :: Application -app42 = serveWithContext - (Proxy @TheAnswerToEverythingAPI) - (hmacAuthServerContext signSHA256 topSecret) - server42 -``` - -### Client - -Now let's implement client that queries our server and signs every request -automatically. - -```haskell -client42 :: HmacClientM TheAnswer -client42 = hmacClient @TheAnswerToEverythingUnprotectedAPI -``` - -Now we need to write function that runs our client: - -```haskell -runClient :: SecretKey -> HmacClientM a -> IO (Either ServantError a) -runClient sk client = do - manager <- newManager defaultManagerSettings - let env = mkClientEnv manager $ BaseUrl Http "localhost" 8080 "" - runHmacClient signSHA256 sk env client -``` - -### Main - -And we're able to run our server in separate thread and perform two quiries: - -* Properly signed -* Signed with different key - -```haskell -main :: IO () -main = do - _ <- forkIO $ run 8080 app42 - - print =<< runClient topSecret client42 - print =<< runClient (SecretKey "wrong!") client42 - - threadDelay $ 10 ^ (6 :: Int) -``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -38,11 +38,11 @@ import Network.HTTP.Client (defaultManagerSettings, newManager) import Network.Wai.Handler.Warp (run) import Servant.API ((:>), Get, JSON) -import Servant.Client (BaseUrl (..), Scheme (..), ServantError, mkClientEnv) +import Servant.Client (BaseUrl (..), Scheme (..), ClientError, mkClientEnv) import Servant.Server (Application, Server, serveWithContext) -import Servant.Auth.Hmac (HmacAuth, HmacClientM, SecretKey (..), hmacAuthServerContext, hmacClient, - runHmacClient, signSHA256) +import Servant.Auth.Hmac (HmacAuth, HmacClientM, SecretKey (..), defaultHmacSettings, + hmacAuthServerContext, hmacClient, runHmacClient, signSHA256) ``` ### Server @@ -101,11 +101,11 @@ Now we need to write function that runs our client: ```haskell -runClient :: SecretKey -> HmacClientM a -> IO (Either ServantError a) +runClient :: SecretKey -> HmacClientM a -> IO (Either ClientError a) runClient sk client = do manager <- newManager defaultManagerSettings let env = mkClientEnv manager $ BaseUrl Http "localhost" 8080 "" - runHmacClient signSHA256 sk env client + runHmacClient (defaultHmacSettings sk) env client ``` ### Main diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-hmac-auth.cabal b/servant-hmac-auth.cabal --- a/servant-hmac-auth.cabal +++ b/servant-hmac-auth.cabal @@ -1,8 +1,8 @@ -cabal-version: 2.0 +cabal-version: 2.4 name: servant-hmac-auth -version: 0.0.0 -description: Servant authentication with HMAC +version: 0.1.1 synopsis: Servant authentication with HMAC +description: Servant authentication with HMAC. See README.md for usage example. homepage: https://github.com/holmusk/servant-hmac-auth bug-reports: https://github.com/holmusk/servant-hmac-auth/issues license: MIT @@ -14,36 +14,15 @@ build-type: Simple extra-doc-files: README.md , CHANGELOG.md -tested-with: GHC == 8.4.3 +tested-with: GHC == 8.6.5 + GHC == 8.8.3 source-repository head type: git location: https://github.com/holmusk/servant-hmac-auth.git -library - hs-source-dirs: src - exposed-modules: Servant.Auth.Hmac - Servant.Auth.Hmac.Crypto - Servant.Auth.Hmac.Client - Servant.Auth.Hmac.Server - - build-depends: base >= 4.11 && < 5 - , base64-bytestring ^>= 1.0 - , binary ^>= 0.8 - , bytestring ^>= 0.10 - , case-insensitive ^>= 1.2 - , containers >= 0.5.7 && < 0.7 - , cryptonite ^>= 0.25 - , http-types ^>= 0.12 - , http-client ^>= 0.5 - , memory ^>= 0.14.14 - , mtl ^>= 2.2.2 - , servant ^>= 0.14.1 - , servant-client ^>= 0.14 - , servant-client-core ^>= 0.14.1 - , servant-server ^>= 0.14.1 - , transformers ^>= 0.5 - , wai ^>= 3.2 +common common-options + build-depends: base >= 4.11.1.0 && < 4.15 ghc-options: -Wall -Wincomplete-uni-patterns @@ -51,57 +30,61 @@ -Wcompat -Widentities -Wredundant-constraints - -Wmissing-export-lists -Wpartial-fields -fhide-source-paths default-language: Haskell2010 - default-extensions: DeriveGeneric + default-extensions: BangPatterns + ConstraintKinds + DataKinds + DeriveGeneric + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures LambdaCase + MultiParamTypeClasses OverloadedStrings + OverloadedLabels RecordWildCards ScopedTypeVariables TypeApplications + TypeFamilies + TypeOperators + ViewPatterns +library + import: common-options + hs-source-dirs: src + exposed-modules: Servant.Auth.Hmac + Servant.Auth.Hmac.Crypto + Servant.Auth.Hmac.Client + Servant.Auth.Hmac.Server + + build-depends: base64-bytestring ^>= 1.0 + , binary ^>= 0.8 + , bytestring ^>= 0.10 + , case-insensitive ^>= 1.2 + , containers >= 0.5.7 && < 0.7 + , cryptonite >= 0.25 && < 0.30 + , http-types ^>= 0.12 + , http-client >= 0.6.4 && < 0.8 + , memory >= 0.15 && < 0.17 + , mtl ^>= 2.2.2 + , servant ^>= 0.18 + , servant-client ^>= 0.18 + , servant-client-core ^>= 0.18 + , servant-server ^>= 0.18 + , transformers ^>= 0.5 + , wai ^>= 3.2.2.1 + test-suite servant-hmac-auth-test + import: common-options type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - ghc-options: -Wall - -threaded - -rtsopts - -with-rtsopts=-N - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wcompat - -Widentities - -Wredundant-constraints - -fhide-source-paths - -Wmissing-export-lists - -Wpartial-fields - build-depends: base - , servant-hmac-auth - - default-language: Haskell2010 - default-extensions: DeriveGeneric - GeneralizedNewtypeDeriving - LambdaCase - OverloadedStrings - RecordWildCards - ScopedTypeVariables - TypeApplications - -executable readme - main-is: README.lhs - build-depends: base - , aeson ^>= 1.3 - , http-client - , servant - , servant-hmac-auth - , servant-client - , servant-server - , warp ^>= 3.2 - build-tool-depends: markdown-unlit:markdown-unlit - ghc-options: -Wall -pgmL markdown-unlit - default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: servant-hmac-auth diff --git a/src/Servant/Auth/Hmac/Client.hs b/src/Servant/Auth/Hmac/Client.hs --- a/src/Servant/Auth/Hmac/Client.hs +++ b/src/Servant/Auth/Hmac/Client.hs @@ -5,7 +5,12 @@ -- | Servant client authentication. module Servant.Auth.Hmac.Client - ( HmacClientM (..) + ( -- * HMAC client settings + HmacSettings (..) + , defaultHmacSettings + + -- * HMAC servant client + , HmacClientM (..) , runHmacClient , hmacClient ) where @@ -14,35 +19,49 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT) import Control.Monad.Trans.Class (lift) -import Data.Binary.Builder (toLazyByteString) import Data.ByteString (ByteString) import Data.Foldable (toList) import Data.List (sort) import Data.Proxy (Proxy (..)) import Data.Sequence (fromList, (<|)) -import Data.String (fromString) -import Network.HTTP.Client (RequestBody (..)) -import Servant.Client (BaseUrl, Client, ClientEnv (baseUrl), ClientM, HasClient, ServantError, +import Servant.Client (BaseUrl, Client, ClientEnv (baseUrl), ClientError, ClientM, HasClient, runClientM) import Servant.Client.Core (RunClient (..), clientIn) -import Servant.Client.Internal.HttpClient (requestToClientRequest) +import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) import Servant.Auth.Hmac.Crypto (RequestPayload (..), SecretKey, Signature (..), authHeaderName, - requestSignature) + keepWhitelistedHeaders, requestSignature, signSHA256) -import qualified Data.ByteString.Lazy as LBS (toStrict) -import qualified Network.HTTP.Client as Client (Request, host, method, path, port, queryString, - requestBody, requestHeaders) -import qualified Servant.Client.Core as Servant (Request, Response, StreamingResponse, - requestHeaders, requestQueryString) +import qualified Network.HTTP.Client as Client +import qualified Servant.Client.Core as Servant --- | Environment for 'HmacClientM'. +-- | Environment for 'HmacClientM'. Contains all required settings for hmac client. data HmacSettings = HmacSettings - { hmacSigner :: SecretKey -> ByteString -> Signature - , hmacSecretKey :: SecretKey + { -- | Singing function that will sign all outgoing requests. + hmacSigner :: SecretKey -> ByteString -> Signature + + -- | Secret key for signing function. + , hmacSecretKey :: SecretKey + + -- | Function to call for every request after this request is signed. + -- Useful for debugging. + , hmacRequestHook :: Maybe (Servant.Request -> ClientM ()) } +{- | Default 'HmacSettings' with the following configuration: + +1. Signing function is 'signSHA256'. +2. Secret key is provided. +3. 'hmacRequestHook' is 'Nothing'. +-} +defaultHmacSettings :: SecretKey -> HmacSettings +defaultHmacSettings sk = HmacSettings + { hmacSigner = signSHA256 + , hmacSecretKey = sk + , hmacRequestHook = Nothing + } + {- | @newtype@ wrapper over 'ClientM' that signs all outgoing requests automatically. -} @@ -53,34 +72,32 @@ hmacifyClient :: ClientM a -> HmacClientM a hmacifyClient = HmacClientM . lift - hmacClientSign :: Servant.Request -> HmacClientM Servant.Request hmacClientSign req = HmacClientM $ do HmacSettings{..} <- ask url <- lift $ asks baseUrl - pure $ signRequestHmac hmacSigner hmacSecretKey url req + let signedRequest = signRequestHmac hmacSigner hmacSecretKey url req + case hmacRequestHook of + Nothing -> pure () + Just hook -> lift $ hook signedRequest + pure signedRequest instance RunClient HmacClientM where - runRequest :: Servant.Request -> HmacClientM Servant.Response - runRequest = hmacClientSign >=> hmacifyClient . runRequest - - streamingRequest :: Servant.Request -> HmacClientM Servant.StreamingResponse - streamingRequest = hmacClientSign >=> hmacifyClient . streamingRequest + runRequestAcceptStatus s = hmacClientSign >=> hmacifyClient . runRequestAcceptStatus s - throwServantError :: ServantError -> HmacClientM a - throwServantError = hmacifyClient . throwServantError + throwClientError :: ClientError -> HmacClientM a + throwClientError = hmacifyClient . throwClientError runHmacClient - :: (SecretKey -> ByteString -> Signature) -- ^ Signing function - -> SecretKey -- ^ Secret key to sign all requests + :: HmacSettings -> ClientEnv -> HmacClientM a - -> IO (Either ServantError a) -runHmacClient hmacSigner hmacSecretKey env client = - runClientM (runReaderT (runHmacClientM client) HmacSettings{..}) env + -> IO (Either ClientError a) +runHmacClient settings env client = + runClientM (runReaderT (runHmacClientM client) settings) env -- | Generates a set of client functions for an API. -hmacClient :: forall api . HasClient HmacClientM api => Client HmacClientM api +hmacClient :: forall api . HasClient HmacClientM api => Client HmacClientM api hmacClient = Proxy @api `clientIn` Proxy @HmacClientM ---------------------------------------------------------------------------- @@ -88,31 +105,31 @@ ---------------------------------------------------------------------------- servantRequestToPayload :: BaseUrl -> Servant.Request -> RequestPayload -servantRequestToPayload url sreq = RequestPayload +servantRequestToPayload url sreq = RequestPayload { rpMethod = Client.method req - , rpContent = toBsBody $ Client.requestBody req - , rpHeaders = ("Host", fullHostName) + , rpContent = "" -- toBsBody $ Client.requestBody req + , rpHeaders = keepWhitelistedHeaders + $ ("Host", host) : ("Accept-Encoding", "gzip") : Client.requestHeaders req - , rpRawUrl = fullHostName <> Client.path req <> Client.queryString req + , rpRawUrl = host <> Client.path req <> Client.queryString req } where req :: Client.Request - req = requestToClientRequest url sreq + req = defaultMakeClientRequest url sreq { Servant.requestQueryString = fromList $ sort $ toList $ Servant.requestQueryString sreq } - - fullHostName :: ByteString - fullHostName = Client.host req <> ":" <> fromString (show (Client.port req)) + host :: ByteString + host = Client.host req - toBsBody :: RequestBody -> ByteString - toBsBody (RequestBodyBS bs) = bs - toBsBody (RequestBodyLBS bs) = LBS.toStrict bs - toBsBody (RequestBodyBuilder _ b) = LBS.toStrict $ toLazyByteString b - toBsBody _ = "" -- heh +-- toBsBody :: RequestBody -> ByteString +-- toBsBody (RequestBodyBS bs) = bs +-- toBsBody (RequestBodyLBS bs) = LBS.toStrict bs +-- toBsBody (RequestBodyBuilder _ b) = LBS.toStrict $ toLazyByteString b +-- toBsBody _ = "" -- heh {- | Adds signed header to the request. diff --git a/src/Servant/Auth/Hmac/Crypto.hs b/src/Servant/Auth/Hmac/Crypto.hs --- a/src/Servant/Auth/Hmac/Crypto.hs +++ b/src/Servant/Auth/Hmac/Crypto.hs @@ -13,6 +13,8 @@ , RequestPayload (..) , requestSignature , verifySignatureHmac + , whitelistHeaders + , keepWhitelistedHeaders -- * Internals , authHeaderName @@ -73,8 +75,6 @@ , rpRawUrl :: !ByteString -- ^ Raw request URL with host, path pieces and parameters } deriving (Show) --- TODO: require Content-Type header? --- TODO: require Date header with timestamp? {- | This function signs HTTP request according to the following algorithm: @ @@ -124,6 +124,23 @@ where normalize :: Header -> ByteString normalize (name, value) = foldedCase name <> value + +{- | White-listed headers. Only these headers will be taken into consideration: + +1. @Authentication@ +2. @Host@ +3. @Accept-Encoding@ +-} +whitelistHeaders :: [HeaderName] +whitelistHeaders = + [ authHeaderName + , "Host" + , "Accept-Encoding" + ] + +-- | Keeps only headers from 'whitelistHeaders'. +keepWhitelistedHeaders :: [Header] -> [Header] +keepWhitelistedHeaders = filter (\(name, _) -> name `elem` whitelistHeaders) {- | This function takes signing function @signer@ and secret key and expects that given 'Request' has header: diff --git a/src/Servant/Auth/Hmac/Server.hs b/src/Servant/Auth/Hmac/Server.hs --- a/src/Servant/Auth/Hmac/Server.hs +++ b/src/Servant/Auth/Hmac/Server.hs @@ -7,24 +7,24 @@ ( HmacAuth , HmacAuthContextHandlers , HmacAuthContext + , HmacAuthHandler , hmacAuthServerContext , hmacAuthHandler + , hmacAuthHandlerMap ) where import Control.Monad.Except (throwError) -import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) -import Network.Wai (rawPathInfo, rawQueryString, requestBody, requestHeaderHost, requestHeaders, - requestMethod) +import Network.Wai (rawPathInfo, rawQueryString, requestHeaderHost, requestHeaders, requestMethod) import Servant (Context ((:.), EmptyContext)) import Servant.API (AuthProtect) import Servant.Server (Handler, err401, errBody) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) -import Servant.Auth.Hmac.Crypto (RequestPayload (..), SecretKey, Signature, verifySignatureHmac) +import Servant.Auth.Hmac.Crypto (RequestPayload (..), SecretKey, Signature, keepWhitelistedHeaders, + verifySignatureHmac) -import qualified Data.ByteString as BS import qualified Network.Wai as Wai (Request) @@ -32,7 +32,8 @@ type instance AuthServerData HmacAuth = () -type HmacAuthContextHandlers = '[AuthHandler Wai.Request ()] +type HmacAuthHandler = AuthHandler Wai.Request () +type HmacAuthContextHandlers = '[HmacAuthHandler] type HmacAuthContext = Context HmacAuthContextHandlers hmacAuthServerContext @@ -41,34 +42,52 @@ -> HmacAuthContext hmacAuthServerContext signer sk = hmacAuthHandler signer sk :. EmptyContext +-- | Create 'HmacAuthHandler' from signing function and secret key. hmacAuthHandler :: (SecretKey -> ByteString -> Signature) -- ^ Signing function -> SecretKey -- ^ Secret key that was used for signing 'Request' - -> AuthHandler Wai.Request () -hmacAuthHandler signer sk = mkAuthHandler handler + -> HmacAuthHandler +hmacAuthHandler = hmacAuthHandlerMap pure + +{- | Like 'hmacAuthHandler' but allows to specify additional mapping function +for 'Wai.Request'. This can be useful if you want to print incoming request (for +logging purposes) or filter some headers (to match signature). Given function is +applied before signature verification. +-} +hmacAuthHandlerMap + :: (Wai.Request -> Handler Wai.Request) -- ^ Request mapper + -> (SecretKey -> ByteString -> Signature) -- ^ Signing function + -> SecretKey -- ^ Secret key that was used for signing 'Request' + -> HmacAuthHandler +hmacAuthHandlerMap mapper signer sk = mkAuthHandler handler where handler :: Wai.Request -> Handler () - handler req = liftIO (verifySignatureHmac signer sk <$> waiRequestToPayload req) >>= \case - Nothing -> pure () - Just bs -> throwError $ err401 { errBody = bs } + handler req = do + newReq <- mapper req + let payload = waiRequestToPayload newReq + let verification = verifySignatureHmac signer sk payload + case verification of + Nothing -> pure () + Just bs -> throwError $ err401 { errBody = bs } ---------------------------------------------------------------------------- -- Internals ---------------------------------------------------------------------------- -getWaiRequestBody :: Wai.Request -> IO ByteString -getWaiRequestBody request = BS.concat <$> getChunks - where - getChunks :: IO [ByteString] - getChunks = requestBody request >>= \chunk -> - if chunk == BS.empty - then pure [] - else (chunk:) <$> getChunks +-- getWaiRequestBody :: Wai.Request -> IO ByteString +-- getWaiRequestBody request = BS.concat <$> getChunks +-- where +-- getChunks :: IO [ByteString] +-- getChunks = requestBody request >>= \chunk -> +-- if chunk == BS.empty +-- then pure [] +-- else (chunk:) <$> getChunks -waiRequestToPayload :: Wai.Request -> IO RequestPayload -waiRequestToPayload req = getWaiRequestBody req >>= \body -> pure RequestPayload +waiRequestToPayload :: Wai.Request -> RequestPayload +-- waiRequestToPayload req = getWaiRequestBody req >>= \body -> pure RequestPayload +waiRequestToPayload req = RequestPayload { rpMethod = requestMethod req - , rpContent = body - , rpHeaders = requestHeaders req + , rpContent = "" + , rpHeaders = keepWhitelistedHeaders $ requestHeaders req , rpRawUrl = fromMaybe mempty (requestHeaderHost req) <> rawPathInfo req <> rawQueryString req }