diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/example/server/Example.hs b/example/server/Example.hs new file mode 100644 --- /dev/null +++ b/example/server/Example.hs @@ -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" diff --git a/example/server/Test.hs b/example/server/Test.hs new file mode 100644 --- /dev/null +++ b/example/server/Test.hs @@ -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 + diff --git a/servant-auth-hmac.cabal b/servant-auth-hmac.cabal new file mode 100644 --- /dev/null +++ b/servant-auth-hmac.cabal @@ -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 +-- 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 diff --git a/src/Servant/Server/Experimental/Auth/HMAC.hs b/src/Servant/Server/Experimental/Auth/HMAC.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Experimental/Auth/HMAC.hs @@ -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 + 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)