servant-hmac-auth (empty) → 0.0.0
raw patch · 11 files changed
+802/−0 lines, 11 filesdep +aesondep +basedep +base64-bytestringsetup-changed
Dependencies added: aeson, base, base64-bytestring, binary, bytestring, case-insensitive, containers, cryptonite, http-client, http-types, memory, mtl, servant, servant-client, servant-client-core, servant-hmac-auth, servant-server, transformers, wai, warp
Files
- CHANGELOG.md +12/−0
- LICENSE +21/−0
- README.lhs +127/−0
- README.md +127/−0
- Setup.hs +2/−0
- servant-hmac-auth.cabal +107/−0
- src/Servant/Auth/Hmac.hs +11/−0
- src/Servant/Auth/Hmac/Client.hs +133/−0
- src/Servant/Auth/Hmac/Crypto.hs +185/−0
- src/Servant/Auth/Hmac/Server.hs +74/−0
- test/Spec.hs +3/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.lhs view
@@ -0,0 +1,127 @@+# 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
@@ -0,0 +1,127 @@+# 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)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-hmac-auth.cabal view
@@ -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
+ src/Servant/Auth/Hmac.hs view
@@ -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
+ src/Servant/Auth/Hmac/Client.hs view
@@ -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 <signature>+@+-}+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 }
+ src/Servant/Auth/Hmac/Crypto.hs view
@@ -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 <signature>+@++It checks whether @<signature>@ 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)
+ src/Servant/Auth/Hmac/Server.hs view
@@ -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+ }
+ test/Spec.hs view
@@ -0,0 +1,3 @@+main :: IO ()+main = putStrLn ("Test suite not yet implemented" :: String)+