servant-auth-hmac (empty) → 0.1.0.0
raw patch · 6 files changed
+688/−0 lines, 6 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, base64-bytestring, blaze-html, blaze-markup, bytestring, case-insensitive, cereal, containers, cryptonite, data-default, exceptions, hspec, hspec-expectations, hspec-wai, http-media, http-types, memory, mtl, random, servant, servant-auth-hmac, servant-blaze, servant-server, string-class, text, time, transformers, unix, wai, wai-extra, warp, with-location
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- example/server/Example.hs +100/−0
- example/server/Test.hs +182/−0
- servant-auth-hmac.cabal +118/−0
- src/Servant/Server/Experimental/Auth/HMAC.hs +256/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Al Zohali++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Al Zohali nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/server/Example.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RecordWildCards #-}++import AuthAPI+import Data.Default+import Data.IORef (newIORef, readIORef)+import Network.Wai (Application)+import Network.Wai.Handler.Warp (run)+import Servant (Proxy(..), Server, (:>), (:<|>)(..), Raw, Get, Capture)+import Servant.API.ContentTypes (JSON)+import Servant.HTML.Blaze+import Servant.Server (Context ((:.), EmptyContext), serveWithContext)+import Servant.Server.Experimental.Auth.HMAC+import Servant.Utils.StaticFiles (serveDirectory)+import System.Posix.Directory (getWorkingDirectory)+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 (Markup)+import qualified Data.Map as Map+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+++type ExampleAPI = Get '[HTML] Markup+ :<|> "static" :> Raw+ :<|> "api" :> "templates" :> Get '[JSON] [String]+ :<|> "api" :> "templates" :> Capture "name" String :> Get '[HTML] Markup+ :<|> "api" :> AuthAPI+++server :: FilePath -> Storage -> Server ExampleAPI+server root storage = serveIndex+ :<|> serveStatic+ :<|> serveTemplates+ :<|> serveTemplate+ :<|> serveAuth storage where++ serveIndex = return indexPage+ serveStatic = serveDirectory root+ serveTemplates = return $ map fst templates+ serveTemplate name = return $ (maybe defaultPage id) (lookup name templates)++ templates = [+ ("home" , homePage)+ , ("login" , loginPage)+ , ("private", privatePage)+ ]+++app :: FilePath -> Storage -> AuthTokenProvider -> AuthHmacSettings -> Application+app root storage tokenProvider settings = serveWithContext+ (Proxy :: Proxy ExampleAPI)+ ((defaultAuthHandler tokenProvider settings) :. EmptyContext)+ (server root storage)++main :: IO ()+main = do+ root <- (++ "/example/client/result/static") <$> getWorkingDirectory+ storage <- newIORef $ Map.empty+ let tokenProvider username = (Map.lookup username) <$> (readIORef storage)+ run 8080 (app root storage tokenProvider (def::AuthHmacSettings))+++indexPage :: H.Html+indexPage = H.docTypeHtml $ do+ H.head $ do+ H.script ! A.src "static/app.js" ! A.type_ "application/javascript;version=1.8" $ ""+ H.body $ do+ H.div ! A.class_ "app" $ "Loading..."++homePage :: H.Html+homePage = do+ H.p "This is an example of using servant-auth-hmac library."+ H.p "Use login page to get access to the private page."++loginPage :: H.Html+loginPage = do+ H.form ! A.method "post" ! A.action "/api/login" $ do+ H.table $ do+ H.tr $ do+ H.td $ "username:"+ H.td $ H.input ! A.type_ "text" ! A.name "username"+ H.tr $ do+ H.td $ "password:"+ H.td $ H.input ! A.type_ "password" ! A.name "password"+ H.input ! A.type_ "submit"+ H.p ! A.class_ "feedback" $ ""++privatePage :: H.Html+privatePage = do+ H.p $ H.b "username: " >> "{{username}}"+ H.p $ H.b "token: " >> "{{token}}"+ H.p $ H.b "secret: " >> "{{secret}}"++defaultPage :: H.Html+defaultPage = H.p "not found"
+ example/server/Test.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++import AuthAPI+import Control.Monad (unless)+import Data.IORef (newIORef, readIORef)+import Data.Aeson (encode, decode)+import Data.Default (def)+import Data.Monoid ((<>))+import Data.WithLocation (WithLocation)+import Data.String.Class (ConvStrictByteString(..))+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Network.Wai (Application)+import Test.Hspec (Spec, hspec, describe, it)+import Test.Hspec.Expectations (expectationFailure)+import Test.Hspec.Wai (WaiExpectation, WaiSession, ResponseMatcher, (<:>))+import Test.Hspec.Wai (request, matchHeaders, matchBody, shouldRespondWith, liftIO, with, get)+import Servant.Server.Experimental.Auth.HMAC+import qualified Data.Map as Map+import Servant (Proxy(..))+import Servant.Server (Context ((:.), EmptyContext), serveWithContext)+import Network.HTTP.Types (Header, methodGet, methodPost)+import Network.HTTP.Types.Header (hWWWAuthenticate, hAuthorization, hContentType)+import Network.Wai.Test (SResponse(..))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Base64 as Base64 (encode)+import qualified Data.ByteString.Char8 as BSC8+import qualified Data.ByteString.Lazy.Char8 as BSLC8+++main :: IO ()+main = hspec spec++spec :: Spec+spec = with (app (def :: AuthHmacSettings)) $ do++ describe "POST /login" $ do+ let username = "mr_foo"++ it "rejects a request with wrong username/password" $ do+ let loginArgs = encode $ LoginArgs {+ laUsername = username+ , laPassword = "password"+ }+ request methodPost "/login" [(hContentType, "application/json")] loginArgs+ `shouldRespondWith` 403++ it "accepts a request with correct username/password" $ do+ let loginArgs = encode $ LoginArgs {+ laUsername = username+ , laPassword = "password1"+ }+ request methodPost "/login" [(hContentType, "application/json")] loginArgs+ `shouldRespondWith` 200+++ describe "GET /secret" $ do+ let username = "mr_bar"++ it "rejects a request without authoriaztion header" $+ get ("/secret/" <> username) `shouldRespondWith` 401 {+ matchHeaders = [hWWWAuthenticate <:> "HMAC"]+ , matchBody = Just . BSLC8.pack . show $ NotAuthoirized+ }++ it "rejects a request with incorrect authorization header" $ do+ let s = "nope"+ let r = request methodGet ("/secret/" <> username) [("Authorization", s)] ""+ r `shouldRespondWith` 403 {+ matchBody = Just . BSLC8.pack . show $ BadAuthorizationHeader s+ }++ it "rejects a request without appropriate parameters" $ do+ let r = request methodGet ("/secret/" <> username) [mkAuthHeader "" "" Nothing] ""+ r `shouldRespondWith` 403 {+ matchBody = Just . BSLC8.pack . show $ AuthorizationParameterNotFound "timestamp"+ }++ it "rejects an expired request" $ do+ let hdr = mkAuthHeader "" "" $ Just (posixSecondsToUTCTime 0)+ let r = request methodGet ("/secret/" <> username) [hdr] ""+ r -: shouldRespondWith' (startsWith "RequestExpired ") :- 403+++ it "rejects a request without non-existing token" $ do+ hdr <- liftIO $ mkAuthHeader (BSC8.unpack username) "" . Just <$> getCurrentTime+ let r = request methodGet ("/secret/" <> username) [hdr] ""+ r `shouldRespondWith` 403 {+ matchBody = Just . BSLC8.pack . show $ TokenNotFound username+ }++ it "rejects a request with wrong signature" $ do+ let loginArgs = encode $ LoginArgs {+ laUsername = BSC8.unpack username+ , laPassword = "letmein"+ }+ _ <- request methodPost "/login" [(hContentType, "application/json")] loginArgs++ hdr <- liftIO $ mkAuthHeader (BSC8.unpack username) "" . Just <$> getCurrentTime+ let r = request methodGet ("/secret/" <> username) [hdr] ""++ r -: shouldRespondWith' (startsWith "IncorrectHash ") :- 403+++ it "accepts a request with correct signature" $ do+ let loginArgs = encode $ LoginArgs {+ laUsername = BSC8.unpack username+ , laPassword = "letmein"+ }++ (SResponse {..}) <- request methodPost "/login" [(hContentType, "application/json")] loginArgs++ currentTime <- liftIO $ getCurrentTime++ let hash = Base64.encode $ getRequestHash+ (def::AuthHmacSettings)+ (maybe "" id (decode simpleBody))+ (BSC8.unpack username)+ currentTime+ ("/secret/" <> username)+ "GET"+ []+ ""++ let hdr = mkAuthHeader (BSC8.unpack username) hash (Just currentTime)+ let r = request methodGet ("/secret/" <> username) [hdr] ""++ r -: shouldRespondWith' (startsWith "\"Freedom is Slavery\"") :- 200+++mkAuthHeader :: AuthHmacAccount -> BS.ByteString -> Maybe UTCTime -> Header+mkAuthHeader account hash mt = let+ timestampStrings = maybe [] (\timestamp -> [+ ",timestamp=\""+ , BSC8.pack . show $ ((truncate . utcTimeToPOSIXSeconds $ timestamp)::Integer)+ , "\""+ ]) $ mt+ in (hAuthorization, BS.concat $ [+ "HMAC "+ , "hash=\"", hash, "\""+ , ",id=\"", toStrictByteString account, "\""+ ] ++ timestampStrings)+++app :: AuthHmacSettings -> IO Application+app authSettings = do+ storage <- newIORef $ Map.empty+ let tokenProvider username = (Map.lookup username) <$> (readIORef storage)++ return $ serveWithContext+ (Proxy :: Proxy AuthAPI)+ ((defaultAuthHandler tokenProvider authSettings) :. EmptyContext)+ (serveAuth storage)+++-- TODO https://github.com/hspec/hspec-wai/issues/35+infixr 0 -:, :-+data Infix f y = f :- y++(-:) :: a -> Infix (a -> b -> c) b -> c+x -:f:- y = x `f` y++shouldRespondWith' :: WithLocation(+ (BSLC8.ByteString -> Bool)+ -> WaiSession SResponse+ -> ResponseMatcher+ -> WaiExpectation)++shouldRespondWith' bodyMatcher response expectation = do+ r@(SResponse {..}) <- response+ liftIO $ unless (bodyMatcher simpleBody) $ expectationFailure $ unlines [+ "match failed for the body:"+ , BSLC8.unpack simpleBody+ ]+ (return r) `shouldRespondWith` expectation++startsWith :: BSL.ByteString -> BSL.ByteString -> Bool+startsWith prefix s = prefix == BSL.take (BSL.length prefix) s+
+ servant-auth-hmac.cabal view
@@ -0,0 +1,118 @@+name: servant-auth-hmac+version: 0.1.0.0+synopsis: Authentication via hashed message code (HMAC) based on RFC1945.+license: BSD3+license-file: LICENSE+author: Al Zohali+maintainer: Al Zohali <zohl@fmap.me>+-- copyright:+category: Web+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/zohl/servant-auth-hmac.git++flag dev+ description: Turn on development settings.+ manual: True+ default: False++library+ hs-source-dirs: src+ exposed-modules:+ Servant.Server.Experimental.Auth.HMAC++ build-depends: base >= 4.7 && < 5.0+ , attoparsec >= 0.13.0 && < 0.14+ , base64-bytestring >= 1.0.0 && < 1.1+ , bytestring >= 0.10.8 && < 0.11+ , case-insensitive >= 1.2.0 && < 1.3+ , cryptonite >= 0.17 && < 0.20+ , data-default >= 0.7.1 && < 0.8+ , exceptions >= 0.8.3 && < 0.9+ , http-types >= 0.9.1 && < 0.10+ , memory >= 0.13 && < 0.14+ , servant >= 0.7.1 && < 0.8+ , servant-server >= 0.7.1 && < 0.8+ , string-class >= 0.1.6 && < 0.2+ , time >= 1.6.0 && < 1.7+ , transformers >= 0.5.2 && < 0.6+ , wai >= 3.2.1 && < 3.3+ default-language: Haskell2010++ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall+++executable example+ hs-source-dirs: example/server+ main-is: Example.hs+ build-depends: base >= 4.7 && < 5.0+ , aeson >= 0.11.2 && < 0.12+ , blaze-html >= 0.8.1 && < 0.9+ , blaze-markup >= 0.7.1 && < 0.8+ , bytestring >= 0.10.8 && < 0.11+ , cereal >= 0.5.3 && < 0.6+ , containers >= 0.5.7 && < 0.6+ , data-default >= 0.7.1 && < 0.8+ , mtl >= 2.2.1 && < 2.3+ , http-media >= 0.6.4 && < 0.7+ , random >= 1.1 && < 1.2+ , servant >= 0.7.1 && < 0.8+ , servant-auth-hmac+ , servant-blaze >= 0.7.1 && < 0.8+ , servant-server >= 0.7.1 && < 0.8+ , string-class >= 0.1.6 && < 0.2+ , text >= 1.2.2 && < 1.3+ , transformers >= 0.5.2 && < 0.6+ , unix >= 2.7.2 && < 2.8+ , wai >= 3.0 && < 3.3+ , warp >= 3.0.11 && < 3.3+ default-language: Haskell2010++ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall+++test-suite tests+ type: exitcode-stdio-1.0++ hs-source-dirs: example/server+ main-is: Test.hs++ build-depends: base >= 4.7 && < 5.0+ , aeson >= 0.11.2 && < 0.12+ , base64-bytestring >= 1.0.0 && < 1.1+ , bytestring >= 0.10.8 && < 0.11+ , case-insensitive >= 1.2.0 && < 1.3+ , cereal >= 0.5.3 && < 0.6+ , containers >= 0.5.7 && < 0.6+ , cryptonite >= 0.17 && < 0.20+ , data-default >= 0.7.1 && < 0.8+ , hspec-expectations+ , hspec-wai+ , hspec+ , http-types >= 0.9.1 && < 0.10+ , random >= 1.1 && < 1.2+ , servant >= 0.7.1 && < 0.8+ , servant-auth-hmac+ , servant-server >= 0.7.1 && < 0.8+ , string-class >= 0.1.6 && < 0.2+ , time >= 1.6.0 && < 1.7+ , transformers >= 0.5.2 && < 0.6+ , wai >= 3.2.1 && < 3.3+ , wai-extra+ , with-location++ default-language: Haskell2010++ if flag(dev)+ ghc-options: -Wall -Werror+ else+ ghc-options: -O2 -Wall
+ src/Servant/Server/Experimental/Auth/HMAC.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleContexts #-}++{-|+ Module: Servant.Server.Experimental.Auth.HMAC+ Copyright: (c) 2016 Al Zohali+ License: BSD3+ Maintainer: Al Zohali <zohl@fmap.me>+ Stability: experimental+++ = Description+ Authentication via hashed message code (HMAC) based on RFC1945.+-}++module Servant.Server.Experimental.Auth.HMAC (+ AuthHmacAccount+ , AuthHmacToken+ , AuthHmacSettings(..)+ , AuthTokenProvider+ , defaultAuthHandler++ , AuthHmacException(..)+ , parseAuthorization+ , getRequestHash+ ) where++import Control.Applicative+import Control.Exception (Exception)+import Control.Monad (when)+import Control.Monad.Catch (MonadThrow, throwM, catch)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Crypto.Hash (HashAlgorithm(..))+import Crypto.Hash.Algorithms (SHA256)+import Crypto.MAC.HMAC (hmac, HMAC)+import Data.Attoparsec.ByteString+import Data.Attoparsec.ByteString.Char8 (char, stringCI)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (fromStrict)+import Data.CaseInsensitive (CI(..))+import Data.Default+import Data.List (sort)+import Data.String.Class (ConvStrictByteString(..))+import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime, NominalDiffTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Data.Typeable+import Network.HTTP.Types.Header (Header, HeaderName, hWWWAuthenticate, hAuthorization)+import Network.HTTP.Types.Method (Method)+import Network.Wai (Request(..), requestHeaders)+import Prelude hiding (takeWhile)+import Servant (throwError)+import Servant.API.Experimental.Auth (AuthProtect)+import Servant.Server (ServantErr(..), err401, err403, errBody, Handler)+import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as Base64 (encode)+import qualified Data.ByteString.Char8 as BSC8+import qualified Data.CaseInsensitive as CI (mk)+++-- | A type family that maps user-defined account type to+-- AuthServerData. This should be instantiated as the following:+-- @+-- type instance AuthHmacAccount = UserDefinedType+-- @+type family AuthHmacAccount++-- | A type family that maps user-defined token type to+-- AuthServerData. This should be instantiated as the following:+-- @+-- type instance AuthHmacToken = UserDefinedType+-- @+type family AuthHmacToken++-- | A function to retrieve token by given account.+type AuthTokenProvider = AuthHmacAccount -> IO (Maybe AuthHmacToken)++type AuthHmacData = (AuthHmacAccount, AuthHmacToken)+type instance AuthServerData (AuthProtect ("hmac-auth")) = AuthHmacData+++-- | Options that determine authentication mechanisms.+data AuthHmacSettings where+ AuthHmacSettings :: (HashAlgorithm h) => {+ ahsMaxAge :: NominalDiffTime+ , ahsRealm :: Maybe ByteString+ , ahsHashAlgorithm :: Proxy h+ , ahsHeaderFilter :: HeaderName -> Bool+ } -> AuthHmacSettings+++instance Default AuthHmacSettings+ where def = AuthHmacSettings {+ ahsMaxAge = fromIntegral (10 * 60 :: Integer) -- 10 minutes+ , ahsRealm = def+ , ahsHashAlgorithm = Proxy :: Proxy SHA256+ , ahsHeaderFilter = ( == "Content-Type")+ }++-- | The exception is thrown when something goes wrong with this package.+data AuthHmacException+ = NotAuthoirized+ -- ^ Thrown when there is no Authorization header in the request.+ | BadAuthorizationHeader ByteString+ -- ^ Thrown when failed to parse Authorization header. Argument of this+ -- constructor: actual header.+ | AuthorizationParameterNotFound ByteString+ -- ^ Thrown when there is missing mandatory parameter in+ -- Authorization header. Argument of this constructor: missing parameter name.+ | RequestExpired UTCTime UTCTime+ -- ^ Thrown when the request has expired. Arguments of this constructor:+ -- expiration time, actual time+ | TokenNotFound ByteString+ -- ^ Thrown when token provider returns 'Nothing'. Argument of this+ -- constructor: string representation of the account.+ | IncorrectHash ByteString ByteString+ -- ^ Thrown when hash in the header and hash or the request differ.+ -- Arguments of this constructor: expected hash, actual hash.+ deriving (Eq, Show, Typeable)++instance (Exception AuthHmacException)+++-- | Extract parameters' values from Authentication header.+parseAuthorization :: (MonadThrow m, ConvStrictByteString AuthHmacAccount)+ => AuthHmacSettings+ -> ByteString+ -> m (ByteString, AuthHmacAccount, UTCTime)++parseAuthorization AuthHmacSettings {..} hdr = either+ (\_ -> throwM $ BadAuthorizationHeader hdr)+ getAuthData+ (parseOnly header hdr) where++ header :: Parser [(ByteString, ByteString)]+ header = do+ _ <- stringCI "HMAC"+ _ <- takeWhile1 isLWS+ authParams <- param `sepBy` (char ',')+ return $ authParams++ isLWS c = (c == 9 || c == 32) -- tab or space+ isNotQuote = (/= 34) -- any but quote++ token = takeWhile1 (inClass "a-zA-Z_-")++ param = do+ name <- token+ _ <- (takeWhile isLWS) *> (char '=') *> (takeWhile isLWS)+ value <- (char '"') *> (takeWhile isNotQuote) <* (char '"')+ return (name, value)++ getAuthData :: (MonadThrow m)+ => [(ByteString, ByteString)]+ -> m (ByteString, AuthHmacAccount, UTCTime)++ getAuthData params = do+ let getParam s = maybe (throwM (AuthorizationParameterNotFound s)) return (lookup s params)+ [hash, accountId, timestamp] <- sequence $ map getParam ["hash", "id", "timestamp"]++ return (+ hash+ , fromStrictByteString accountId+ , posixSecondsToUTCTime . fromIntegral $ (read . BSC8.unpack $ timestamp :: Int))++sign :: forall h. HashAlgorithm h+ => Proxy h -- ^ The hash algorithm to use+ -> ByteString -- ^ The key+ -> ByteString -- ^ The message+ -> ByteString+sign Proxy key msg = BA.convert (hmac key msg :: HMAC h)++-- | Generate hash based on request and account data.+getRequestHash :: (ConvStrictByteString AuthHmacAccount, ConvStrictByteString AuthHmacToken)+ => AuthHmacSettings+ -> AuthHmacToken+ -> AuthHmacAccount+ -> UTCTime+ -> ByteString -- ^ URI+ -> Method+ -> [Header]+ -> ByteString -- ^ Request Body+ -> ByteString++getRequestHash AuthHmacSettings {..} key account timestamp uri method headers body+ = sign ahsHashAlgorithm (toStrictByteString key) $ BS.intercalate "\n" [+ toStrictByteString account+ , BSC8.pack . show $ ((truncate . utcTimeToPOSIXSeconds $ timestamp)::Integer)+ , uri+ , method+ , normalizeHeaders $ filter (\(name, _) -> ahsHeaderFilter name) headers+ , body+ ] where++ normalizeHeaders = BS.intercalate "\n" . sort . map normalize where+ normalize (name, value) = BS.concat [foldedCase name, value]++-- | HMAC handler+defaultAuthHandler :: (ConvStrictByteString AuthHmacAccount, ConvStrictByteString AuthHmacToken)+ => AuthTokenProvider+ -> AuthHmacSettings+ -> AuthHandler Request AuthHmacData++defaultAuthHandler tokenProvider settings@(AuthHmacSettings {..}) = mkAuthHandler handler where++ handler :: Request -> Handler AuthHmacData+ handler req = catch (handler' req) $ \(ex :: AuthHmacException) -> throwError $ case ex of+ NotAuthoirized -> err401 {+ errHeaders = [(+ hWWWAuthenticate+ , maybe "HMAC" (\realm -> BS.concat ["HMAC realm=\"", realm, "\""]) ahsRealm)]+ , errBody = fromStrict $ BSC8.pack $ show ex+ }+ _ -> err403 {+ errBody = fromStrict $ BSC8.pack $ show ex+ }++ handler' :: (MonadThrow m, MonadIO m) => Request -> m AuthHmacData+ handler' req = do++ authHeader <- maybe (throwM NotAuthoirized) return $+ lookup (CI.mk hAuthorization) $ map (\(k, v) -> (CI.mk k, v)) (requestHeaders req)++ (reqHash, account, timestamp) <- parseAuthorization settings $ authHeader++ currentTime <- liftIO getCurrentTime++ let expirationTime = addUTCTime ahsMaxAge timestamp+ when (expirationTime < currentTime) $ throwM (RequestExpired expirationTime currentTime)++ token <- (liftIO $ tokenProvider account)+ >>= maybe (throwM (TokenNotFound (toStrictByteString account))) return++ reqHash' <- liftIO $ Base64.encode <$> getRequestHash+ settings+ token+ account+ timestamp+ (rawPathInfo req)+ (requestMethod req)+ (requestHeaders req)+ <$> (requestBody req)++ when (reqHash /= reqHash') $ throwM (IncorrectHash reqHash reqHash')++ return (account, token)