diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Change log + +`servant-hmac-auth` uses [PVP Versioning][1]. +The change log is available [on GitHub][2]. + +0.0.0 +===== + +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/holmusk/servant-hmac-auth/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 Holmusk + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,127 @@ +# 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 new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,127 @@ +# 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-hmac-auth.cabal b/servant-hmac-auth.cabal new file mode 100644 --- /dev/null +++ b/servant-hmac-auth.cabal @@ -0,0 +1,107 @@ +cabal-version: 2.0 +name: servant-hmac-auth +version: 0.0.0 +description: Servant authentication with HMAC +synopsis: Servant authentication with HMAC +homepage: https://github.com/holmusk/servant-hmac-auth +bug-reports: https://github.com/holmusk/servant-hmac-auth/issues +license: MIT +license-file: LICENSE +author: Holmusk +maintainer: tech@holmusk.com +copyright: 2018 Holmusk +category: Web, Cryptography +build-type: Simple +extra-doc-files: README.md + , CHANGELOG.md +tested-with: GHC == 8.4.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 + + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wpartial-fields + -fhide-source-paths + + default-language: Haskell2010 + default-extensions: DeriveGeneric + GeneralizedNewtypeDeriving + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TypeApplications + +test-suite servant-hmac-auth-test + 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 diff --git a/src/Servant/Auth/Hmac.hs b/src/Servant/Auth/Hmac.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Hmac.hs @@ -0,0 +1,11 @@ +{- | Servant authentication with HMAC. Contains server and client +implementation. +-} + +module Servant.Auth.Hmac + ( module Hmac + ) where + +import Servant.Auth.Hmac.Client as Hmac +import Servant.Auth.Hmac.Crypto as Hmac +import Servant.Auth.Hmac.Server as Hmac diff --git a/src/Servant/Auth/Hmac/Client.hs b/src/Servant/Auth/Hmac/Client.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Hmac/Client.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} + +-- | Servant client authentication. + +module Servant.Auth.Hmac.Client + ( HmacClientM (..) + , runHmacClient + , hmacClient + ) where + +import Control.Monad ((>=>)) +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, + runClientM) +import Servant.Client.Core (RunClient (..), clientIn) +import Servant.Client.Internal.HttpClient (requestToClientRequest) + +import Servant.Auth.Hmac.Crypto (RequestPayload (..), SecretKey, Signature (..), authHeaderName, + requestSignature) + +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) + + +-- | Environment for 'HmacClientM'. +data HmacSettings = HmacSettings + { hmacSigner :: SecretKey -> ByteString -> Signature + , hmacSecretKey :: SecretKey + } + +{- | @newtype@ wrapper over 'ClientM' that signs all outgoing requests +automatically. +-} +newtype HmacClientM a = HmacClientM + { runHmacClientM :: ReaderT HmacSettings ClientM a + } deriving (Functor, Applicative, Monad, MonadIO, MonadReader HmacSettings) + +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 + +instance RunClient HmacClientM where + runRequest :: Servant.Request -> HmacClientM Servant.Response + runRequest = hmacClientSign >=> hmacifyClient . runRequest + + streamingRequest :: Servant.Request -> HmacClientM Servant.StreamingResponse + streamingRequest = hmacClientSign >=> hmacifyClient . streamingRequest + + throwServantError :: ServantError -> HmacClientM a + throwServantError = hmacifyClient . throwServantError + +runHmacClient + :: (SecretKey -> ByteString -> Signature) -- ^ Signing function + -> SecretKey -- ^ Secret key to sign all requests + -> ClientEnv + -> HmacClientM a + -> IO (Either ServantError a) +runHmacClient hmacSigner hmacSecretKey env client = + runClientM (runReaderT (runHmacClientM client) HmacSettings{..}) env + +-- | Generates a set of client functions for an API. +hmacClient :: forall api . HasClient HmacClientM api => Client HmacClientM api +hmacClient = Proxy @api `clientIn` Proxy @HmacClientM + +---------------------------------------------------------------------------- +-- Internals +---------------------------------------------------------------------------- + +servantRequestToPayload :: BaseUrl -> Servant.Request -> RequestPayload +servantRequestToPayload url sreq = RequestPayload + { rpMethod = Client.method req + , rpContent = toBsBody $ Client.requestBody req + , rpHeaders = ("Host", fullHostName) + : ("Accept-Encoding", "gzip") + : Client.requestHeaders req + + , rpRawUrl = fullHostName <> Client.path req <> Client.queryString req + } + where + req :: Client.Request + req = requestToClientRequest url sreq + { Servant.requestQueryString = + fromList $ sort $ toList $ Servant.requestQueryString sreq + } + + + fullHostName :: ByteString + fullHostName = Client.host req <> ":" <> fromString (show (Client.port req)) + + 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. + +@ +Authentication: HMAC +@ +-} +signRequestHmac + :: (SecretKey -> ByteString -> Signature) -- ^ Signing function + -> SecretKey -- ^ Secret key that was used for signing 'Request' + -> BaseUrl -- ^ Base url for servant request + -> Servant.Request -- ^ Original request + -> Servant.Request -- ^ Signed request +signRequestHmac signer sk url req = do + let payload = servantRequestToPayload url req + let signature = requestSignature signer sk payload + let authHead = (authHeaderName, "HMAC " <> unSignature signature) + req { Servant.requestHeaders = authHead <| Servant.requestHeaders req } diff --git a/src/Servant/Auth/Hmac/Crypto.hs b/src/Servant/Auth/Hmac/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Hmac/Crypto.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Crypto primitives for hmac signing. + +module Servant.Auth.Hmac.Crypto + ( -- * Crypto primitives + SecretKey (..) + , Signature (..) + , sign + , signSHA256 + + -- * Request signing + , RequestPayload (..) + , requestSignature + , verifySignatureHmac + + -- * Internals + , authHeaderName + ) where + +import Crypto.Hash (hash) +import Crypto.Hash.Algorithms (MD5, SHA256) +import Crypto.Hash.IO (HashAlgorithm) +import Crypto.MAC.HMAC (HMAC (hmacGetDigest), hmac) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (foldedCase) +import Data.List (sort, uncons) +import Network.HTTP.Types (Header, HeaderName, Method, RequestHeaders) + +import qualified Data.ByteArray as BA (convert) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Lazy as LBS + +-- | The wraper for the secret key. +newtype SecretKey = SecretKey + { unSecretKey :: ByteString + } + +-- | Hashed message used as the signature. Encoded in Base64. +newtype Signature = Signature + { unSignature :: ByteString + } deriving (Eq) + +{- | Compute the hashed message using the supplied hashing function. And then +encode the result in the Base64 encoding. +-} +sign :: forall algo . (HashAlgorithm algo) + => SecretKey -- ^ Secret key to use + -> ByteString -- ^ Message to MAC + -> Signature -- ^ Hashed message +sign (SecretKey sk) msg = Signature + $ Base64.encode + $ BA.convert + $ hmacGetDigest + $ hmac @_ @_ @algo sk msg +{-# INLINE sign #-} + +-- | 'sign' function specialized for 'SHA256' cryptographic algorithm. +signSHA256 :: SecretKey -> ByteString -> Signature +signSHA256 = sign @SHA256 +{-# INLINE signSHA256 #-} + +---------------------------------------------------------------------------- +-- Request signing +---------------------------------------------------------------------------- + +-- | Part of the HTTP request that will be signed. +data RequestPayload = RequestPayload + { rpMethod :: !Method -- ^ HTTP method + , rpContent :: !ByteString -- ^ Raw content of HTTP body + , rpHeaders :: !RequestHeaders -- ^ All headers of HTTP request + , 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: + +@ +stringToSign = HTTP-Method ++ "\n" + ++ Content-MD5 ++ "\n" + ++ HeadersNormalized ++ "\n" + ++ RawURL + +signature = encodeBase64 + $ signHmac yourSecretKey + $ encodeUtf8 stringToSign +@ + +where @HeadersNormalized@ are headers decapitalzed, joined, sorted +alphabetically and intercalated with line break. So, if you have headers like +these: + +@ +User-Agent: Mozilla/5.0 +Host: foo.bar.com +@ + +the result of header normalization will look like this: + +@ +hostfoo.bar.com +user-agentMozilla/5.0 +@ +-} +requestSignature + :: (SecretKey -> ByteString -> Signature) -- ^ Signing function + -> SecretKey -- ^ Secret key to use + -> RequestPayload -- ^ Payload to sign + -> Signature +requestSignature signer sk = signer sk . createStringToSign + where + createStringToSign :: RequestPayload -> ByteString + createStringToSign RequestPayload{..} = BS.intercalate "\n" + [ rpMethod + , hashMD5 rpContent + , normalizeHeaders rpHeaders + , rpRawUrl + ] + + normalizeHeaders :: [Header] -> ByteString + normalizeHeaders = BS.intercalate "\n" . sort . map normalize + where + normalize :: Header -> ByteString + normalize (name, value) = foldedCase name <> value + +{- | This function takes signing function @signer@ and secret key and expects +that given 'Request' has header: + +@ +Authentication: HMAC +@ + +It checks whether @@ is true request signature. Function returns 'Nothing' +if it is true, and 'Just' error message otherwise. +-} +verifySignatureHmac + :: (SecretKey -> ByteString -> Signature) -- ^ Signing function + -> SecretKey -- ^ Secret key that was used for signing 'Request' + -> RequestPayload + -> Maybe LBS.ByteString +verifySignatureHmac signer sk signedPayload = case unsignedPayload of + Left err -> Just err + Right (pay, sig) -> if sig == requestSignature signer sk pay + then Nothing + else Just "Signatures don't match" + where + -- Extracts HMAC signature from request and returns request with @authHeaderName@ header + unsignedPayload :: Either LBS.ByteString (RequestPayload, Signature) + unsignedPayload = case extractOn isAuthHeader $ rpHeaders signedPayload of + (Nothing, _) -> Left "No 'Authentication' header" + (Just (_, val), headers) -> case BS.stripPrefix "HMAC " val of + Just sig -> Right + ( signedPayload { rpHeaders = headers } + , Signature sig + ) + Nothing -> Left "Can not strip 'HMAC' prefix in header" + +---------------------------------------------------------------------------- +-- Internals +---------------------------------------------------------------------------- + +authHeaderName :: HeaderName +authHeaderName = "Authentication" + +isAuthHeader :: Header -> Bool +isAuthHeader = (== authHeaderName) . fst + +hashMD5 :: ByteString -> ByteString +hashMD5 = BA.convert . hash @_ @MD5 + +{- | Removes and returns first element from list that satisfies given predicate. + +>>> extractOn (== 3) [1..5] +(Just 3, [1,2,4,5]) +>>> extractOn (== 3) [5..10] +(Nothing,[5,6,7,8,9,10]) +-} +extractOn :: (a -> Bool) -> [a] -> (Maybe a, [a]) +extractOn p l = + let (before, after) = break p l + in case uncons after of + Nothing -> (Nothing, l) + Just (x, xs) -> (Just x, before ++ xs) diff --git a/src/Servant/Auth/Hmac/Server.hs b/src/Servant/Auth/Hmac/Server.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Hmac/Server.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Servant server authentication. + +module Servant.Auth.Hmac.Server + ( HmacAuth + , HmacAuthContextHandlers + , HmacAuthContext + , hmacAuthServerContext + , hmacAuthHandler + ) 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 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 qualified Data.ByteString as BS +import qualified Network.Wai as Wai (Request) + + +type HmacAuth = AuthProtect "hmac-auth" + +type instance AuthServerData HmacAuth = () + +type HmacAuthContextHandlers = '[AuthHandler Wai.Request ()] +type HmacAuthContext = Context HmacAuthContextHandlers + +hmacAuthServerContext + :: (SecretKey -> ByteString -> Signature) -- ^ Signing function + -> SecretKey -- ^ Secret key that was used for signing 'Request' + -> HmacAuthContext +hmacAuthServerContext signer sk = hmacAuthHandler signer sk :. EmptyContext + +hmacAuthHandler + :: (SecretKey -> ByteString -> Signature) -- ^ Signing function + -> SecretKey -- ^ Secret key that was used for signing 'Request' + -> AuthHandler Wai.Request () +hmacAuthHandler 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 } + +---------------------------------------------------------------------------- +-- 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 + +waiRequestToPayload :: Wai.Request -> IO RequestPayload +waiRequestToPayload req = getWaiRequestBody req >>= \body -> pure RequestPayload + { rpMethod = requestMethod req + , rpContent = body + , rpHeaders = requestHeaders req + , rpRawUrl = fromMaybe mempty (requestHeaderHost req) <> rawPathInfo req <> rawQueryString req + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,3 @@ +main :: IO () +main = putStrLn ("Test suite not yet implemented" :: String) +