servant-hmac-auth 0.0.0 → 0.1.1
raw patch · 8 files changed
+193/−272 lines, 8 filesdep −aesondep −warpdep ~basedep ~cryptonitedep ~http-clientsetup-changednew-uploader
Dependencies removed: aeson, warp
Dependency ranges changed: base, cryptonite, http-client, memory, servant, servant-client, servant-client-core, servant-server, wai
Files
- CHANGELOG.md +17/−3
- README.lhs +0/−127
- README.md +5/−5
- Setup.hs +0/−2
- servant-hmac-auth.cabal +50/−67
- src/Servant/Auth/Hmac/Client.hs +60/−43
- src/Servant/Auth/Hmac/Crypto.hs +19/−2
- src/Servant/Auth/Hmac/Server.hs +42/−23
CHANGELOG.md view
@@ -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.
− README.lhs
@@ -1,127 +0,0 @@-# servant-hmac-auth--[](https://hackage.haskell.org/package/servant-hmac-auth)-[](LICENSE)-[](http://stackage.org/lts/package/servant-hmac-auth)-[](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)-```
README.md view
@@ -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
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
servant-hmac-auth.cabal view
@@ -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
src/Servant/Auth/Hmac/Client.hs view
@@ -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.
src/Servant/Auth/Hmac/Crypto.hs view
@@ -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:
src/Servant/Auth/Hmac/Server.hs view
@@ -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 }