diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Rodney Lorrimar and Eran Hammer +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its + 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 +HOLDER 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,86 @@ +# Oz Haskell Implementation + +[![Build Status](https://travis-ci.org/rvl/hsoz.svg?branch=master)](https://travis-ci.org/rvl/hsoz) [![Hackage](https://img.shields.io/hackage/v/hsoz.svg)]() + +*hsoz* is a Haskell implementation of the Iron, Hawk, and Oz web +authentication protocols. These protocols originate from the OAuth2 +standardisation process, but are designed to be simpler to implement +for the common case of web applications. + +## Introduction + +In the words of their principal designer: + +**Iron** is a cryptographic utility for sealing a JSON object using +symmetric key encryption with message integrity verification. Or in +other words, it lets you encrypt an object, send it around (in +cookies, authentication credentials, etc.), then receive it back and +decrypt it. The algorithm ensures that the message was not tampered +with, and also provides a simple mechanism for password rotation. + +**Hawk** is an HTTP authentication scheme using a message +authentication code (MAC) algorithm to provide partial HTTP request +cryptographic verification. + +**Oz** is a web authorization protocol based on industry best +practices. Oz combines the Hawk authentication protocol with the +Iron encryption protocol to provide a simple to use and secure +solution for granting and authenticating third-party access to an +API on behalf of a user or an application. + +## Documentation + +The Haddock documentation is on [Hackage](http://hackage.haskell.org/package/hsoz) +and at https://rodney.id.au/docs/hsoz/. + + * [Network.Iron](http://hackage.haskell.org/package/hsoz/docs/Network-Iron.html) + * [Network.Hawk](http://hackage.haskell.org/package/hsoz/docs/Network-Hawk.html) + * [Network.Oz](http://hackage.haskell.org/package/hsoz/docs/Network-Oz.html) + +## Example Usage + +See the [Network.Iron](http://hackage.haskell.org/package/hsoz/docs/Network-Iron.html) +documentation, and the [example](./example/) directory of this +repository. + +## Status + +This is an in-progress experiment in implementing the protocol in +Haskell. + + * **Iron**: complete and tested. + * **Hawk**: complete, test suite under development. + * **Oz**: under construction. + * **Example web application**: under construction. + +*Please note*: until the example application is built, this library +cannot be considered "battle-tested". + +There is also an `org-mode` file: [todo.org](./todo.org?raw=1). + +## Development + +I welcome collaborators, particularly anyone who would like to develop +authentication plugins for frameworks such as +[Snap](http://snapframework.com/) and +[Servant](https://haskell-servant.github.io/). + +### Building with Stack + +``` +stack build +``` + +### Building with Nix + +``` +nix-shell -p cabal2nix --command "cabal2nix --shell . > default.nix" +nix-shell --command "cabal configure" +cabal build +``` + +## Credits + +This module is based on the Javascript code and documentation by Eran +Hammer and others. A fair amount of Hammer's descriptive text has been +incorporated into this documentation, as well as the cool logos. diff --git a/example/HawkServer.hs b/example/HawkServer.hs --- a/example/HawkServer.hs +++ b/example/HawkServer.hs @@ -5,9 +5,9 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Default import qualified Data.Map as M import Data.Monoid -import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) @@ -28,20 +28,21 @@ app :: Application app req respond = do - let opts = Hawk.defaultAuthReqOpts payload <- lazyRequestBody req - res <- Hawk.authenticateRequest opts auth req (Just payload) + res <- Hawk.authenticateRequest def auth req (Just payload) respond $ case res of - Right (Hawk.AuthSuccess creds artifacts user) -> do - let ext = decodeUtf8 <$> shaExt artifacts - let payload = textPayload $ "Hello " <> user <> maybe "" (" " <>) ext - let autho = Hawk.header creds artifacts (Just payload) - responseLBS status200 [payloadCt payload, autho] (payloadData payload) - Left (Hawk.AuthFailBadRequest e _) -> responseLBS badRequest400 [] (L8.pack e) - Left (Hawk.AuthFailUnauthorized _ _ _) -> responseLBS unauthorized401 [plain] "Shoosh!" - Left (Hawk.AuthFailStaleTimeStamp e creds artifacts) -> do - let autho = Hawk.header creds artifacts Nothing - responseLBS unauthorized401 [plain, autho] (L8.pack e) + Right (Hawk.AuthSuccess creds artifacts user) -> let + ext = decodeUtf8 <$> shaExt artifacts + payload = textPayload $ "Hello " <> user <> maybe "" (" " <>) ext + (ok, autho) = Hawk.header res (Just payload) + in responseLBS ok [payloadCt payload, autho] (payloadData payload) + Left f -> let + (status, hdr) = Hawk.header res Nothing + msg = case f of + AuthFailBadRequest e _ -> e + AuthFailUnauthorized e _ _ -> "Shoosh!" + AuthFailStaleTimeStamp e _ _ _ -> e + in responseLBS status [plain, hdr] (L8.pack msg) textPayload :: Text -> PayloadInfo textPayload = PayloadInfo (snd plain) . BL.fromStrict . encodeUtf8 diff --git a/hsoz.cabal b/hsoz.cabal --- a/hsoz.cabal +++ b/hsoz.cabal @@ -1,64 +1,30 @@ name: hsoz -version: 0.0.0.2 +version: 0.0.0.3 synopsis: Iron, Hawk, Oz: Web auth protocols description: - - <> __ - <> __ - <> - . - - __hsoz__ is a Haskell implementation of the Iron, Hawk, and Oz web + hsoz is a Haskell implementation of the Iron, Hawk, and Oz web authentication protocols. These protocols originate from the OAuth2 standardisation process, but are designed to be simpler to implement for the common case of web applications. - . - - This module is based on the Javascript code and documentation by - Eran Hammer and others. A fair amount of Hammer's descriptive text - has been incorporated into this documentation, as well as the cool - logos. - - . - == Introduction - . - In the words of their principal designer: - . - __Iron__ is a cryptographic utility for sealing a JSON object using - symmetric key encryption with message integrity verification. Or in - other words, it lets you encrypt an object, send it around (in - cookies, authentication credentials, etc.), then receive it back and - decrypt it. The algorithm ensures that the message was not tampered - with, and also provides a simple mechanism for password rotation. - . - __Hawk__ is an HTTP authentication scheme using a message - authentication code (MAC) algorithm to provide partial HTTP request - cryptographic verification. - . - __Oz__ is a web authorization protocol based on industry best - practices. Oz combines the Hawk authentication protocol with the - Iron encryption protocol to provide a simple to use and secure - solution for granting and authenticating third-party access to an - API on behalf of a user or an application. - . - == Usage - . The top-level "Network.Iron", "Network.Hawk", "Network.Oz" modules contain further instructions on their usage. There are also some example server and client programs within the . - -homepage: https://github.com/rvl/hsoz#readme +homepage: https://github.com/rvl/hsoz license: BSD3 +license-file: LICENSE author: Rodney Lorrimar maintainer: dev@rodney.id.au copyright: 2016 Rodney Lorrimar category: Web, Authentication build-type: Simple extra-doc-files: images/*.png +extra-source-files: README.md cabal-version: >=1.10 +stability: experimental +bug-reports: https://github.com/rvl/hsoz/issues library hs-source-dirs: src diff --git a/src/Network/Hawk/Algo.hs b/src/Network/Hawk/Algo.hs --- a/src/Network/Hawk/Algo.hs +++ b/src/Network/Hawk/Algo.hs @@ -25,7 +25,7 @@ -- fixme: decide whether this should be bytestring or SecureMem, and -- whether it should be a typeclass. -- | A user-supplied password or generated key. -newtype Key = Key ByteString deriving (Show, Generic, ByteArrayAccess, IsString) +newtype Key = Key ByteString deriving (Show, Eq, Generic, ByteArrayAccess, IsString) -- | The class of HMAC algorithms supported by the Hawk -- protocol. Users of the 'Network.Hawk' module probably won't @@ -56,6 +56,9 @@ instance HawkAlgoCls SHA256 where hawkHash _ bs = b64 (hash bs :: Digest SHA256) hawkMac _ k bs = b64 $ hmacGetDigest (hmac k bs :: HMAC SHA256) + +instance Eq HawkAlgo where + _ == _ = True -- fixme: only used for test assertions currently -- | Inverse of 'show', for parsing @"algorithm"@ fields in JSON -- structures. diff --git a/src/Network/Hawk/Client.hs b/src/Network/Hawk/Client.hs --- a/src/Network/Hawk/Client.hs +++ b/src/Network/Hawk/Client.hs @@ -183,13 +183,10 @@ checkWwwAuthenticateHeader :: Credentials -> ByteString -> Either String POSIXTime checkWwwAuthenticateHeader creds w = do WwwAuthenticateHeader{..} <- parseWwwAuthenticateHeader w - let tsm = calculateTsMac wahTs creds + let tsm = calculateTsMac (ccAlgorithm creds) wahTs if wahTsm `constEqBytes` tsm then Right wahTs else Left "Invalid server timestamp hash" - -calculateTsMac :: POSIXTime -> Credentials -> ByteString -calculateTsMac = undefined -- fixme: achtung minen checkServerAuthorizationHeader :: Credentials -> HeaderArtifacts -> ServerAuthorizationCheck -> POSIXTime diff --git a/src/Network/Hawk/Common.hs b/src/Network/Hawk/Common.hs --- a/src/Network/Hawk/Common.hs +++ b/src/Network/Hawk/Common.hs @@ -4,6 +4,7 @@ ( calculateMac , escapeHeaderAttribute , hawkHeaderString + , calculateTsMac , calculatePayloadHash , checkPayloadHash , checkPayloadHashMaybe @@ -76,7 +77,7 @@ -- fixme: ext and payload hash hawk1String t ts nonce method resource host port = newlines $ [ "hawk.1." <> hawkType t - , (S8.pack . show . round) ts + , S8.pack . show . round $ ts , nonce , S8.map toUpper method , resource @@ -117,6 +118,13 @@ -- fixme: maybe convert payload to strict further up the chain, or -- feed chunks to the hasher calculatePayloadHash algo payload = hawkHash algo (hawk1Payload payload) + +calculateTsMac :: HawkAlgoCls a => a -> POSIXTime -> ByteString +calculateTsMac algo ts = hawkHash algo (hawk1Ts ts) + +hawk1Ts :: POSIXTime -> ByteString +hawk1Ts ts = newlines ["hawk.1.ts", nowSecs ts] + where nowSecs = S8.pack . show . floor -- | The name of the authorization header which the server provides to -- the client. diff --git a/src/Network/Hawk/Middleware.hs b/src/Network/Hawk/Middleware.hs --- a/src/Network/Hawk/Middleware.hs +++ b/src/Network/Hawk/Middleware.hs @@ -22,6 +22,7 @@ import qualified Data.Vault.Lazy as V import qualified Network.Hawk.Server as Hawk +import qualified Network.Hawk.Server.Types as Hawk -- | Whether the middleware should verify the payload hash by reading -- the entire request body. 'Network.Hawk.Server.authenticatePayload' @@ -52,16 +53,14 @@ Right s -> do let vault' = V.insert k s (vault req) req' = req { vault = vault' } + -- fixme: insert Server-Authorization header app req' respond - Left f -> respond $ case f of - Hawk.AuthFailBadRequest e _ -> - responseLBS badRequest400 [plain, wwwAuthHawk] (L8.pack e) - Hawk.AuthFailUnauthorized e _ _ -> - responseLBS unauthorized401 [plain, wwwAuthHawk] (L8.pack e) - Hawk.AuthFailStaleTimeStamp e creds artifacts -> - let autho = Hawk.header creds artifacts Nothing - in responseLBS unauthorized401 [plain, autho] (L8.pack e) + Left f -> respond $ failResponse f -plain, wwwAuthHawk :: Header -plain = (hContentType, "text/plain") -wwwAuthHawk = (hWWWAuthenticate, "Hawk") +failResponse :: Hawk.AuthFail -> Response +failResponse f = responseLBS status [(hContentType, plain), hdr] msg + where + (status, hdr) = Hawk.header (Left f) (Just payload) + msg = L8.pack (Hawk.authFailMessage f) + plain = "text/plain" + payload = Hawk.PayloadInfo plain msg diff --git a/src/Network/Hawk/Server.hs b/src/Network/Hawk/Server.hs --- a/src/Network/Hawk/Server.hs +++ b/src/Network/Hawk/Server.hs @@ -10,10 +10,9 @@ , authenticatePayload , HawkReq(..) , header - , defaultAuthReqOpts - , defaultAuthOpts , AuthReqOpts(..) , AuthOpts(..) + , def , module Network.Hawk.Server.Types ) where @@ -36,8 +35,9 @@ import Data.Time.Clock (NominalDiffTime) import Data.Time.Clock.POSIX import Network.HTTP.Types.Header (Header, hAuthorization, - hContentType) + hContentType, hWWWAuthenticate) import Network.HTTP.Types.Method (Method, methodGet, methodPost) +import Network.HTTP.Types.Status (Status, ok200, badRequest400, unauthorized401) import Network.HTTP.Types.URI (renderQuery) import Network.Wai (Request, rawPathInfo, rawQueryString, queryString, @@ -69,16 +69,11 @@ , saIronLocaltimeOffset :: NominalDiffTime -- fixme: check this is still needed } --- | Default parameters for 'authenticateRequest'. -defaultAuthReqOpts = AuthReqOpts Nothing Nothing Nothing "bewit" defaultAuthOpts - -defaultAuthOpts = AuthOpts (\x t n -> True) 60 0 - instance Default AuthReqOpts where - def = defaultAuthReqOpts + def = AuthReqOpts Nothing Nothing Nothing "bewit" def instance Default AuthOpts where - def = defaultAuthOpts + def = AuthOpts (\x t n -> True) 60 0 -- | Checks the @Authorization@ header of a 'Network.Wai.Request' and -- (optionally) a payload. The header will be parsed and verified with @@ -199,12 +194,13 @@ -> HawkReq -> AuthorizationHeader -> AuthResult t authenticate' now opts (creds, t) hrq@HawkReq{..} sah@AuthorizationHeader{..} = do let arts = headerArtifacts hrq sah - let doCheck = authResult creds arts t - let mac = serverMac creds arts HawkHeader + doCheck = authResult creds arts t + doCheckExp = authResultExp now creds arts t + mac = serverMac creds arts HawkHeader if mac `constEqBytes` sahMac then do doCheck $ checkPayloadHash (scAlgorithm creds) sahHash hrqPayload doCheck $ checkNonce (saCheckNonce opts) (scKey creds) sahNonce sahTs - doCheck $ checkExpiration now (saTimestampSkew opts) sahTs + doCheckExp $ checkExpiration now (saTimestampSkew opts) sahTs doCheck $ Right () else Left (AuthFailUnauthorized "Bad mac" (Just creds) (Just arts)) @@ -214,6 +210,12 @@ authResult c a t (Right _) = Right (AuthSuccess c a t) authResult c a _ (Left e) = Left (AuthFailUnauthorized e (Just c) (Just a)) +-- fixme: refactor with authResult and doCheck +authResultExp :: POSIXTime -> Credentials -> HeaderArtifacts -> t + -> Either String a -> Either AuthFail (AuthSuccess t) +authResultExp _ c a t (Right _) = Right (AuthSuccess c a t) +authResultExp now c a _ (Left e) = Left (AuthFailStaleTimeStamp e now c a) + -- | Constructs artifacts bundle out of the request. headerArtifacts :: HawkReq -> AuthorizationHeader -> HeaderArtifacts headerArtifacts HawkReq{..} AuthorizationHeader{..} = @@ -233,9 +235,17 @@ -- previous call to 'authenticateRequest' (or 'authenticate'). -- -- If a payload is supplied, its hash will be included in the header. -header :: Credentials -> HeaderArtifacts -> Maybe PayloadInfo -> Header -header creds arts payload = (hServerAuthorization, hawkHeaderString (catMaybes parts)) +header :: AuthResult t -> Maybe PayloadInfo -> (Status, Header) +header (Right a) p = (ok200, (hServerAuthorization, headerSuccess a p)) +header (Left e) _ = (status e, (hWWWAuthenticate, headerFail e)) where + status (AuthFailBadRequest _ _) = badRequest400 + status (AuthFailUnauthorized _ _ _) = unauthorized401 + status (AuthFailStaleTimeStamp _ _ _ _) = unauthorized401 + +headerSuccess :: AuthSuccess t -> Maybe PayloadInfo -> ByteString +headerSuccess (AuthSuccess creds arts _) payload = hawkHeaderString (catMaybes parts) + where parts :: [Maybe (ByteString, ByteString)] parts = [ Just ("mac", mac) , fmap ((,) "hash") hash @@ -248,6 +258,21 @@ serverMac Credentials{..} HeaderArtifacts{..} = calculateMac scAlgorithm scKey shaTimestamp shaNonce shaMethod shaResource shaHost shaPort + +headerFail :: AuthFail -> ByteString +headerFail (AuthFailBadRequest e _) = hawkHeaderError e [] +headerFail (AuthFailUnauthorized e _ _) = hawkHeaderError e [] +headerFail (AuthFailStaleTimeStamp e now creds artifacts) = timestampMessage e now creds + +hawkHeaderError :: String -> [(ByteString, ByteString)] -> ByteString +hawkHeaderError e ps = hawkHeaderString (("error", S8.pack e):ps) + +timestampMessage :: String -> POSIXTime -> Credentials -> ByteString +timestampMessage e now creds = hawkHeaderError e parts + where + parts = [ ("ts", (S8.pack . show . floor) now) + , ("tsm", calculateTsMac (scAlgorithm creds) now) + ] -- | User-supplied nonce validation function. type NonceFunc = Key -> POSIXTime -> Nonce -> Bool diff --git a/src/Network/Hawk/Server/Types.hs b/src/Network/Hawk/Server/Types.hs --- a/src/Network/Hawk/Server/Types.hs +++ b/src/Network/Hawk/Server/Types.hs @@ -5,6 +5,7 @@ ( AuthResult , AuthResult'(..) , AuthFail(..) + , authFailMessage , AuthSuccess(..) , Credentials(..) , HeaderArtifacts(..) @@ -32,8 +33,8 @@ -- another authenticated request. data AuthFail = AuthFailBadRequest String (Maybe HeaderArtifacts) | AuthFailUnauthorized String (Maybe Credentials) (Maybe HeaderArtifacts) - | AuthFailStaleTimeStamp String Credentials HeaderArtifacts - deriving Show + | AuthFailStaleTimeStamp String POSIXTime Credentials HeaderArtifacts + deriving (Show, Eq) -- | Successful authentication produces a set of credentials and -- "artifacts". Also included in the result is the result of @@ -41,7 +42,13 @@ data AuthSuccess t = AuthSuccess Credentials HeaderArtifacts t instance Show t => Show (AuthSuccess t) +instance Eq t => Eq (AuthSuccess t) +authFailMessage :: AuthFail -> String +authFailMessage (AuthFailBadRequest e _) = e +authFailMessage (AuthFailUnauthorized e _ _) = e +authFailMessage (AuthFailStaleTimeStamp e _ _ _) = e + ---------------------------------------------------------------------------- -- | A package of values containing the attributes of a HTTP request @@ -65,7 +72,7 @@ data Credentials = Credentials { scKey :: Key -- ^ Key , scAlgorithm :: HawkAlgo -- ^ HMAC - } deriving (Show, Generic) + } deriving (Show, Eq, Generic) -- | HeaderArtifacts are the attributes which are included in the -- verification. The terminology (and spelling) come from the original @@ -83,7 +90,7 @@ , shaExt :: Maybe ByteString , shaApp :: Maybe Text , shaDlg :: Maybe ByteString - } deriving Show + } deriving (Show, Eq) -- | A user-supplied callback to get credentials from a client -- identifier. diff --git a/src/Network/Oz/Application.hs b/src/Network/Oz/Application.hs --- a/src/Network/Oz/Application.hs +++ b/src/Network/Oz/Application.hs @@ -25,6 +25,7 @@ import Data.ByteString (ByteString) import Data.Maybe (fromMaybe, isJust) import Data.Monoid ((<>)) +import Data.Default import Data.Proxy import Data.Text (Text) import qualified Data.Text as T @@ -57,7 +58,7 @@ -- something secret. defaultOzServerOpts :: Key -> OzServerOpts defaultOzServerOpts p = OzServerOpts p defaultLoadApp defaultLoadGrant - defaultTicketOpts Hawk.defaultAuthReqOpts defaultEndpoints + defaultTicketOpts def defaultEndpoints defaultLoadApp :: OzLoadApp defaultLoadApp _ = return $ Left "ozLoadApp not set" @@ -173,11 +174,12 @@ Left f -> hawkAuthFail f -- respond to failed hawk authentication + -- fixme: see also: Hawk.Middleware.failResponse hawkAuthFail :: Hawk.AuthFail -> ActionM a - hawkAuthFail (Hawk.AuthFailBadRequest e _) = Boom.badRequest e - hawkAuthFail (Hawk.AuthFailUnauthorized e _ _) = Boom.unauthorized e + hawkAuthFail (Hawk.AuthFailBadRequest e _) = Boom.badRequest e + hawkAuthFail (Hawk.AuthFailUnauthorized e _ _) = Boom.unauthorized e -- fixme: need to send back server's time so client can apply offset - hawkAuthFail (Hawk.AuthFailStaleTimeStamp e c a) = Boom.unauthorized e + hawkAuthFail (Hawk.AuthFailStaleTimeStamp e t c a) = Boom.unauthorized e loadAppAction appId = do appCfg <- liftIO $ loadApp appId diff --git a/test/Network/Hawk/Tests.hs b/test/Network/Hawk/Tests.hs --- a/test/Network/Hawk/Tests.hs +++ b/test/Network/Hawk/Tests.hs @@ -3,11 +3,14 @@ module Network.Hawk.Tests (tests) where import Data.Either (isRight) +import Data.Maybe (isJust) import Data.Default import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BL import Network.Wai (Request(..), defaultRequest) import Network.HTTP.Client (Response(..)) import Network.HTTP.Client.Internal (Response(..)) +import Network.HTTP.Types (Method, RequestHeaders) import Network.HTTP.Types.Status (ok200) import Data.Text.Encoding (decodeUtf8) @@ -24,13 +27,25 @@ tests :: TestTree tests = testGroup "Network.Hawk" - [ testCase "generates a header then successfully parses it" test01 - --, testCase "generates a header then successfully parses it (WAI request)" test02 - , testCase "generates a header then successfully parses it (absolute request uri)" test03 + [ testGroup "Server" + [ test01 + , test02 + , test03 + , test04 + --, testCase "generates a header then successfully parse it (no server header options)" boring + --, testCase "generates a header then successfully parse it (with hash)" duplicate + , test05 + , test06 + , test07 + , test08 + --, testCase "generates a header then fail authentication due to bad hash" duplicate + , test09 + ] + , testGroup "header" [ testHeader01 ] ] -makeCreds :: Client.ClientId -> (Client.Credentials, Server.CredentialsFunc IO String) -makeCreds i = (cc, \i -> return sc) +makeCreds :: Client.ClientId -> (Client.Credentials, Server.CredentialsFunc IO String, String) +makeCreds i = (cc, \i -> return sc, user) where cc = Client.Credentials i key algo sc = Right (Server.Credentials key algo, user) @@ -38,9 +53,8 @@ algo = if i == "1" then HawkAlgo SHA1 else HawkAlgo SHA256 user = "steve" -test01 :: Assertion -test01 = do - let (creds, credsFunc) = makeCreds "123456" +test01 = testCase "generates a header then successfully parses it" $ do + let (creds, credsFunc, user) = makeCreds "123456" ext = Just "some-app-data" hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "GET" creds Nothing ext let hrq = def @@ -55,26 +69,17 @@ user @?= "steve" Server.shaExt arts @?= Just "some-app-data" --- generates a header then successfully parse it (WAI request) -test02 :: Assertion -test02 = do +test02 = testCase "generates a header then successfully parses it (WAI request)" $ do -- Generate client header - let (creds, credsFunc) = makeCreds "123456" + let (creds, credsFunc, user) = makeCreds "123456" ext = Just "some-app-data" payload = PayloadInfo "text/plain;x=y" "some not so random text" hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "POST" creds (Just payload) ext -- Server verifies client request - let req = defaultRequest - { requestMethod = "POST" - , rawPathInfo = "/resource/4" - , rawQueryString = "?filter=a" - , requestHeaders = [("host", "example.com:8080"), - ("content-type", "text/plain;x=y"), - ("authorization", Client.hdrField hdr)] - } + let req = mockRequest "POST" "/resource/4" "?filter=a" "example.com:8080" payload [("authorization", Client.hdrField hdr)] + r <- Server.authenticateRequest def credsFunc req (Just (payloadData payload)) - -- fixme: Left "Bad mac" isRight r @? "Expected auth success, got: " ++ show r let Right s@(Server.AuthSuccess creds2 arts user) = r user @?= "steve" @@ -83,15 +88,8 @@ -- Client verifies server response let payload2 = PayloadInfo "text/plain" "Some reply" - hdr2 = Server.header creds2 arts (Just payload2) - res = Response - { responseStatus = ok200 - , responseHeaders = [hdr2, ("content-type", payloadContentType payload2)] - , responseBody = payloadData payload2 - , responseVersion = undefined - , responseCookieJar = undefined - , responseClose' = undefined - } + (_, hdr2) = Server.header r (Just payload2) + res = mockResponse payload2 [hdr2] creds2' = clientCreds "" creds2 arts' = clientHeaderArtifacts arts r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired @@ -119,10 +117,27 @@ -- , shaMac :: ByteString } --- generates a header then successfully parse it (absolute request uri) -test03 :: Assertion -test03 = do - let (creds, credsFunc) = makeCreds "123456" +mockRequest :: Method -> ByteString -> ByteString -> ByteString -> PayloadInfo -> RequestHeaders -> Request +mockRequest method path qs host (PayloadInfo ct _) hdrs = defaultRequest + { requestMethod = method + , rawPathInfo = path + , rawQueryString = qs + , requestHeaderHost = Just host + , requestHeaders = [("host", host), ("content-type", ct)] ++ hdrs + } + +mockResponse :: PayloadInfo -> RequestHeaders -> Response BL.ByteString +mockResponse (PayloadInfo ct d) hdrs = Response + { responseStatus = ok200 + , responseHeaders = hdrs ++ [("content-type", ct)] + , responseBody = d + , responseVersion = undefined + , responseCookieJar = undefined + , responseClose' = undefined + } + +test03 = testCase "generates a header then successfully parses it (absolute request uri)" $ do + let (creds, credsFunc, user) = makeCreds "123456" ext = Just "some-app-data" payload = PayloadInfo "text/plain;x=y" "some not so random text" hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "POST" creds (Just payload) ext @@ -136,7 +151,176 @@ } r <- Server.authenticate def credsFunc hrq isRight r @? "Expected auth success, got: " ++ show r + let Right s@(Server.AuthSuccess creds2 arts user) = r + user @?= "steve" + Server.shaExt arts @?= Just "some-app-data" + Server.authenticatePayload s payload @?= Right () + + let payload2 = PayloadInfo "text/plain" "some reply" + fixmeExt2 = "response-specific" + (_, hdr) = Server.header r (Just payload2) + res = mockResponse payload2 [hdr] + creds2' = clientCreds "" creds2 + arts' = clientHeaderArtifacts arts + + r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired + r2 @?= Right () + + +test04 = testCase "generates a header then fails to parse it (missing server header hash)" $ do + let (creds, credsFunc, user) = makeCreds "123456" + ext = Just "some-app-data" + payload = PayloadInfo "text/plain;x=y" "some not so random text" + hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "POST" creds (Just payload) ext + let hrq = def + { hrqMethod = "POST" + , hrqUrl = "/resource/4?filter=a" -- fixme: not absolute + , hrqHost = "example.com" + , hrqPort = Just 8080 + , hrqAuthorization = Client.hdrField hdr + , hrqPayload = Nothing + } + r <- Server.authenticate def credsFunc hrq + isRight r @? "Expected auth success, got: " ++ show r + let Right s@(Server.AuthSuccess creds2 arts user) = r + user @?= "steve" + Server.shaExt arts @?= Just "some-app-data" + Server.authenticatePayload s payload @?= Right () + + let payload2 = PayloadInfo "text/plain" "some reply" + fixmeExt2 = "response-specific" + (_, hdr) = Server.header r Nothing + res = mockResponse payload2 [hdr] + creds2' = clientCreds "" creds2 + arts' = clientHeaderArtifacts arts + + r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired + r2 @?= Left "Missing response hash attribute" + +test05 = testCase "generates a header then successfully parse it then validate payload" $ do + let (creds, credsFunc, user) = makeCreds "123456" + ext = Just "some-app-data" + -- fixme: js impl seems to have a default content-type + payload = PayloadInfo "text/plain" "hola!" + payload2 = PayloadInfo "text/html" "hola!" + payload3 = PayloadInfo "text/plain" "hello!" + hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "GET" creds (Just payload) ext + let hrq = def + { hrqUrl = "/resource/4?filter=a" + , hrqHost = "example.com" + , hrqPort = Just 8080 + , hrqAuthorization = Client.hdrField hdr + } + + -- authenticate request + r <- Server.authenticate def credsFunc hrq + isRight r @?= True let Right s@(Server.AuthSuccess creds' arts user) = r user @?= "steve" Server.shaExt arts @?= Just "some-app-data" + + -- authenticate payload Server.authenticatePayload s payload @?= Right () + Server.authenticatePayload s payload2 @?= Left "Bad response payload mac" + Server.authenticatePayload s payload3 @?= Left "Bad response payload mac" + +test06 = testCase "generates a header then successfully parses and validates payload" $ do + let (creds, credsFunc, user) = makeCreds "123456" + ext = Just "some-app-data" + -- js impl has empty string as default content-type + payload = PayloadInfo "" "hola!" + payload2 = PayloadInfo "text/plain" "hola!" + payload3 = PayloadInfo "" "hello!" + hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "GET" creds (Just payload) ext + let hrq = def + { hrqUrl = "/resource/4?filter=a" + , hrqHost = "example.com" + , hrqPort = Just 8080 + , hrqAuthorization = Client.hdrField hdr + , hrqPayload = Just payload + } + hrq2 = hrq { hrqPayload = Just payload2 } + hrq3 = hrq { hrqPayload = Just payload3 } + + -- authenticate request + r <- Server.authenticate def credsFunc hrq + isRight r @?= True + let Right s@(Server.AuthSuccess creds' arts user) = r + user @?= "steve" + Server.shaExt arts @?= Just "some-app-data" + + r2 <- Server.authenticate def credsFunc hrq2 + r2 @?= Left (Server.AuthFailUnauthorized "Bad response payload mac" (Just creds') (Just arts)) + + r3 <- Server.authenticate def credsFunc hrq3 + r3 @?= Left (Server.AuthFailUnauthorized "Bad response payload mac" (Just creds') (Just arts)) + +test07 = testCase "generates a header then successfully parse it (app)" $ do + let (creds, credsFunc, user) = makeCreds "123456" + ext = Just "some-app-data" + app = "asd23ased" + hdr <- Client.headerOz "http://example.com:8080/resource/4?filter=a" "GET" + creds Nothing ext app Nothing + let hrq = def + { hrqUrl = "/resource/4?filter=a" + , hrqHost = "example.com" + , hrqPort = Just 8080 + , hrqAuthorization = Client.hdrField hdr + } + + -- authenticate request + r <- Server.authenticate def credsFunc hrq + isRight r @?= True + let Right s@(Server.AuthSuccess creds' arts user) = r + user @?= user + Server.shaExt arts @?= Just "some-app-data" + Server.shaApp arts @?= Just app + Server.shaDlg arts @?= Nothing + +test08 = testCase "generates a header then successfully parse it (app, dlg)" $ do + let (creds, credsFunc, user) = makeCreds "123456" + ext = Just "some-app-data" + app = "asd23ased" + dlg = "23434szr3q4d" + hdr <- Client.headerOz "http://example.com:8080/resource/4?filter=a" "GET" + creds Nothing ext app (Just dlg) + let hrq = def + { hrqUrl = "/resource/4?filter=a" + , hrqHost = "example.com" + , hrqPort = Just 8080 + , hrqAuthorization = Client.hdrField hdr + } + + -- authenticate request + r <- Server.authenticate def credsFunc hrq + isRight r @?= True + let Right s@(Server.AuthSuccess creds' arts user) = r + user @?= user + Server.shaExt arts @?= Just "some-app-data" + Server.shaApp arts @?= Just app + Server.shaDlg arts @?= Just "23434szr3q4d" + +test09 = testCase "generates a header for one resource then fail to authenticate another" $ do + let (creds, credsFunc, user) = makeCreds "123456" + ext = Just "some-app-data" + hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "GET" creds Nothing ext + let hrq = def + { hrqUrl = "/something/else" + , hrqHost = "example.com" + , hrqPort = Just 8080 + , hrqAuthorization = Client.hdrField hdr + } + + -- authenticate request + r <- Server.authenticate def credsFunc hrq + let Left f@(Server.AuthFailUnauthorized e creds arts) = r + e @?= "Bad mac" + isJust creds @?= True + --arts @?= Nothing + +missing, boring :: Assertion +missing = return () +boring = return () + +testHeader01 = testCase "returns a valid authorization header (sha1)" $ do + return ()