hsoz-0.0.0.4: test/Network/Hawk/Tests.hs
{-# LANGUAGE RecordWildCards, TupleSections #-}
module Network.Hawk.Tests (tests) where
import Data.Either (isLeft, isRight)
import Data.Maybe (isJust, catMaybes)
import Control.Monad (void)
import Data.Default
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
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)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import Data.Time.Clock (NominalDiffTime)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)
import Test.HUnit (Assertion, (@?=), (@?), assertFailure)
import Test.Tasty.QuickCheck (testProperty)
import Test.QuickCheck
import Test.QuickCheck.Monadic
import Network.Hawk
import Network.Hawk.Internal.Server.Types (HawkReq(..), AuthSuccess(..))
import Network.Hawk.Internal.Server.Header (timestampMessage)
import Network.Hawk.Internal (calculatePayloadHash)
import qualified Network.Hawk.Internal.Client as Client (headerBase')
import qualified Network.Hawk.Client as Client
import qualified Network.Hawk.Internal.Client.HeaderParser as Client
import qualified Network.Hawk.Server as Server
import qualified Network.Hawk.Internal.Types as Hawk
import Network.Hawk.Internal.Types (HeaderArtifacts(..))
import qualified Network.Hawk.Server.Nonce as Server
tests :: TestTree
tests = testGroup "Network.Hawk"
[ testGroup "Client+Server"
[ test01
, test02
, test03
, test04
, test05
, test06
, test07
, test08
--, testCase "generates a header then fail authentication due to bad hash" duplicate
, test09
, testWWWAuthenticate
]
, testGroup "Server"
[ testGroup "authenticate"
[ testServerAuth01
, testServerAuth02
, testServerAuth05
, testServerAuth06
, testServerAuth07
, testServerAuth08
, testServerAuth09
, testServerAuth10
, testServerAuth11
, testServerAuth12
, testServerAuth13
, testServerAuth14
, testServerAuth15
, testServerAuth16
, testServerAuth17
, testServerAuth18
, testServerAuth19
-- , testServerAuth20
-- , testServerAuth21
-- , testServerAuth22
-- , testServerAuth23
, testServerAuth26
-- , testServerAuth30
, testServerAuth32
]
, testGroup "header"
[ testServerHeader01
, testServerHeader02
, testServerHeader04
, testServerHeader08
]
, testGroup "authenticateBewit"
[ testServerBewit01
]
, testGroup "message"
[ testMessages
, testServerMessage04
, testServerMessage05
]
]
, testGroup "Client"
[ testGroup "header"
[ testClientHeader01
, testClientHeader02
, testClientHeader03
, testClientHeader05
, testClientHeader06
--, testClientHeader07
--, testClientHeader09
]
, testGroup "authenticate"
[ testClientAuth01
, testClientAuth03
, testClientAuth04
, testClientAuth05
, testClientAuth07
, testClientAuth08
, testClientAuth09
, testClientAuth10
]
, testGroup "message"
[ testClientMessage01
]
]
]
makeCreds :: Client.ClientId -> (Client.Credentials, Server.CredentialsFunc IO String, String)
makeCreds i = (cc, \i -> return sc, user)
where
sc@(Right (Server.Credentials key algo, user)) = testCreds i
cc = Client.Credentials i key algo
testCredsFunc = return . testCreds
testCreds "456" = credsBob
testCreds "doesnotexist" = Left "Unknown user"
testCreds "999" = credsFred
testCreds "1" = credsSteve' (HawkAlgo SHA1)
testCreds _ = credsSteve' (HawkAlgo SHA256)
credsSteve = credsSteve' (HawkAlgo SHA256)
credsSteve' algo = Right (Server.Credentials key algo, "steve")
where key = "werxhqb98rpaxn39848xrunpaw3489ruxnpa98w4rxn"
credsBob = Right (Server.Credentials altKey (HawkAlgo SHA256), "bob")
where altKey = "xrunpaw3489ruxnpa98w4rxnwerxhqb98rpaxn39848"
credsFred = Right (Server.Credentials "hi" (HawkAlgo SHA256), "fred")
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 0 ext
let hrq = def
{ hrqUrl = "/resource/4?filter=a"
, hrqHost = "example.com"
, hrqPort = Just 8080
, hrqAuthorization = Client.hdrField hdr
}
r <- Server.authenticate def credsFunc hrq
assertSuccess r
let Right (Server.AuthSuccess creds' arts user) = r
user @?= "steve"
Hawk.haExt arts @?= Just "some-app-data"
test02 = testCase "generates a header then successfully parses it (WAI request)" $ do
-- Generate client header
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) 0 ext
-- Server verifies client request
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))
isRight r @? "Expected auth success, got: " ++ show r
let Right s@(Server.AuthSuccess creds2 arts user) = r
user @?= "steve"
Hawk.haExt arts @?= Just "some-app-data"
Server.authenticatePayload s payload @?= Right ()
-- Client verifies server response
let payload2 = PayloadInfo "text/plain" "Some reply"
(_, hdr2) = Server.header r (Just payload2)
res = mockResponse payload2 [hdr2]
creds2' = clientCreds "" creds2
arts' = arts { haHash = Just $ calculatePayloadHash (Client.ccAlgorithm creds) payload2 }
r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired
isRight r2 @?= True
clientCreds :: ClientId -> Server.Credentials -> Client.Credentials
clientCreds i (Server.Credentials k a) = Client.Credentials i k a
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) 0 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"
Hawk.haExt 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' = arts { haHash = Just $ calculatePayloadHash (Client.ccAlgorithm creds) payload2 }
r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired
isRight r2 @?= True
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) 0 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"
Hawk.haExt 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
arts2 = arts { haHash = Nothing }
r2 <- Client.authenticate res creds2' arts2 (Just (payloadData payload2)) Client.ServerAuthorizationRequired
r2 @?= Left "Missing response hash attribute"
-- boring test case
-- test00 = testCase "generates a header then successfully parse it (no server header options)"
-- duplicate test case
-- test00 = testCase "generates a header then successfully parse it (with hash)"
test05 = testCase "generates a header then successfully parse it then validate payload" $ do
let (creds, credsFunc, user) = makeCreds "123456"
ext = Just "some-app-data"
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) 0 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
assertSuccess r
let Right s@(Server.AuthSuccess creds' arts user) = r
user @?= "steve"
Hawk.haExt 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) 0 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
assertSuccess r
let Right s@(Server.AuthSuccess creds' arts user) = r
user @?= "steve"
Hawk.haExt 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 0 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
assertSuccess r
let Right s@(Server.AuthSuccess creds' arts user) = r
user @?= user
Hawk.haExt arts @?= Just "some-app-data"
Hawk.haApp arts @?= Just app
Hawk.haDlg 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 0 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
s@(Server.AuthSuccess creds' arts user) <- assertSuccess r
user @?= user
Hawk.haExt arts @?= Just "some-app-data"
Hawk.haApp arts @?= Just app
Hawk.haDlg 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 0 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 ()
testReq1 = def { hrqUrl = "/resource/1?b=1&a=2"
, hrqHost = "example.com"
, hrqPort = Just 8000
, hrqAuthorization = ""
}
testReq4 = def { hrqUrl = "/resource/4?filter=a"
, hrqHost = "example.com"
, hrqPort = Just 8080
, hrqAuthorization = ""
}
testAuth auth ts hrq = do
now <- getPOSIXTime
opts <- testNonceOpts ts now
testAuth' auth ts hrq now opts
testNonceOpts ts now = Server.nonceOpts (now - ts + 60)
testAuth' auth ts hrq now opts = do
let opts' = opts { Server.saLocaltimeOffset = ts - now }
hrq' = hrq { hrqAuthorization = auth }
Server.authenticate opts' testCredsFunc hrq'
checkAuthSuccess = checkAuthSuccessUser "steve"
checkAuthSuccessUser _ (Left f) = show f @?= "some success"
checkAuthSuccessUser user (Right (AuthSuccess c a t)) = t @?= user
checkAuthFail msg (Left f) = Server.authFailMessage f @?= msg
checkAuthFail _ (Right _) = "success" @?= "failure"
-- authenticate
testServerAuth01 = testCase "parses a valid authentication header (sha1)" $ do
res <- testAuth "Hawk id=\"1\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"zy79QQ5/EYFmQqutVnYb73gAc/U=\", ext=\"hello\"" 1353788437 testReq4
checkAuthSuccess res
testServerAuth02 = testCase "parses a valid authentication header (sha256)" $ do
res <- testAuth "Hawk id=\"dh37fgj492je\", ts=\"1353832234\", nonce=\"j4h3g2\", mac=\"m8r1rHbXN6NgO+KIIhjO7sFRyd78RNGVUwehe8Cp2dU=\", ext=\"some-app-data\"" 1353832234 testReq1
checkAuthSuccess res
-- These two are really just testing the hawkReq function.
-- testServerAuth03 = testCase "parses a valid authentication header (host override)"
-- testServerAuth04 = testCase "parses a valid authentication header (host port override)"
testServerAuth05 = testCase "parses a valid authentication header (POST with payload)" $ do
let hrq = testReq4 { hrqMethod = "POST" }
res <- testAuth "Hawk id=\"123456\", ts=\"1357926341\", nonce=\"1AwuJD\", hash=\"qAiXIVv+yjDATneWxZP2YCTa9aHRgQdnH9b3Wc+o3dg=\", ext=\"some-app-data\", mac=\"UeYcj5UoTVaAWXNvJfLVia7kU3VabxCqrccXP8sUGC4=\"" 1357926341 hrq
checkAuthSuccess res
testServerAuth06 = testCase "errors on missing hash" $ do
let hrq = testReq1 { hrqPayload = Just (PayloadInfo "" "body") }
res <- testAuth "Hawk id=\"dh37fgj492je\", ts=\"1353832234\", nonce=\"j4h3g2\", mac=\"m8r1rHbXN6NgO+KIIhjO7sFRyd78RNGVUwehe8Cp2dU=\", ext=\"some-app-data\"" 1353832234 hrq
-- js impl says "Missing required payload hash"
checkAuthFail "Missing response hash attribute" res
testServerAuth07 = testCase "errors on a stale timestamp" $ do
now <- getPOSIXTime
res <- testAuth' "Hawk id=\"123456\", ts=\"1362337299\", nonce=\"UzmxSs\", ext=\"some-app-data\", mac=\"wnNUxchvvryMH2RxckTdZ/gY3ijzvccx4keVvELC61w=\"" now testReq4 now def
checkAuthFail "Expired seal" res -- js impl says "Stale timestamp"
testWWWAuthenticate = testProperty "timeStampMessage . parseWwwAuthenticateHeader == id"
prop_parseWWWAuthenticate
instance Arbitrary NominalDiffTime where
arbitrary = do
n <- choose (-3600 * 24, 3600 * 24) :: Gen Double
return $ 1481062437 + realToFrac n
prop_parseWWWAuthenticate :: (POSIXTime, String) -> Property
prop_parseWWWAuthenticate (ts, error) = isNice error ==>
either (const $ property False) check wh
where
check Client.WwwAuthenticateHeader{..} = fmap floor wahTs == Just (floor ts) .&&.
wahError == (S8.pack error) .&&.
wahTsm /= Just ""
algo = HawkAlgo SHA256
key = "key"
cc = Client.Credentials "1" key algo
sc = Server.Credentials key algo
h = timestampMessage error ts sc
wh = Client.parseWwwAuthenticateHeader h
--ck = Client.checkWwwAuthenticateHeader cc h
-- fixme: need to handle quote characters?
isNice s = notElem '"' s && notElem '\\' s
testServerAuth08 = testCase "errors on a replay" $ do
let auth = "Hawk id=\"123\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"bXx7a7p1h9QYQNZ8x7QhvDQym8ACgab4m3lVSFn4DBw=\", ext=\"hello\""
ts = 1353788437
now <- getPOSIXTime
opts <- testNonceOpts ts now
res1 <- testAuth' auth ts testReq4 now opts
checkAuthSuccess res1
res2 <- testAuth' auth ts testReq4 now opts
checkAuthFail "Invalid nonce" res2
testServerAuth09 = testCase "does not error on nonce collision if keys differ" $ do
let auth1 = "Hawk id=\"123\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"bXx7a7p1h9QYQNZ8x7QhvDQym8ACgab4m3lVSFn4DBw=\", ext=\"hello\""
auth2 = "Hawk id=\"456\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"LXfmTnRzrLd9TD7yfH+4se46Bx6AHyhpM94hLCiNia4=\", ext=\"hello\""
ts = 1353788437
now <- getPOSIXTime
opts <- testNonceOpts ts now
res1 <- testAuth' auth1 ts testReq4 now opts
checkAuthSuccess res1
res2 <- testAuth' auth2 ts testReq4 now opts
checkAuthSuccessUser "bob" res2
testServerAuth10 = testCase "errors on an invalid authentication header: wrong scheme" $ do
res <- testAuth "Basic asdasdasdasd" 1353788437 testReq4
checkAuthFail "string" res -- fixme: not a good error message
testServerAuth11 = testCase "errors on an invalid authentication header: no scheme" $ do
res <- testAuth "!@#" 1353788437 testReq4
checkAuthFail "string" res -- fixme: "Invalid header syntax"
testServerAuth12 = testCase "errors on an missing authorization header" $ do
res <- testAuth "" 1353788437 testReq4
checkAuthFail "not enough input" res -- fixme: need better error message
-- fixme
testServerAuth13 = testCase "errors on an missing host header" (return ())
missingAttrTest attr auth = testAuth auth 1353788437 testReq4 >>= checkAuthFail msg
-- js impl is just "Missing attributes"
where msg = "Failed reading: Missing \"" ++ attr ++ "\" attribute"
testServerAuth14 = testCase "errors on an missing authorization attribute (id)" $
missingAttrTest "id" "Hawk ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"/qwS4UjfVWMcUyW6EEgUH4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\""
testServerAuth15 = testCase "errors on an missing authorization attribute (ts)" $
missingAttrTest "ts" "Hawk id=\"123\", nonce=\"k3j4h2\", mac=\"/qwS4UjfVWMcUyW6EEgUH4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\""
testServerAuth16 = testCase "errors on an missing authorization attribute (nonce)" $
missingAttrTest "nonce" "Hawk id=\"123\", ts=\"1353788437\", mac=\"/qwS4UjfVWMcUyW6EEgUH4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\""
testServerAuth17 = testCase "errors on an missing authorization attribute (mac)" $
missingAttrTest "mac" "Hawk id=\"123\", ts=\"1353788437\", nonce=\"k3j4h2\", ext=\"hello\""
testServerAuth18 = testCase "errors on an unknown authorization attribute" $ do
let msg = "endOfInput" -- fixme: "Unknown attribute: x"
auth = "Hawk id=\"123\", ts=\"1353788437\", nonce=\"k3j4h2\", x=\"3\", mac=\"/qwS4UjfVWMcUyW6EEgUH4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\""
testAuth auth 1353788437 testReq4 >>= checkAuthFail msg
testServerAuth19 = testCase "errors on an bad authorization header format" $ do
let msg = "endOfInput" -- fixme: "Bad header format"
auth = "Hawk id=\"123\\\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"/qwS4UjfVWMcUyW6EEgUH4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\""
res <- testAuth auth 1353788437 testReq4
checkAuthFail msg res
testServerAuth20 = testCase "errors on an bad authorization attribute value" $ do
res <- testAuth "Hawk id=\"\t\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"/qwS4UjfVWMcUyW6EEgUH4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\"" 1353788437 testReq4
checkAuthFail "Bad attribute value: id" res
testServerAuth21 = testCase "errors on an empty authorization attribute value" $ do
res <- testAuth "Hawk id=\"\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"/qwS4UjfVWMcUyW6EEgUH4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\"" 1353788437 testReq4
checkAuthFail "Bad attribute value: id" res
testServerAuth22 = testCase "errors on duplicated authorization attribute key" $ do
res <- testAuth "Hawk id=\"123\", id=\"456\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"/qwS4UjfVWMcUyW6EEgUH4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\"" 1353788437 testReq4
checkAuthFail "Duplicate attribute: id" res
testServerAuth23 = testCase "errors on an invalid authorization header format" $ do
res <- testAuth "Hawk" 1353788437 testReq4
checkAuthFail "Invalid header syntax" res
-- fixme: i don't think these are needed because HawkReq has types
-- testServerAuth24 = testCase "errors on an bad host header (missing host)" (fail "n/a for wai?")
-- testServerAuth25 = testCase "errors on an bad host header (bad port)" (fail "n/a for wai?")
testServerAuth26 = testCase "errors on credentialsFunc error" $ do
res <- testAuth "Hawk id=\"doesnotexist\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"doesn't matter\", ext=\"hello\"" 1353788437 testReq4
checkAuthFail "Unknown user" res
-- not sure why this use case is needed
-- testServerAuth27 = testCase "errors on credentialsFunc error (with credentials)" (fail "n/a")
-- following errors can't happen in this implementation
-- testServerAuth28 = testCase "errors on missing credentials"
-- testServerAuth29 = testCase "errors on invalid credentials (id)"
-- testServerAuth30 = testCase "errors on invalid credentials (key)"
-- testServerAuth31 = testCase "errors on unknown credentials algorithm"
testServerAuth30 = testCase "errors on invalid credentials (key too short)" $ do
res <- testAuth "Hawk id=\"999\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"doesn't matter\", ext=\"hello\"" 1353788437 testReq4
checkAuthFail "Invalid credentials" res
testServerAuth32 = testCase "errors on unknown bad mac" $ do
res <- testAuth "Hawk id=\"123\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"/qwS4UjfVWMcU4jlr7T/wuKe3dKijvTvSos=\", ext=\"hello\"" 1353788437 testReq4
checkAuthFail "Bad mac" res
-- header()
testServerHeader01 = testCase "generates header" $ do
let Right (creds, user) = credsSteve
let arts = HeaderArtifacts
{ haMethod = "POST"
, haHost = "example.com"
, haPort = Just 8080
, haResource = hrqUrl testReq4
, haTimestamp = 1398546787
, haNonce = "xUwusx"
, haHash = Just "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
-- note js tests override artifacts ext with a param to header()
, haExt = Just "response-specific"
, haMac = "dvIvMThwi28J61Jc3P0ryAhuKpanU63GXdx6hkmQkJA="
, haId = "123456"
, haApp = Nothing
, haDlg = Nothing
}
res = Right (AuthSuccess creds arts ())
(_, (_, hdr)) = Server.header res (Just $ PayloadInfo "text/plain" "some reply")
hdr @?= "Hawk mac=\"n14wVJK4cOxAytPUMc5bPezQzuJGl5n7MYXhFQgEKsE=\", hash=\"f9cDF/TDm7TkYRLnGwRMfeDzT6LixQVLvrIKhh0vgmM=\", ext=\"response-specific\""
testServerHeader02 = testCase "generates header (empty payload)" $ do
let Right (creds, user) = credsSteve
let arts = HeaderArtifacts
{ haMethod = "POST"
, haHost = "example.com"
, haPort = Just 8080
, haResource = hrqUrl testReq4
, haTimestamp = 1398546787
, haNonce = "xUwusx"
, haHash = Just "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
-- note js tests override artifacts ext with a param to header()
, haExt = Just "response-specific"
, haMac = "dvIvMThwi28J61Jc3P0ryAhuKpanU63GXdx6hkmQkJA="
, haId = "123456"
, haApp = Nothing
, haDlg = Nothing
}
res = Right (AuthSuccess creds arts ())
(_, (_, hdr)) = Server.header res (Just $ PayloadInfo "text/plain" "")
hdr @?= "Hawk mac=\"i8/kUBDx0QF+PpCtW860kkV/fa9dbwEoe/FpGUXowf0=\", hash=\"q/t+NNAkQZNlq/aAD6PlexImwQTxwgT2MahfTa9XRLA=\", ext=\"response-specific\""
{-
-- fixme: need to change PayloadInfo to support this use case
testServerHeader03 = testCase "generates header (pre calculated hash)" $ do
let hash = calculatePayloadHash creds (PayloadInfo "text/plain" "some reply")
-- hash becomes PayloadHash "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
return ()
-}
testServerHeader04 = testCase "generates header (null ext)" $ do
let Right (creds, user) = credsSteve
let arts = HeaderArtifacts
{ haMethod = "POST"
, haHost = "example.com"
, haPort = Just 8080
, haResource = hrqUrl testReq4
, haTimestamp = 1398546787
, haNonce = "xUwusx"
, haHash = Just "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
, haExt = Nothing
, haMac = "dvIvMThwi28J61Jc3P0ryAhuKpanU63GXdx6hkmQkJA="
, haId = "123456"
, haApp = Nothing
, haDlg = Nothing
}
res = Right (AuthSuccess creds arts ())
(_, (_, hdr)) = Server.header res (Just $ PayloadInfo "text/plain" "some reply")
hdr @?= "Hawk mac=\"6PrybJTJs20jsgBw5eilXpcytD8kUbaIKNYXL+6g0ns=\", hash=\"f9cDF/TDm7TkYRLnGwRMfeDzT6LixQVLvrIKhh0vgmM=\""
-- not relevant due to types
--testServerHeader05 = testCase "errors on missing artifacts"
--testServerHeader06 = testCase "errors on invalid artifacts"
--testServerHeader07 = testCase "errors on missing credentials"
--testServerHeader09 = testCase "errors on invalid algorithm"
testServerHeader08 = testCase "errors on invalid credentials (key)" $ do
let Right (creds, user) = credsFred
let arts = HeaderArtifacts
{ haMethod = "POST"
, haHost = "example.com"
, haPort = Just 8080
, haResource = hrqUrl testReq4
, haTimestamp = 1398546787
, haNonce = "xUwusx"
, haHash = Just "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
, haExt = Just "response-specific"
, haMac = "dvIvMThwi28J61Jc3P0ryAhuKpanU63GXdx6hkmQkJA="
, haId = "123456"
, haApp = Nothing
, haDlg = Nothing
}
res = Right (AuthSuccess creds arts ())
(_, (_, hdr)) = Server.header res (Just $ PayloadInfo "text/plain" "some reply")
-- fixme: header should return empty string or something because key
-- is too short
hdr @?= "Hawk mac=\"f877uh9HCdCTF/Y3hIxG0XdUAsWQDqfkPekzLasFlNY=\", hash=\"f9cDF/TDm7TkYRLnGwRMfeDzT6LixQVLvrIKhh0vgmM=\", ext=\"response-specific\""
-- authenticateBewit()
testServerBewit01 = testCase "errors on uri too long" $ do
let req = testReq4
{ hrqUrl = S8.pack ('/':take 5000 (repeat 'x'))
, hrqAuthorization = "Hawk id=\"1\", ts=\"1353788437\", nonce=\"k3j4h2\", mac=\"zy79QQ5/EYFmQqutVnYb73gAc/U=\", ext=\"hello\""
}
res <- Server.authenticateBewit def testCredsFunc req
case res of
Right _ -> "success" @?= "failure"
Left (Server.AuthFailBadRequest e _) -> e @?= "Resource path exceeds max length"
Left e -> show e @?= "AuthFailBadRequest _ _"
-- message
testMessages = testProperty "Client.message . Server.authenticateMessage == Right"
prop_messageSame
prop_messageSame :: String -> Property
prop_messageSame msg = monadicIO $ do
res <- run $ do
tm <- setupTestMessage
testMessage (tm { tmMsg = BL.fromStrict (S8.pack msg) })
assert (isRight res)
data TestMessage = TestMessage
{ tmServerCreds :: Server.Credentials
, tmClientCreds :: Client.Credentials
, tmCredsFunc :: Server.CredentialsFunc IO String
, tmHost :: ByteString
, tmPort :: Maybe Int
, tmSkew :: NominalDiffTime
, tmOpts :: Server.AuthOpts
, tmMsg :: BL.ByteString
}
setupTestMessage :: IO TestMessage
setupTestMessage = do
let cf = testCredsFunc
Right (sc, user) <- cf "123456"
let cc = clientCreds "" sc
opts <- Server.nonceOpts 60
return $ TestMessage sc cc testCredsFunc "example.com" (Just 8080) 0 opts ""
testMessage TestMessage{..} = do
auth <- Client.message tmClientCreds tmHost tmPort tmMsg tmSkew
Server.authenticateMessage tmOpts tmCredsFunc tmHost tmPort tmMsg auth
-- because of types, these test cases are impossible
--testServerMessage01 = testCase "errors on invalid authorization (ts)"
--testServerMessage02 = testCase "errors on invalid authorization (nonce)"
--testServerMessage03 = testCase "errors on invalid authorization (hash)"
testServerMessage04 = testCase "errors with credentials" $ do
tm <- setupTestMessage
res <- testMessage (tm { tmCredsFunc = \i -> return (Left "something") })
case res of
Right _ -> "success" @?= "failure"
Left (Server.AuthFailUnauthorized e _ _) -> e @?= "something"
Left e -> show e @?= "AuthFailUnauthorized _ _ _"
testServerMessage05 = testCase "errors on nonce collision" $ do
tm@TestMessage{..} <- setupTestMessage
auth <- Client.message tmClientCreds tmHost tmPort tmMsg tmSkew
res <- Server.authenticateMessage tmOpts tmCredsFunc tmHost tmPort tmMsg auth
Server.authValue <$> res @?= Right "steve"
res2 <- Server.authenticateMessage tmOpts tmCredsFunc tmHost tmPort tmMsg auth
isRight res2 @?= False
let Left e = res2
Server.authFailMessage e @?= "Invalid nonce"
testServerMessage06 = testCase "should generate an authorization then successfully parse it"
testServerMessage07 = testCase "should fail authorization on mismatching host"
testServerMessage08 = testCase "should fail authorization on stale timestamp"
testServerMessage09 = testCase "overrides timestampSkewSec"
testServerMessage10 = testCase "should fail authorization on invalid authorization"
testServerMessage11 = testCase "should fail authorization on bad hash"
testServerMessage12 = testCase "should fail authorization on nonce error"
testServerMessage13 = testCase "should fail authorization on credentials error"
testServerMessage14 = testCase "should fail authorization on missing credentials"
testServerMessage15 = testCase "should fail authorization on invalid credentials"
testServerMessage16 = testCase "should fail authorization on invalid credentials algorithm"
testServerMessage17 = testCase "should fail on missing host"
testServerMessage18 = testCase "should fail on missing credentials"
testServerMessage19 = testCase "should fail on invalid algorithm"
testClientUrl1 = "http://example.net/somewhere/over/the/rainbow"
testClientUrl2 = "https://example.net/somewhere/over/the/rainbow"
testClientCreds1 = Client.Credentials "123456" "2983d45yun89q" (HawkAlgo SHA1)
testClientCreds2 = Client.Credentials "123456" "2983d45yun89q" (HawkAlgo SHA256)
testPayload1 = PayloadInfo "" "something to write about"
testPayload2 = PayloadInfo "text/plain" "something to write about"
testPayload3 = PayloadInfo "text/plain" ""
testClientExt = "Bazinga!"
data TestClient = TestClient
{ tcUrl :: Text
, tcMethod :: ByteString
, tcCreds :: Client.Credentials
, tcPayload :: Maybe PayloadInfo
, tcSkew :: NominalDiffTime
, tcExt :: Maybe ExtData
, tcTimestamp :: POSIXTime
, tcNonce :: ByteString
}
instance Default TestClient where
def = TestClient testClientUrl2 "POST" testClientCreds2 (Just testPayload2) 0 (Just testClientExt) 1353809207 "Ygvqdz"
testClientHeader TestClient{..} hdr = Client.hdrField h @?= hdr
where h = Client.headerBase' tcUrl tcMethod tcCreds tcPayload
tcSkew tcExt Nothing Nothing tcTimestamp tcNonce
testClientHeader01 = testCase "returns a valid authorization header (sha1)" $
testClientHeader (def { tcUrl = testClientUrl1, tcCreds = testClientCreds1, tcPayload = Just testPayload1 })
"Hawk id=\"123456\", ts=\"1353809207\", nonce=\"Ygvqdz\", hash=\"bsvY3IfUllw6V5rvk4tStEvpBhE=\", ext=\"Bazinga!\", mac=\"qbf1ZPG/r/e06F4ht+T77LXi5vw=\""
testClientHeader02 = testCase "returns a valid authorization header (sha256)" $
testClientHeader def
"Hawk id=\"123456\", ts=\"1353809207\", nonce=\"Ygvqdz\", hash=\"2QfCt3GuY9HQnHWyWD3wX68ZOKbynqlfYmuO2ZBRqtY=\", ext=\"Bazinga!\", mac=\"q1CwFoSHzPZSkbIvl0oYlD+91rBUEvFk763nMjMndj8=\""
testClientHeader03 = testCase "returns a valid authorization header (no ext)" $
testClientHeader (def { tcExt = Nothing })
"Hawk id=\"123456\", ts=\"1353809207\", nonce=\"Ygvqdz\", hash=\"2QfCt3GuY9HQnHWyWD3wX68ZOKbynqlfYmuO2ZBRqtY=\", mac=\"HTgtd0jPI6E4izx8e4OHdO36q00xFCU0FolNq3RiCYs=\""
-- don't need this test because of types
-- testClientHeader04 = testCase "returns a valid authorization header (null ext)"
testClientHeader05 = testCase "returns a valid authorization header (empty payload)" $
testClientHeader (def { tcPayload = Just testPayload3, tcExt = Nothing })
"Hawk id=\"123456\", ts=\"1353809207\", nonce=\"Ygvqdz\", hash=\"q/t+NNAkQZNlq/aAD6PlexImwQTxwgT2MahfTa9XRLA=\", mac=\"U5k16YEzn3UnBHKeBzsDXn067Gu3R4YaY6xOt9PYRZM=\""
testClientHeader06 = testCase "returns a valid authorization header (pre hashed payload)" $
-- fixme: use precalculated hash
let hash = calculatePayloadHash (HawkAlgo SHA256) testPayload2
in testClientHeader (def { tcPayload = Just testPayload2, tcExt = Nothing })
"Hawk id=\"123456\", ts=\"1353809207\", nonce=\"Ygvqdz\", hash=\"2QfCt3GuY9HQnHWyWD3wX68ZOKbynqlfYmuO2ZBRqtY=\", mac=\"HTgtd0jPI6E4izx8e4OHdO36q00xFCU0FolNq3RiCYs=\""
testClientHeader07 = testCase "errors on missing uri" $
testClientHeader (def { tcUrl = "" }) ""
-- js impl tests supply a number instead of string url
-- testClientHeader08 = testCase "errors on invalid uri"
testClientHeader09 = testCase "errors on missing method" $
testClientHeader (def { tcMethod = "" }) ""
-- js impl tests supply a number instead of string
--testClientHeader10 = testCase "errors on invalid method"
-- not needed because of types
-- testClientHeader11 = testCase "errors on missing options"
-- testClientHeader12 = testCase "errors on invalid credentials (id)"
-- testClientHeader13 = testCase "errors on missing credentials"
-- testClientHeader14 = testCase "errors on invalid credentials"
-- testClientHeader15 = testCase "errors on invalid algorithm"
mockResponse2 :: Maybe ByteString -> BL.ByteString -> Response BL.ByteString
mockResponse2 auth b = mockResponse (PayloadInfo "text/plain" b) (catMaybes [hdr])
where hdr = fmap ("server-authorization",) auth
testClientAuth01 = testCase "returns false on invalid header" $ do
let r = mockResponse2 (Just "Hawk mac=\"abc\", bad=\"xyz\"") ""
ok <- Client.authenticate r undefined undefined Nothing Client.ServerAuthorizationRequired
isLeft ok @?= True
-- fixme: better message for parse error
-- ok @?= Left "Invalid Server-Authorization header"
ok @?= Left "endOfInput"
-- same as previous test
--testClientAuth02 = testCase "returns false on invalid header (callback)"
testClientAuth03 = testCase "returns false on invalid mac" $ do
let r = mockResponse2 (Just "Hawk mac=\"_IJRsMl/4oL+nn+vKoeVZPdCHXB4yJkNnBbTbHFZUYE=\", hash=\"f9cDF/TDm7TkYRLnGwRMfeDzT6LixQVLvrIKhh0vgmM=\", ext=\"response-specific\"") ""
cid = "123456"
(creds, _, _) = makeCreds cid
arts = HeaderArtifacts
{ haMethod = "POST"
, haHost = "example.com"
, haPort = Just 8080
, haResource = hrqUrl testReq4
, haTimestamp = 1362336900
, haNonce = "eb5S_L"
, haHash = Just "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
, haExt = Just "some-app-data"
, haMac = "BlmSe8K+pbKIb6YsZCnt4E1GrYvY1AaYayNR82dGpIk="
, haId = cid
, haApp = Nothing
, haDlg = Nothing
}
ok <- Client.authenticate r creds arts Nothing Client.ServerAuthorizationRequired
ok @?= Left "Bad response mac"
testClientAuth04 = testCase "returns true on ignoring hash" $ do
let r = mockResponse2 (Just "Hawk mac=\"XIJRsMl/4oL+nn+vKoeVZPdCHXB4yJkNnBbTbHFZUYE=\", hash=\"f9cDF/TDm7TkYRLnGwRMfeDzT6LixQVLvrIKhh0vgmM=\", ext=\"response-specific\"") ""
cid = "123456"
(creds, _, _) = makeCreds cid
arts = HeaderArtifacts
{ haMethod = "POST"
, haHost = "example.com"
, haPort = Just 8080
, haResource = hrqUrl testReq4
, haTimestamp = 1362336900
, haNonce = "eb5S_L"
, haHash = Just "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
, haExt = Just "some-app-data"
, haMac = "BlmSe8K+pbKIb6YsZCnt4E1GrYvY1AaYayNR82dGpIk="
, haId = cid
, haApp = Nothing
, haDlg = Nothing
}
r <- Client.authenticate r creds arts Nothing Client.ServerAuthorizationRequired
void $ assertSuccess r
testClientAuth05 = testCase "validates response payload" $ do
let r = mockResponse2 (Just "Hawk mac=\"odsVGUq0rCoITaiNagW22REIpqkwP9zt5FyqqOW9Zj8=\", hash=\"f9cDF/TDm7TkYRLnGwRMfeDzT6LixQVLvrIKhh0vgmM=\", ext=\"response-specific\"") p
p = "some reply"
cid = "123456"
(creds, _, _) = makeCreds cid
arts = HeaderArtifacts
{ haMethod = "POST"
, haHost = "example.com"
, haPort = Just 8080
, haResource = hrqUrl testReq4
, haTimestamp = 1453070933
, haNonce = "3hOHpR"
, haHash = Just "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
, haExt = Just "some-app-data"
, haMac = "/DitzeD66F2f7O535SERbX9p+oh9ZnNLqSNHG+c7/vs="
, haId = cid
, haApp = Nothing
, haDlg = Nothing
}
ok <- Client.authenticate r creds arts (Just p) Client.ServerAuthorizationRequired
ok @?= Right (Just (Client.ServerAuthorizationHeader
"odsVGUq0rCoITaiNagW22REIpqkwP9zt5FyqqOW9Zj8="
(Just "f9cDF/TDm7TkYRLnGwRMfeDzT6LixQVLvrIKhh0vgmM=")
(Just "response-specific")))
-- same as previous test
--testClientAuth06 = testCase "validates response payload (callback)"
testClientAuth07 = testCase "errors on invalid response payload" $ do
let r = mockResponse2 (Just "Hawk mac=\"odsVGUq0rCoITaiNagW22REIpqkwP9zt5FyqqOW9Zj8=\", hash=\"f9cDF/TDm7TkYRLnGwRMfeDzT6LixQVLvrIKhh0vgmM=\", ext=\"response-specific\"") p
p = "wrong reply"
cid = "123456"
(creds, _, _) = makeCreds cid
arts = HeaderArtifacts
{ haMethod = "POST"
, haHost = "example.com"
, haPort = Just 8080
, haResource = hrqUrl testReq4
, haTimestamp = 1453070933
, haNonce = "3hOHpR"
, haHash = Just "nJjkVtBE5Y/Bk38Aiokwn0jiJxt/0S2WRSUwWLCf5xk="
, haExt = Just "some-app-data"
, haMac = "/DitzeD66F2f7O535SERbX9p+oh9ZnNLqSNHG+c7/vs="
, haId = cid
, haApp = Nothing
, haDlg = Nothing
}
ok <- Client.authenticate r creds arts (Just p) Client.ServerAuthorizationRequired
ok @?= Left "Bad response payload mac"
mockResponse3 :: ByteString -> Response BL.ByteString
mockResponse3 auth = mockResponse (PayloadInfo "text/plain" "") [("www-authenticate", auth)]
testClientAuth08 = testCase "fails on invalid WWW-Authenticate header format 1" $ do
let r = mockResponse3 "Hawk ts=\"1362346425875\", tsm=\"PhwayS28vtnn3qbv0mqRBYSXebN/zggEtucfeZ620Zo=\", x=\"Stale timestamp\""
ok <- Client.authenticate r undefined undefined Nothing Client.ServerAuthorizationRequired
-- fixme: better message for parse error
ok @?= Left "endOfInput"
testClientAuth09 = testCase "fails on invalid WWW-Authenticate header format 2" $ do
let r = mockResponse3 "Hawk ts=\"1362346425875\", tsm=\"hwayS28vtnn3qbv0mqRBYSXebN/zggEtucfeZ620Zo=\", error=\"Stale timestamp\""
(creds, _, _) = makeCreds "123456"
ok <- Client.authenticate r creds undefined Nothing Client.ServerAuthorizationRequired
ok @?= Left "Invalid server timestamp hash"
testClientAuth10 = testCase "skips tsm validation when missing ts" $ do
let r = mockResponse3 "Hawk error=\"Stale timestamp\""
ok <- Client.authenticate r undefined undefined Nothing Client.ServerAuthorizationNotRequired
ok @?= Right Nothing
testClientMessage01 = testCase "generates authorization" $ do
now <- getPOSIXTime
let ts = 1353809207
skew = ts - now
nonce = "abc123"
-- fixme: add messageWith function with option to provide timestamp and nonce
MessageAuth{..} <- Client.message testClientCreds1 "example.com" (Just 80) "I am the boodyman" skew
msgId @?= Client.ccId testClientCreds1
msgTimestamp - ts < 0.1 @? "Timestamp mismatch"
-- msgNonce @?= nonce
-- tests not needed because of types
-- testClientMessage02 = testCase "errors on invalid host"
-- testClientMessage03 = testCase "errors on invalid port"
-- testClientMessage04 = testCase "errors on missing host"
-- testClientMessage05 = testCase "errors on null message"
-- testClientMessage06 = testCase "errors on missing message"
-- testClientMessage07 = testCase "errors on invalid message"
-- testClientMessage08 = testCase "errors on missing options"
-- testClientMessage09 = testCase "errors on invalid credentials (id)"
-- testClientMessage10 = testCase "errors on invalid credentials (key)"
assertSuccess :: Show e => Either e a -> IO a
assertSuccess (Left msg) = do
assertFailure $ "Expected auth success, got: " ++ show msg
return undefined
assertSuccess (Right a) = return a