diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -48,8 +48,8 @@ This is an in-progress experiment in implementing the protocol in Haskell. - * **Iron**: complete and tested. - * **Hawk**: complete, test suite under development. + * **Iron**: complete + * **Hawk**: complete * **Oz**: under construction. * **Example web application**: under construction. @@ -63,7 +63,8 @@ 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/). +[Servant](https://haskell-servant.github.io/), or a manager for +[Wreq](http://www.serpentine.com/wreq/). ### Building with Stack diff --git a/example/BewitClient.hs b/example/BewitClient.hs --- a/example/BewitClient.hs +++ b/example/BewitClient.hs @@ -7,7 +7,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 import Network.HTTP.Client (HttpException (..)) -import Network.Wreq +import Network.HTTP.Simple import Data.Monoid import Common @@ -15,15 +15,15 @@ import qualified Network.Hawk.Client as Hawk clientMain :: IO () -clientMain = +clientMain = do let uri = "http://localhost:8000/resource/1?b=1&a=2" creds = Hawk.Credentials "dh37fgj492je" sharedKey (HawkAlgo SHA256) - in do - res <- Hawk.getBewit creds 60 Nothing 0 uri - case res of - Just bewit -> do - let uri' = uri <> "&bewit=" <> bewit - r <- get (S8.unpack uri') - putStrLn $ (show $ r ^. responseStatus . statusCode) ++ ": " - ++ (L8.unpack $ r ^. responseBody) - Nothing -> putStrLn "Couldn't generate bewit" + + res <- Hawk.getBewit creds 60 Nothing 0 uri + case res of + Just bewit -> do + let uri' = S8.unpack $ uri <> "&bewit=" <> bewit + r <- httpLBS (parseRequest_ uri') + print $ getResponseStatusCode r + L8.putStrLn $ ": " <> getResponseBody r + Nothing -> putStrLn "Couldn't generate bewit" diff --git a/example/BewitServer.hs b/example/BewitServer.hs --- a/example/BewitServer.hs +++ b/example/BewitServer.hs @@ -7,15 +7,15 @@ import Network.Wai.Handler.Warp import Common -import Network.Hawk.Server.Types import qualified Network.Hawk.Server as Hawk +import Network.Hawk.Types import Network.Hawk.Middleware (bewitAuth) serverMain :: IO () serverMain = run 8000 (middleware app) -auth :: ClientId -> IO (Either String (Credentials, Text)) -auth _ = return $ Right (Credentials sharedKey (HawkAlgo SHA256), "Steve") +auth :: ClientId -> IO (Either String (Hawk.Credentials, Text)) +auth _ = return $ Right (Hawk.Credentials sharedKey (HawkAlgo SHA256), "Steve") middleware :: Middleware middleware = bewitAuth def auth diff --git a/example/HawkClient.hs b/example/HawkClient.hs --- a/example/HawkClient.hs +++ b/example/HawkClient.hs @@ -4,6 +4,7 @@ import Control.Lens import Control.Monad (void) import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy as BL import Data.Either (isRight) @@ -11,30 +12,47 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Network.HTTP.Client (HttpException (..)) -import Network.HTTP.Types.Header (hAuthorization) -import Network.Wreq +import Network.HTTP.Types.Header (ResponseHeaders, hAuthorization, hWWWAuthenticate) +import Network.HTTP.Types.Status (Status(..)) +import Network.HTTP.Simple +import Data.Monoid ((<>)) import Common import Network.Hawk import qualified Network.Hawk.Client as Hawk +uri = "http://localhost:8000/resource/1?b=1&a=2" +creds = Hawk.Credentials "dh37fgj492je" sharedKey (HawkAlgo SHA256) +ext = Just "some-app-data" +payload = PayloadInfo "" "" + +clientMainSimple :: IO () +clientMainSimple = do + (arts, req) <- Hawk.sign creds ext (Just payload) 0 uri + r <- httpLBS req + + res <- Hawk.authenticate r creds arts + (Just $ getResponseBody r) + Hawk.ServerAuthorizationRequired + + printResponse (isRight res) r + +printResponse :: Bool -> Response BL.ByteString -> IO () +printResponse valid r = putStrLn $ (show $ getResponseStatusCode r) ++ ": " + ++ L8.unpack (getResponseBody r) + ++ (if valid then " (valid)" else " (invalid)") + clientMain :: IO () -clientMain = void $ clientAuth creds uri -- `E.catch` handler +clientMain = (withHawk httpLBS uri >>= printResponse True) `E.catches` handlers where - uri = "http://localhost:8000/resource/1?b=1&a=2" - creds = Hawk.Credentials "dh37fgj492je" sharedKey (HawkAlgo SHA256) - handler e@(StatusCodeException s _ _) - | s ^. statusCode == 401 = putStrLn "Unauthorized" - | otherwise = throwIO e + withHawk = Hawk.withHawk creds ext (Just payload) Hawk.ServerAuthorizationRequired + handlers = [E.Handler handleHTTP, E.Handler handleHawk] + handleHTTP e@(StatusCodeException s hdrs _) + | statusCode s == 401 = S8.putStrLn $ errMessage s hdrs + | otherwise = throwIO e + handleHawk (Hawk.HawkServerAuthorizationException e) + = putStrLn $ "Invalid server response: " ++ e -clientAuth :: Hawk.Credentials -> T.Text -> IO Bool -clientAuth creds uri = do - hdr <- Hawk.header uri "GET" creds Nothing (Just "some-app-data") - let opts = defaults & header hAuthorization .~ [Hawk.hdrField hdr] - r <- getWith opts (T.unpack uri) - let body = r ^. responseBody - res <- Hawk.authenticate r creds (Hawk.hdrArtifacts hdr) (Just body) Hawk.ServerAuthorizationRequired - putStrLn $ (show $ r ^. responseStatus . statusCode) ++ ": " - ++ L8.unpack body - ++ (if isRight res then " (valid)" else " (invalid)") - return $ isRight res +errMessage :: Status -> ResponseHeaders -> ByteString +errMessage s hdrs = statusMessage s <> maybe "" (": " <>) authHdr + where authHdr = lookup hWWWAuthenticate hdrs diff --git a/example/HawkServer.hs b/example/HawkServer.hs --- a/example/HawkServer.hs +++ b/example/HawkServer.hs @@ -17,31 +17,34 @@ import Network.Wai.Handler.Warp import Common -import Network.Hawk.Server.Types +import Network.Hawk.Types import qualified Network.Hawk.Server as Hawk +import qualified Network.Hawk.Server.Nonce as Hawk serverMain :: IO () -serverMain = run 8000 app +serverMain = do + opts <- Hawk.nonceOptsReq 60 + run 8000 (app opts) -auth :: ClientId -> IO (Either String (Credentials, Text)) -auth id = return $ Right (Credentials sharedKey (HawkAlgo SHA256), "Steve") +auth :: ClientId -> IO (Either String (Hawk.Credentials, Text)) +auth id = return $ Right (Hawk.Credentials sharedKey (HawkAlgo SHA256), "Steve") -app :: Application -app req respond = do +app :: Hawk.AuthReqOpts -> Application +app opts req respond = do payload <- lazyRequestBody req - res <- Hawk.authenticateRequest def auth req (Just payload) + res <- Hawk.authenticateRequest opts auth req (Just payload) respond $ case res of Right (Hawk.AuthSuccess creds artifacts user) -> let - ext = decodeUtf8 <$> shaExt artifacts + ext = decodeUtf8 <$> haExt 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 + Hawk.AuthFailBadRequest e _ -> e + Hawk.AuthFailUnauthorized e _ _ -> "Shoosh!" + Hawk.AuthFailStaleTimeStamp e _ _ _ -> e in responseLBS status [plain, hdr] (L8.pack msg) textPayload :: Text -> PayloadInfo diff --git a/example/Iron.hs b/example/Iron.hs new file mode 100644 --- /dev/null +++ b/example/Iron.hs @@ -0,0 +1,139 @@ +import Options.Applicative +import Control.Monad (join, unless) +import Data.Time.Clock (NominalDiffTime) +import Text.Read (readEither) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Char8 as S8 +import System.IO +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8') +import Data.Text.Encoding.Error (lenientDecode) + +import Network.Iron + +main :: IO () +main = join . execParser $ + info (helper <*> parser) + ( fullDesc + <> header "Iron Utility" + <> progDesc "Seals/unseals Iron messages." + ) + where + parser :: Parser (IO ()) + parser = + iron + <$> (Right <$> ( strOption + ( long "password" + <> short 'p' + <> metavar "STRING" + <> help "Encryption password" + )) <|> + (Left <$> ( strOption + ( long "password-file" + <> metavar "FILENAME" + <> help "File containing encryption password" + ) + )) + ) + <*> ( optional + ( flag' Seal + ( long "seal" + <> short 's' + <> help "Seal (encrypt) input" ) + <|> + flag' Unseal + ( long "unseal" + <> short 'u' + <> help "Unseal (decrypt) input" ) + ) + ) + <*> flag StringFormat JSONFormat + ( long "json" + <> short 'j' + <> help "Encode/decode input/output as JSON values" + ) + <*> option ttl + ( long "ttl" + <> metavar "NUMBER" + <> help "Ticket lifetime in seconds (default: 0 -- infinite)" + <> value 0 + ) + <*> option auto + (long "cipher" + <> metavar "TYPE" + <> help "Encryption algorithm: AES128CTR or AES256CBC (default)" + <> value AES256CBC + ) + +ttl :: ReadM NominalDiffTime +ttl = eitherReader (fmap fromInteger . readEither) + +data Action = Seal | Unseal +data Format = JSONFormat | StringFormat + +iron :: Either String String -> Maybe Action -> Format -> NominalDiffTime -> IronCipher -> IO () +iron p a j ttl c = do + p' <- password <$> readPassword p + let opts = def { ironEncryption = def { ieAlgorithm = c } + , ironTTL = ttl + } + L8.hGetContents stdin >>= mapM_ (processLine opts p' a j) . L8.lines + +readPassword :: Either FilePath String -> IO ByteString +readPassword (Left f) = withFile f ReadMode S8.hGetLine +-- fixme: error handling, checking if password is valid +readPassword (Right p) = return (S8.pack p) + +processLine :: Options -> Password -> Maybe Action -> Format -> L8.ByteString -> IO () +processLine opts p a j l = doLine opts p a j l >>= uncurry L8.hPutStrLn . output + +output :: Either String ByteString -> (Handle, L8.ByteString) +output (Left e) = (stderr, L8.pack e) +output (Right s) = (stdout, L8.fromStrict s) + +doLine :: Options -> Password -> Maybe Action -> Format -> L8.ByteString -> IO (Either String ByteString) +doLine o p (Just Unseal) j s = lineUnseal o p j s +doLine o p (Just Seal) j s = lineSeal o p j s +doLine o p Nothing j s | L8.isPrefixOf "Fe26.2" s = lineUnseal o p j s + | otherwise = lineSeal o p j s + +lineUnseal :: Options -> Password -> Format -> L8.ByteString -> IO (Either String ByteString) +lineUnseal o p j s = doUnseal o p s >>= return . join . fmap (fmap L8.toStrict . unconv j) + +lineSeal :: Options -> Password -> Format -> L8.ByteString -> IO (Either String ByteString) +lineSeal o p j s = case conv j s of + Right v -> doSeal o p v + Left e -> return (Left e) + +unconv :: Format -> Value -> Either String L8.ByteString +unconv JSONFormat v = Right . encode $ v +unconv StringFormat (String s) = Right . encodeUtf8 . TL.fromStrict $ s +unconv StringFormat _ = Left "Value is not a plain JSON string" + +conv :: Format -> L8.ByteString -> Either String Value +conv JSONFormat = eitherDecode' +conv StringFormat = mapEither show (String . TL.toStrict) . decodeUtf8' + +doSeal :: ToJSON a => Options -> Password -> a -> IO (Either String ByteString) +doSeal o p a = justRight "Failed to seal" <$> sealWith o p a + +doUnseal :: FromJSON a => Options -> Password -> L8.ByteString -> IO (Either String a) +doUnseal o p s = unsealWith o (const (Just p)) (L8.toStrict s) + + +-- | Modifies the left branch of an 'Either'. +mapLeft :: (a -> a') -> Either a b -> Either a' b +mapLeft f (Left a) = Left (f a) +mapLeft _ (Right b) = Right b + +-- | Modifies both branches of an 'Either'. +mapEither :: (a -> a') -> (b -> b') -> Either a b -> Either a' b' +mapEither f g = mapLeft f . fmap g + +-- | Converts 'Maybe' to 'Either'. +justRight :: e -> Maybe a -> Either e a +justRight _ (Just a) = Right a +justRight e Nothing = Left e diff --git a/example/OzServer.hs b/example/OzServer.hs --- a/example/OzServer.hs +++ b/example/OzServer.hs @@ -142,7 +142,7 @@ -- can be used to access Oz. printCurl :: OzApp -> Text -> Maybe Value -> IO Text printCurl (OzApp aid _ _ key algo) url mdata = do - auth <- Hawk.headerOz (TL.toStrict url) "POST" creds Nothing Nothing aid Nothing + auth <- Hawk.headerOz (TL.toStrict url) "POST" creds Nothing 0 Nothing aid Nothing let authHeader = decodeUtf8 . BL.fromStrict . fmtHeader . mkHeader $ auth return $ "curl -i -X POST " <> dataArg <> "-H 'Content-Type: application/json' -H '" <> authHeader <> "' " <> url where diff --git a/hsoz.cabal b/hsoz.cabal --- a/hsoz.cabal +++ b/hsoz.cabal @@ -1,5 +1,5 @@ name: hsoz -version: 0.0.0.3 +version: 0.0.0.4 synopsis: Iron, Hawk, Oz: Web auth protocols description: hsoz is a Haskell implementation of the Iron, Hawk, and Oz web @@ -16,7 +16,7 @@ license: BSD3 license-file: LICENSE author: Rodney Lorrimar -maintainer: dev@rodney.id.au +maintainer: Rodney Lorrimar copyright: 2016 Rodney Lorrimar category: Web, Authentication build-type: Simple @@ -25,18 +25,30 @@ cabal-version: >=1.10 stability: experimental bug-reports: https://github.com/rvl/hsoz/issues +Tested-With: GHC == 8.0.1 +flag example + description: Build the example applications + default: True + library hs-source-dirs: src exposed-modules: Network.Iron , Network.Hawk - , Network.Hawk.Types - , Network.Hawk.Server - , Network.Hawk.Server.Types - , Network.Hawk.Middleware , Network.Hawk.Client - , Network.Hawk.Client.Types + , Network.Hawk.Middleware + , Network.Hawk.Server + , Network.Hawk.Server.Nonce + , Network.Hawk.Types , Network.Hawk.URI + , Network.Hawk.Internal + , Network.Hawk.Internal.Client + , Network.Hawk.Internal.Client.HeaderParser + , Network.Hawk.Internal.Client.Types + , Network.Hawk.Internal.Server + , Network.Hawk.Internal.Server.Header + , Network.Hawk.Internal.Server.Types + , Network.Hawk.Internal.Types , Network.Oz , Network.Oz.Application , Network.Oz.Client @@ -45,9 +57,8 @@ , Network.Oz.Types other-modules: Network.Iron.Util , Network.Hawk.Algo - , Network.Hawk.Common , Network.Hawk.Util - , Network.Hawk.Client.HeaderParser + , Network.Hawk.Internal.JSON , Network.Oz.JSON , Network.Oz.Internal.Types , Network.Oz.Boom @@ -64,7 +75,9 @@ , data-default , either , errors - , http-client + , exceptions + , hashable + , http-client >= 0.4 && < 0.5 , http-types , lens , memory @@ -76,6 +89,7 @@ , text , time , transformers + , unordered-containers , uri-bytestring , vault , wai @@ -84,6 +98,11 @@ default-extensions: OverloadedStrings executable hsoz-example + if flag(example) + buildable: True + else + buildable: False + hs-source-dirs: example main-is: Main.hs other-modules: Common @@ -102,8 +121,8 @@ , containers , cryptonite , data-default - , http-client - , http-conduit + , http-client >= 0.4 && < 0.5 + , http-conduit >= 2.1 && < 2.2 , http-types , lens , lucid @@ -113,12 +132,30 @@ , uri-bytestring , wai , warp - , wreq default-language: Haskell2010 default-extensions: OverloadedStrings - if impl(ghcjs) - -- this is just because of wreq pulling in unbuildable deps - buildable: False + +executable iron + if flag(example) + buildable: True + else + buildable: False + + hs-source-dirs: example + main-is: Iron.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: hsoz + , aeson + , base + , bytestring + , containers + , cryptonite + , data-default + , optparse-applicative + , text + , time + default-language: Haskell2010 + default-extensions: OverloadedStrings test-suite hsoz-test type: exitcode-stdio-1.0 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 @@ -1,223 +1,31 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RecordWildCards #-} - -- | Functions for making Hawk-authenticated request headers and -- verifying responses from the server. +-- +-- The easiest way to make authenticated requests is to use 'withHawk' +-- with functions from the "Network.HTTP.Simple" module (from the +-- @http-conduit@ package). module Network.Hawk.Client - ( header - , headerOz - , getBewit - , authenticate + ( -- * Higher-level API + withHawk + -- ** Types , ServerAuthorizationCheck(..) + , HawkException(..) , Credentials(..) + -- * Protocol functions + , sign + , authenticate + , header + , headerOz + , getBewit + , message + -- ** Types , Header(..) , Authorization - , HeaderArtifacts , module Network.Hawk.Types ) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Crypto.Hash -import Crypto.Random -import qualified Data.ByteArray as BA (unpack) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as BL -import Data.Byteable (constEqBytes) -import Data.CaseInsensitive (CI (..)) -import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import Data.Time.Clock (NominalDiffTime) -import Data.Time.Clock.POSIX -import Network.HTTP.Types.Header (hContentType, hWWWAuthenticate, HeaderName) -import Network.HTTP.Types.Method (Method) -import Network.HTTP.Types.URI (extractPath) -import Network.HTTP.Client (Response, responseHeaders) -import Network.Socket (PortNumber, SockAddr (..)) -import URI.ByteString (authorityHost, authorityPort, - hostBS, laxURIParserOptions, - parseURI, portNumber, uriAuthority) - -import Network.Hawk.Common -import Network.Hawk.Types -import Network.Hawk.Util -import Network.Iron.Util -import Network.Hawk.Client.Types -import Network.Hawk.Client.HeaderParser - --- | Generates the Hawk authentication header for a request. -header :: Text -- ^ The request URL - -> Method -- ^ The request method - -> Credentials -- ^ Credentials used to generate the header - -> Maybe PayloadInfo -- ^ Optional request payload - -> Maybe Text -- ^ @ext@ data - -> IO Header -header url method creds payload ext = headerBase url method creds payload ext Nothing Nothing - --- | Generates the Hawk authentication header for an Oz request. Oz --- requires another attribute -- the application id. It also has an --- optional delegated-by attribute, which is the application id of the --- application the credentials were directly issued to. -headerOz :: Text -> Method -> Credentials -> Maybe PayloadInfo -> Maybe Text - -> Text -> Maybe Text -> IO Header -headerOz url method creds payload ext app dlg = headerBase url method creds payload ext (Just app) dlg - -headerBase :: Text -> Method -> Credentials -> Maybe PayloadInfo -> Maybe Text - -> Maybe Text -> Maybe Text -> IO Header -headerBase url method creds payload ext app dlg = do - now <- getPOSIXTime - nonce <- genNonce - let hash = calculatePayloadHash (ccAlgorithm creds) <$> payload - let art = clientHeaderArtifacts now nonce method (encodeUtf8 url) hash (encodeUtf8 <$> ext) app dlg - let auth = clientHawkAuth creds art - return $ Header auth art - -clientHeaderArtifacts :: POSIXTime -> ByteString -> Method -> ByteString - -> Maybe ByteString -> Maybe ByteString - -> Maybe Text -> Maybe Text - -> HeaderArtifacts -clientHeaderArtifacts now nonce method url hash ext app dlg = case splitUrl url of - Just (SplitURL host port resource) -> - HeaderArtifacts now nonce method host port resource hash ext app dlg - Nothing -> - HeaderArtifacts now nonce method "" Nothing url hash ext app dlg - -clientHawkAuth :: Credentials -> HeaderArtifacts -> ByteString -clientHawkAuth creds arts@HeaderArtifacts{..} = hawkHeaderString (hawkHeaderItems items) - where - items = [ ("id", (Just . encodeUtf8 . ccId) creds) - , ("ts", (Just . S8.pack . show . round) chaTimestamp) - , ("nonce", Just chaNonce) - , ("hash", chaHash) - , ("ext", chaExt) - , ("mac", Just $ clientMac HawkHeader creds arts) - , ("app", encodeUtf8 <$> chaApp) - , ("dlg", encodeUtf8 <$> chaDlg) - ] - -clientMac :: HawkType -> Credentials -> HeaderArtifacts -> ByteString -clientMac h Credentials{..} HeaderArtifacts{..} = - calculateMac ccAlgorithm ccKey - chaTimestamp chaNonce chaMethod chaResource chaHost chaPort h - -hawkHeaderItems :: [(ByteString, Maybe ByteString)] -> [(ByteString, ByteString)] -hawkHeaderItems = catMaybes . map pull - where - pull (k, Just v) = Just (k, v) - pull (k, Nothing) = Nothing - -splitUrl :: ByteString -> Maybe SplitURL -splitUrl url = SplitURL <$> host <*> pure port <*> path - where - p = either (const Nothing) uriAuthority (parseURI laxURIParserOptions url) - host = fmap (hostBS . authorityHost) p - port :: Maybe Int - port = fmap portNumber $ p >>= authorityPort - path = fmap (const (extractPath url)) p - -genNonce :: IO ByteString -genNonce = do - g <- getSystemDRG - return $ fst $ withRandomBytes g 10 B64.encode - --- | Whether the client wants to check the received --- @Server-Authorization@ header depends on the application. -data ServerAuthorizationCheck = ServerAuthorizationNotRequired - | ServerAuthorizationRequired - deriving Show - --- | Validates the server response. -authenticate :: Response body -> Credentials -> HeaderArtifacts - -> Maybe BL.ByteString -> ServerAuthorizationCheck - -> IO (Either String ()) -authenticate r creds artifacts payload saCheck = do - now <- getPOSIXTime - return $ clientAuthenticate' r creds artifacts payload saCheck now - -clientAuthenticate' :: Response body -> Credentials -> HeaderArtifacts - -> Maybe BL.ByteString -> ServerAuthorizationCheck - -> POSIXTime -> Either String () -clientAuthenticate' r creds artifacts payload saCheck now = do - let w = responseHeader hWWWAuthenticate r - ts <- mapM (checkWwwAuthenticateHeader creds) w - let sa = responseHeader hServerAuthorization r - sarh <- checkServerAuthorizationHeader creds artifacts saCheck now sa - let ct = fromMaybe "" $ responseHeader hContentType r - let payload' = PayloadInfo ct <$> payload - case sarh of - Just sarh' -> checkPayloadHash (ccAlgorithm creds) (sarhHash sarh') payload' - Nothing -> Right () - --- fixme: lens version from wreq is better -responseHeader :: HeaderName -> Response body -> Maybe ByteString -responseHeader h = lookup h . responseHeaders - --- | The protocol relies on a clock sync between the client and --- server. To accomplish this, the server informs the client of its --- current time when an invalid timestamp is received. --- --- If an attacker is able to manipulate this information and cause the --- client to use an incorrect time, it would be able to cause the --- client to generate authenticated requests using time in the --- future. Such requests will fail when sent by the client, and will --- not likely leave a trace on the server (given the common --- implementation of nonce, if at all enforced). The attacker will --- then be able to replay the request at the correct time without --- detection. --- --- The client must only use the time information provided by the --- server if: --- --- * it was delivered over a TLS connection and the server identity --- has been verified, or --- * the `tsm` MAC digest calculated using the same client credentials --- over the timestamp has been verified. --- --- fixme: implement checks for both of the above conditions -checkWwwAuthenticateHeader :: Credentials -> ByteString -> Either String POSIXTime -checkWwwAuthenticateHeader creds w = do - WwwAuthenticateHeader{..} <- parseWwwAuthenticateHeader w - let tsm = calculateTsMac (ccAlgorithm creds) wahTs - if wahTsm `constEqBytes` tsm - then Right wahTs - else Left "Invalid server timestamp hash" - -checkServerAuthorizationHeader :: Credentials -> HeaderArtifacts - -> ServerAuthorizationCheck -> POSIXTime - -> Maybe ByteString - -> Either String (Maybe ServerAuthorizationReplyHeader) -checkServerAuthorizationHeader _ _ ServerAuthorizationNotRequired _ Nothing = Right Nothing -checkServerAuthorizationHeader _ _ ServerAuthorizationRequired _ Nothing = Left "Missing Server-Authorization header" -checkServerAuthorizationHeader creds arts _ now (Just sa) = do - sarh <- parseServerAuthorizationReplyHeader sa - let mac = clientMac HawkResponse creds arts - if sarhMac sarh `constEqBytes` mac - then Right (Just sarh) - else Left "Bad response mac" - ----------------------------------------------------------------------------- - --- | Generate a bewit value for a given URI. -getBewit :: Credentials -> NominalDiffTime -> Maybe ByteString -> NominalDiffTime - -> ByteString -> IO (Maybe ByteString) --- fixme: ext is a json value i think --- fixme: javascript version supports deconstructed parsed uri objects --- fixme: not much point having two time interval arguments? -getBewit creds ttl ext offset uri = do - exp <- fmap (+ (ttl + offset)) getPOSIXTime - return $ bewit exp <$> splitUrl uri - where - bewit exp = encode . clientMac HawkBewit creds . make - where - make (SplitURL host port resource) = - HeaderArtifacts exp "" "GET" host port resource Nothing ext Nothing Nothing - encode = b64url . S8.intercalate "\\" . parts - parts mac = [ encodeUtf8 . ccId $ creds - , S8.pack . show . round $ exp - , mac, fromMaybe "" ext ] +import Network.Hawk.Internal.Client +import Network.Hawk.Internal.Client.Types +import Network.Hawk.Types +import Network.Hawk.Internal diff --git a/src/Network/Hawk/Client/HeaderParser.hs b/src/Network/Hawk/Client/HeaderParser.hs deleted file mode 100644 --- a/src/Network/Hawk/Client/HeaderParser.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Network.Hawk.Client.HeaderParser - ( parseWwwAuthenticateHeader - , parseServerAuthorizationReplyHeader - , WwwAuthenticateHeader(..) - , ServerAuthorizationReplyHeader(..) - ) where - -import Data.ByteString (ByteString) -import Data.Time.Clock.POSIX (POSIXTime) -import Network.Hawk.Client.Types -import Control.Monad (join) - -import Network.Hawk.Util - --- | Represents the `WWW-Authenticate` header which the server uses to --- respond when the client isn't authenticated. -data WwwAuthenticateHeader = WwwAuthenticateHeader - { wahTs :: POSIXTime -- ^ server's timestamp - , wahTsm :: ByteString -- ^ timestamp mac - , wahError :: ByteString - } deriving Show - --- | Represents the `Server-Authorization` header which the server --- sends back to the client. -data ServerAuthorizationReplyHeader = ServerAuthorizationReplyHeader - { sarhMac :: ByteString - , sarhHash :: Maybe ByteString -- ^ optional payload hash - , sarhExt :: Maybe ByteString - } deriving Show - -parseWwwAuthenticateHeader :: ByteString -> Either String WwwAuthenticateHeader -parseWwwAuthenticateHeader = fmap snd . parseHeader wwwKeys wwwAuthHeader - -parseServerAuthorizationReplyHeader :: ByteString -> Either String ServerAuthorizationReplyHeader -parseServerAuthorizationReplyHeader = fmap snd . parseHeader serverKeys serverAuthReplyHeader - -wwwKeys = ["tsm", "ts", "error"] -serverKeys = ["mac", "ext", "hash"] - -wwwAuthHeader :: AuthAttrs -> Either String WwwAuthenticateHeader -wwwAuthHeader m = do - credTs <- join (readTs <$> authAttr m "ts") - credTsm <- authAttr m "tsm" - credError <- authAttr m "error" - return $ WwwAuthenticateHeader credTs credTsm credError - -serverAuthReplyHeader :: AuthAttrs -> Either String ServerAuthorizationReplyHeader -serverAuthReplyHeader m = do - mac <- authAttr m "mac" - let hash = authAttrMaybe m "hash" - let ext = authAttrMaybe m "ext" - return $ ServerAuthorizationReplyHeader mac hash ext diff --git a/src/Network/Hawk/Client/Types.hs b/src/Network/Hawk/Client/Types.hs deleted file mode 100644 --- a/src/Network/Hawk/Client/Types.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - --- | Consider this module to be internal, and don't import directly. - -module Network.Hawk.Client.Types where - -import Data.Text (Text) -import Data.ByteString (ByteString) -import Data.Time.Clock.POSIX (POSIXTime) -import GHC.Generics -import Network.HTTP.Types.Method (Method) - -import Network.Hawk.Common -import Network.Hawk.Types - --- | ID and key used for encrypting Hawk @Authorization@ header. -data Credentials = Credentials - { ccId :: ClientId - , ccKey :: Key - , ccAlgorithm :: HawkAlgo - } deriving (Show, Generic) - --- | Struct for attributes which will be encoded in the Hawk --- @Authorization@ header. The term "artifacts" comes from the --- original Javascript implementation of Hawk. -data HeaderArtifacts = HeaderArtifacts - { chaTimestamp :: POSIXTime - , chaNonce :: ByteString - , chaMethod :: Method - , chaHost :: ByteString - , chaPort :: Maybe Int - , chaResource :: ByteString - , chaHash :: Maybe ByteString - , chaExt :: Maybe ByteString -- fixme: this should be json value - , chaApp :: Maybe Text -- ^ app id, for oz - , chaDlg :: Maybe Text -- ^ delegated-by app id, for oz - } deriving Show - --- | The result of Hawk header generation. -data Header = Header - { hdrField :: Authorization -- ^ Value of @Authorization@ header. - , hdrArtifacts :: HeaderArtifacts -- ^ Not sure if this is needed by users. - } deriving (Show, Generic) - - -data SplitURL = SplitURL - { urlHost :: ByteString - , urlPort :: Maybe Int - , urlPath :: ByteString - } deriving (Show, Generic) diff --git a/src/Network/Hawk/Common.hs b/src/Network/Hawk/Common.hs deleted file mode 100644 --- a/src/Network/Hawk/Common.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} - -module Network.Hawk.Common - ( calculateMac - , escapeHeaderAttribute - , hawkHeaderString - , calculateTsMac - , calculatePayloadHash - , checkPayloadHash - , checkPayloadHashMaybe - , hServerAuthorization - , HawkType(..) - , Authorization - ) where - -import Crypto.Hash.Algorithms (HashAlgorithm, SHA1 (..), - SHA256 (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder (byteString, charUtf8, - toLazyByteString) -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as BL -import Data.Byteable (constEqBytes) -import Data.Char (toLower, toUpper) -import Data.List (intercalate) -import Data.Monoid ((<>)) -import Data.Time.Clock.POSIX -import Network.HTTP.Types.Header (HeaderName) -import Network.HTTP.Types.Method (Method) - -import Network.Hawk.Types - -data HawkType = HawkHeader | HawkBewit | HawkResponse - deriving (Show, Eq) - --- | The value of an @Authorization@ header. -type Authorization = ByteString - --- | Generates a @hawk.1.@ string with the given attributes, --- calculates its HMAC, and returns the Base64 encoded hash. -calculateMac :: HawkAlgoCls a => a -> Key - -> POSIXTime -> ByteString -> Method - -> ByteString -> ByteString -> Maybe Int - -> HawkType -> ByteString -calculateMac a key ts nonce method path host port hawkType = hawkMac a key str - where - str = hawk1String hawkType ts nonce method path host port - --- This would be the same as Hoek.escapeHeaderAttribute, which --- replaces double quotes and backslashes so that the string can be --- put in a HTTP header. I'm not sure if it's needed if WAI already --- quotes header values. -escapeHeaderAttribute :: ByteString -> ByteString -escapeHeaderAttribute = id - -checkPayload :: HawkAlgoCls a => Maybe ByteString -> a -> ContentType -> BL.ByteString -> Either String () -checkPayload (Just hash) algo ct payload = if good then Right () else Left "Bad payload hash" - where - good = hash `constEqBytes` (calculatePayloadHash algo payloadInfo) - payloadInfo = PayloadInfo ct payload -checkPayload Nothing algo ct payload = Left "Missing required payload hash" - -checkPayloadHashMaybe :: HawkAlgoCls a => a -> Maybe ByteString -> Maybe PayloadInfo -> Maybe Bool -checkPayloadHashMaybe _ _ Nothing = Just True -checkPayloadHashMaybe _ Nothing (Just _) = Nothing -checkPayloadHashMaybe algo (Just hash) (Just payload) = Just (hash == calculatePayloadHash algo payload) - -checkPayloadHash :: HawkAlgoCls a => a -> Maybe ByteString -> Maybe PayloadInfo -> Either String () -checkPayloadHash algo hash payload = case checkPayloadHashMaybe algo hash payload of - Nothing -> Left "Missing response hash attribute" - Just False -> Left "Bad response payload mac" - Just True -> Right () - -hawk1String :: HawkType -> POSIXTime -> ByteString -> Method -> ByteString -> ByteString -> Maybe Int -> ByteString --- corresponds to generateNormalizedString in crypto.js --- fixme: ext and payload hash -hawk1String t ts nonce method resource host port = newlines $ - [ "hawk.1." <> hawkType t - , S8.pack . show . round $ ts - , nonce - , S8.map toUpper method - , resource - , S8.map toLower host - , maybe "" (S8.pack . show) port - , payloadHash - ] ++ ext - where - ext = [] - payloadHash = "" - -hawk1Payload :: PayloadInfo -> ByteString -hawk1Payload (PayloadInfo contentType body) = newlines [ "hawk.1.payload" - , contentType - , BL.toStrict body ] - -newlines :: [ByteString] -> ByteString -newlines lines = BS.intercalate (S8.singleton '\n') (lines ++ [""]) - -hawkType :: HawkType -> ByteString -hawkType HawkHeader = "header" -hawkType HawkBewit = "bewit" -hawkType HawkResponse = "response" - -hawk1Header = hawk1String HawkHeader - --- Generates an @Authorization@ header string of the form: --- Hawk id="app123", ts="1476130687", nonce="+olvVyT7i8dqkA==", --- mac="xG9KhUQXjCSWbqNbRI41tI19+fG0upsuDoVbNpt8+K0=", app="app123" -hawkHeaderString :: [(ByteString, ByteString)] -> ByteString -hawkHeaderString items = BL.toStrict $ toLazyByteString bld - where - bld = byteString "Hawk " <> mconcat (intercalate comma $ foldMap q items) - comma = [byteString ", "] - q (k, v) = [[byteString k, byteString "=\"", byteString v, byteString "\""]] - -calculatePayloadHash :: HawkAlgoCls a => a -> PayloadInfo -> ByteString --- 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. -hServerAuthorization :: HeaderName -hServerAuthorization = "Server-Authorization" diff --git a/src/Network/Hawk/Internal.hs b/src/Network/Hawk/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} + +-- | These functions are intended only to be used internally by this +-- package. No API stability is guaranteed for this module. If you see +-- functions here which you believe should be promoted to a stable +-- API, please contact the author. + +module Network.Hawk.Internal + ( calculateMac + , escapeHeaderAttribute + , hawkHeaderString + , calculateTsMac + , calculatePayloadHash + , checkPayloadHash + , checkPayloadHashMaybe + , hServerAuthorization + , HawkType(..) + , Authorization + ) where + +import Crypto.Hash.Algorithms (HashAlgorithm, SHA1 (..), + SHA256 (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (byteString, charUtf8, + toLazyByteString) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL +import Data.Text.Encoding (encodeUtf8) +import Data.Byteable (constEqBytes) +import Data.Char (toLower, toUpper) +import Data.List (intercalate) +import Data.Monoid ((<>)) +import Data.Maybe (fromMaybe) +import Data.Time.Clock.POSIX +import Network.HTTP.Types.Header (HeaderName) +import Network.HTTP.Types.Method (Method) + +import Network.Hawk.Algo +import Network.Hawk.Internal.Types + +data HawkType = HawkHeader + | HawkMessage + | HawkBewit + | HawkResponse + | HawkPayload + | HawkTs + deriving (Show, Eq) + +-- | The value of an @Authorization@ header. +type Authorization = ByteString + +-- | Generates a @hawk.1.@ string with the given attributes, +-- calculates its HMAC, and returns the Base64 encoded hash. +calculateMac :: HawkAlgoCls a => a -> Key -> HawkType -> HeaderArtifacts -> ByteString +calculateMac a key ty arts = hawkMac a key $ hawk1String ty arts + +-- This would be the same as Hoek.escapeHeaderAttribute, which +-- replaces double quotes and backslashes so that the string can be +-- put in a HTTP header. I'm not sure if it's needed if WAI already +-- quotes header values. +escapeHeaderAttribute :: ByteString -> ByteString +escapeHeaderAttribute = id + +checkPayload :: HawkAlgoCls a => Maybe ByteString -> a -> ContentType -> BL.ByteString -> Either String () +checkPayload (Just hash) algo ct payload = if good then Right () else Left "Bad payload hash" + where + good = hash `constEqBytes` (calculatePayloadHash algo payloadInfo) + payloadInfo = PayloadInfo ct payload +checkPayload Nothing algo ct payload = Left "Missing required payload hash" + +checkPayloadHashMaybe :: HawkAlgoCls a => a -> Maybe ByteString -> Maybe PayloadInfo -> Maybe Bool +checkPayloadHashMaybe _ _ Nothing = Just True +checkPayloadHashMaybe _ Nothing (Just _) = Nothing +checkPayloadHashMaybe algo (Just hash) (Just payload) = Just (hash == calculatePayloadHash algo payload) + +checkPayloadHash :: HawkAlgoCls a => a -> Maybe ByteString -> Maybe PayloadInfo -> Either String () +checkPayloadHash algo hash payload = case checkPayloadHashMaybe algo hash payload of + Nothing -> Left "Missing response hash attribute" + Just False -> Left "Bad response payload mac" + Just True -> Right () + +hawk1String :: HawkType -> HeaderArtifacts -> ByteString +-- corresponds to generateNormalizedString in crypto.js +hawk1String t HeaderArtifacts{..} = newlines $ + [ hawk1Header t + , S8.pack . show . round $ haTimestamp + , haNonce + , S8.map toUpper haMethod + , haResource + , S8.map toLower haHost + , maybe "" (S8.pack . show) haPort + , fromMaybe "" haHash + , maybe "" escapeExt haExt + ] ++ map encodeUtf8 (oz haApp haDlg) + where + oz Nothing _ = [] + oz (Just a) (Just d) = [a, d] + oz (Just a) Nothing = [a] + +hawk1Payload :: PayloadInfo -> ByteString +hawk1Payload (PayloadInfo contentType body) = newlines [ hawk1Header HawkPayload + , contentType + , BL.toStrict body ] + +hawk1Ts :: POSIXTime -> ByteString +hawk1Ts ts = newlines [hawk1Header HawkTs, nowSecs ts] + where nowSecs = S8.pack . show . floor + +hawk1Header :: HawkType -> ByteString +hawk1Header t = "hawk.1." <> hawkType t + +hawkType :: HawkType -> ByteString +hawkType HawkHeader = "header" +hawkType HawkMessage = "message" +hawkType HawkBewit = "bewit" +hawkType HawkResponse = "response" +hawkType HawkPayload = "payload" +hawkType HawkTs = "ts" + +newlines :: [ByteString] -> ByteString +newlines lines = BS.intercalate (S8.singleton '\n') (lines ++ [""]) + +escapeExt :: ExtData -> ExtData +escapeExt = sub '\n' "\\n" . sub '\\' "\\\\" + where + sub s r = BS.intercalate r . S8.split s + +-- Generates an @Authorization@ header string of the form: +-- Hawk id="app123", ts="1476130687", nonce="+olvVyT7i8dqkA==", +-- mac="xG9KhUQXjCSWbqNbRI41tI19+fG0upsuDoVbNpt8+K0=", app="app123" +hawkHeaderString :: [(ByteString, ByteString)] -> ByteString +hawkHeaderString items = BL.toStrict $ toLazyByteString bld + where + bld = byteString "Hawk " <> mconcat (intercalate comma $ foldMap q items) + comma = [byteString ", "] + q (k, v) = [[byteString k, byteString "=\"", byteString v, byteString "\""]] + +calculatePayloadHash :: HawkAlgoCls a => a -> PayloadInfo -> ByteString +-- 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) + +-- | The name of the authorization header which the server provides to +-- the client. +hServerAuthorization :: HeaderName +hServerAuthorization = "Server-Authorization" diff --git a/src/Network/Hawk/Internal/Client.hs b/src/Network/Hawk/Internal/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal/Client.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Note that this is essentially the "kitchen sink" export module, +-- including many functions intended only to be used internally by +-- this package. No API stability is guaranteed for this module. If +-- you see functions here which you believe should be promoted to a +-- stable API, please contact the author. + +module Network.Hawk.Internal.Client where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.Hash +import Crypto.Random +import qualified Data.ByteArray as BA (unpack) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL +import Data.Byteable (constEqBytes) +import Data.CaseInsensitive (CI (..)) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (NominalDiffTime) +import Data.Time.Clock.POSIX +import Network.HTTP.Types.Header (HeaderName, hContentType, hWWWAuthenticate, hAuthorization, ResponseHeaders) +import Network.HTTP.Types.Method (Method) +import Network.HTTP.Types.Status (Status, statusCode) +import Network.HTTP.Types.URI (extractPath) +import Network.HTTP.Client (Response, responseHeaders) +import Network.HTTP.Client (Request, requestHeaders, requestBody, getUri, method, secure) +import Network.HTTP.Client (HttpException(..)) +import URI.ByteString (authorityHost, authorityPort, + hostBS, laxURIParserOptions, + parseURI, portNumber, uriAuthority, + uriScheme, schemeBS) +import Data.Typeable (Typeable) +import Control.Exception (Exception, throwIO) +import Control.Monad.Catch as E (MonadThrow(..), MonadCatch(..), handle) +import Control.Monad (join, void) + +import Network.Hawk.Internal +import Network.Hawk.Internal.Types +import Network.Hawk.Util +import Network.Iron.Util +import Network.Hawk.Internal.Client.Types +import Network.Hawk.Internal.Client.HeaderParser + +-- | Generates the Hawk authentication header for a request. +header :: Text -- ^ The request URL + -> Method -- ^ The request method + -> Credentials -- ^ Credentials used to generate the header + -> Maybe PayloadInfo -- ^ Optional request payload + -> NominalDiffTime -- ^ Time offset to sync with server time + -> Maybe ExtData -- ^ Application-specific @ext@ data + -> IO Header +header url method creds payload skew ext = + headerBase url method creds payload skew ext Nothing Nothing + +-- | Generates the Hawk authentication header for an Oz request. Oz +-- requires another attribute -- the application id. It also has an +-- optional delegated-by attribute, which is the application id of the +-- application the credentials were directly issued to. +headerOz :: Text -- ^ The request URL + -> Method -- ^ The request method + -> Credentials -- ^ Credentials used to generate the header + -> Maybe PayloadInfo -- ^ Optional request payload + -> NominalDiffTime -- ^ Time offset to sync with server time + -> Maybe ExtData -- ^ Application-specific @ext@ data + -> Text -- ^ Oz application identifier + -> Maybe Text -- ^ Oz delegated application + -> IO Header +headerOz url method creds payload skew ext app dlg = + headerBase url method creds payload skew ext (Just app) dlg + +headerBase :: Text -> Method -> Credentials -> Maybe PayloadInfo -> NominalDiffTime + -> Maybe ExtData -> Maybe Text -> Maybe Text -> IO Header +headerBase url method creds payload skew ext app dlg = + headerBase' url method creds payload skew ext app dlg <$> getPOSIXTime <*> genNonce + +headerBase' :: Text -> Method -> Credentials + -> Maybe PayloadInfo -> NominalDiffTime + -> Maybe ExtData -> Maybe Text -> Maybe Text + -> POSIXTime -> ByteString -> Header +headerBase' url method creds payload skew ext app dlg ts nonce = let + arts = header' HawkHeader url method creds payload skew ext app dlg ts nonce + in Header (clientHawkAuth arts) arts + +-- | Generates an authorization object for a Hawk signed message. +message :: Credentials -- ^ Credentials for encryption. + -> ByteString -- ^ Destination host. + -> Maybe Int -- ^ Destination port. + -> BL.ByteString -- ^ The message. + -> NominalDiffTime -- ^ Time offset to sync with server time. + -> IO MessageAuth +message creds host port msg skew = + message' creds host port msg skew <$> getPOSIXTime <*> genNonce + +-- | Generates an authorization object for a Hawk signed message. This +-- variation allows the user to provide the message timestamp and +-- nonce string. +message' :: Credentials -- ^ Credentials for encryption. + -> ByteString -- ^ Destination host. + -> Maybe Int -- ^ Destination port. + -> BL.ByteString -- ^ The message. + -> NominalDiffTime -- ^ Time offset to sync with server time. + -> POSIXTime -- ^ Message timestamp. + -> ByteString -- ^ Random nonce string. + -> MessageAuth +message' creds host port msg skew ts nonce = artsMsg creds arts + where + arts = HeaderArtifacts "" host port "" (ccId creds) ts' nonce "" (Just hash) Nothing Nothing Nothing + hash = calculatePayloadHash (ccAlgorithm creds) payload + payload = PayloadInfo "" msg + ts' = ts + skew + +-- | Signs a message stored in the given artifacts bundle. +artsMsg :: Credentials -> HeaderArtifacts -> MessageAuth +artsMsg creds arts@HeaderArtifacts{..} = MessageAuth haId haTimestamp haNonce hash mac + where + mac = clientMac creds HawkMessage arts + hash = fromMaybe "" haHash + +header' :: HawkType -> Text -> Method -> Credentials + -> Maybe PayloadInfo -> NominalDiffTime + -> Maybe ExtData -> Maybe Text -> Maybe Text + -> POSIXTime -> ByteString -> HeaderArtifacts +header' ty url method creds payload skew ext app dlg ts nonce = arts + where + arts = headerArtifacts ts' nonce method (encodeUtf8 url) + hash ext app dlg (ccId creds) mac + hash = calculatePayloadHash (ccAlgorithm creds) <$> payload + mac = clientMac creds ty arts + ts' = ts + skew + +-- | Constructs artifacts bundle from header params. +headerArtifacts :: POSIXTime -> ByteString -> Method -> ByteString + -> Maybe ByteString -> Maybe ByteString + -> Maybe Text -> Maybe Text + -> ClientId -> ByteString + -> HeaderArtifacts +headerArtifacts now nonce method url hash ext app dlg cid mac = + HeaderArtifacts method host (Just port') resource cid now nonce mac hash ext app dlg + where + s@(SplitURL _ host port resource) = fromMaybe relUrl $ splitUrl url + relUrl = SplitURL HTTP "" Nothing url + port' = urlPort' s + +clientHawkAuth :: HeaderArtifacts -> ByteString +clientHawkAuth arts@HeaderArtifacts{..} = hawkHeaderString (hawkHeaderItems items) + where + items = [ ("id", Just . encodeUtf8 $ haId) + , ("ts", Just . S8.pack . show . round $ haTimestamp) + , ("nonce", Just haNonce) + , ("hash", haHash) + , ("ext", haExt) + , ("mac", Just haMac) + , ("app", encodeUtf8 <$> haApp) + , ("dlg", encodeUtf8 <$> haDlg) + ] + +clientMac :: Credentials -> HawkType -> HeaderArtifacts -> ByteString +clientMac Credentials{..} = calculateMac ccAlgorithm ccKey + +hawkHeaderItems :: [(ByteString, Maybe ByteString)] -> [(ByteString, ByteString)] +hawkHeaderItems = catMaybes . map pull + where + pull (k, Just v) = Just (k, v) + pull (k, Nothing) = Nothing + +splitUrl :: ByteString -> Maybe SplitURL +splitUrl url = SplitURL s <$> host <*> pure port <*> path + where + p = either (const Nothing) Just (parseURI laxURIParserOptions url) + a = p >>= uriAuthority + https = fmap (schemeBS . uriScheme) p == Just "https" + s = if https then HTTPS else HTTP + host = fmap (hostBS . authorityHost) a + port :: Maybe Int + port = fmap portNumber (a >>= authorityPort) + path = fmap (const (extractPath url)) a + +genNonce :: IO ByteString +genNonce = takeRandom 10 <$> getSystemDRG + where takeRandom n g = fst $ withRandomBytes g n (b64url :: ByteString -> ByteString) + +-- | Whether the client wants to check the received +-- @Server-Authorization@ header depends on the application. +data ServerAuthorizationCheck = ServerAuthorizationNotRequired + | ServerAuthorizationRequired + deriving Show + +-- | Validates the server response from a signed request. If the +-- payload body is provided, its hash will be checked. +authenticate :: Response body -- ^ Response from server. + -> Credentials -- ^ Credentials used for signing the request. + -> HeaderArtifacts -- ^ The result of 'sign'. + -> Maybe BL.ByteString -- ^ Optional payload body from response. + -> ServerAuthorizationCheck -- ^ Whether a valid @Server-Authorization@ header is required. + -> IO (Either String (Maybe ServerAuthorizationHeader)) -- ^ Error message if authentication failed. +authenticate r creds artifacts payload saCheck = do + now <- getPOSIXTime + return $ authenticate' r creds artifacts payload saCheck now + +authenticate' :: Response body -> Credentials -> HeaderArtifacts + -> Maybe BL.ByteString -> ServerAuthorizationCheck + -> POSIXTime -> Either String (Maybe ServerAuthorizationHeader) +authenticate' r creds arts payload saCheck now = do + let w = responseHeader hWWWAuthenticate r + ts <- mapM (checkWwwAuthenticateHeader creds) w + let sa = responseHeader hServerAuthorization r + msah <- checkServerAuthorizationHeader creds arts saCheck now sa + let ct = fromMaybe "" $ responseHeader hContentType r + let payload' = PayloadInfo ct <$> payload + case msah of + Just sah -> checkPayloadHash (ccAlgorithm creds) (sahHash sah) payload' + Nothing -> return () + return msah + +-- fixme: lens version from wreq is better +responseHeader :: HeaderName -> Response body -> Maybe ByteString +responseHeader h = lookup h . responseHeaders + +-- | The protocol relies on a clock sync between the client and +-- server. To accomplish this, the server informs the client of its +-- current time when an invalid timestamp is received. +-- +-- If an attacker is able to manipulate this information and cause the +-- client to use an incorrect time, it would be able to cause the +-- client to generate authenticated requests using time in the +-- future. Such requests will fail when sent by the client, and will +-- not likely leave a trace on the server (given the common +-- implementation of nonce, if at all enforced). The attacker will +-- then be able to replay the request at the correct time without +-- detection. +-- +-- The client must only use the time information provided by the +-- server if: +-- +-- * it was delivered over a TLS connection and the server identity +-- has been verified, or +-- * the `tsm` MAC digest calculated using the same client credentials +-- over the timestamp has been verified. +checkWwwAuthenticateHeader :: Credentials -> ByteString -> Either String (Maybe POSIXTime) +checkWwwAuthenticateHeader creds w = parseWwwAuthenticateHeader w >>= check + where + check h | tsm `tsmEq` (wahTsm h) = Right (wahTs h) + | otherwise = Left "Invalid server timestamp hash" + where tsm = calculateTsMac (ccAlgorithm creds) <$> wahTs h + + tsmEq :: Maybe ByteString -> Maybe ByteString -> Bool + tsmEq (Just a) (Just b) = a `constEqBytes` b + tsmEq (Just _) Nothing = False + tsmEq _ _ = True + +checkServerAuthorizationHeader :: Credentials -> HeaderArtifacts + -> ServerAuthorizationCheck -> POSIXTime + -> Maybe ByteString + -> Either String (Maybe ServerAuthorizationHeader) +checkServerAuthorizationHeader _ _ ServerAuthorizationNotRequired _ Nothing = Right Nothing +checkServerAuthorizationHeader _ _ ServerAuthorizationRequired _ Nothing = Left "Missing Server-Authorization header" +checkServerAuthorizationHeader creds arts _ now (Just sa) = + parseServerAuthorizationHeader sa >>= check + where check sah | sahMac sah `constEqBytes` mac = Right (Just sah) + | otherwise = Left "Bad response mac" + where + arts' = responseArtifacts sah arts + mac = clientMac creds HawkResponse arts' + +-- | Updates the artifacts which were used for client authentication +-- with values from there server's response. +responseArtifacts :: ServerAuthorizationHeader -> HeaderArtifacts -> HeaderArtifacts +responseArtifacts ServerAuthorizationHeader{..} arts = arts { haMac = sahMac + , haExt = sahExt + , haHash = sahHash + } + +---------------------------------------------------------------------------- + +-- | Generate a bewit value for a given URI. If the URI can't be +-- parsed, @Nothing@ will be returned. +-- +-- See "Network.Hawk.URI" for more information about bewits. +getBewit :: Credentials -- ^ Credentials used to generate the bewit. + -> NominalDiffTime -- ^ Time-to-live (TTL) value. + -> Maybe ExtData -- ^ Optional application-specific data. + -> NominalDiffTime -- ^ Time offset to sync with server time. + -> ByteString -- ^ URI. + -> IO (Maybe ByteString) -- ^ Base-64 encoded bewit value. +-- fixme: javascript version supports deconstructed parsed uri objects +-- fixme: not much point having two time interval arguments? Maybe just have a single expiry time argument. +getBewit creds ttl ext offset uri = do + exp <- fmap (+ (ttl + offset)) getPOSIXTime + return $ encodeBewit creds <$> bewitArtifacts uri exp ext + +bewitArtifacts :: ByteString -> POSIXTime -> Maybe ExtData -> Maybe HeaderArtifacts +bewitArtifacts uri exp ext = make <$> splitUrl uri + where make (SplitURL s host port resource) = + HeaderArtifacts "GET" host port resource "" exp "" "" Nothing ext Nothing Nothing + +encodeBewit :: Credentials -> HeaderArtifacts -> ByteString +encodeBewit creds arts = bewitString (ccId creds) (haTimestamp arts) mac (haExt arts) + where mac = clientMac creds HawkBewit arts + +-- | Constructs a bewit: @id\exp\mac\ext@ +bewitString :: ClientId -> POSIXTime -> ByteString -> Maybe ExtData -> ByteString +bewitString cid exp mac ext = b64url (S8.intercalate "\\" parts) + where parts = [ encodeUtf8 cid, S8.pack . show . round $ exp + , mac, fromMaybe "" ext ] + +---------------------------------------------------------------------------- + +-- | Modifies a 'Wai.Request' to include the @Authorization@ header +-- necessary for Hawk. +sign :: MonadIO m => Credentials -- ^ Credentials for signing + -> Maybe ExtData -- ^ Optional application-specific data. + -> Maybe PayloadInfo -- ^ Optional payload to hash + -> NominalDiffTime -- ^ Time offset to sync with server time + -> Request -- ^ The request to sign + -> m (HeaderArtifacts, Request) +sign creds ext payload skew req = do + let uri = T.pack . show . getUri $ req + hdr <- liftIO $ header uri (method req) creds payload skew ext + return $ (hdrArtifacts hdr, addAuth hdr req) + +addAuth :: Header -> Request -> Request +addAuth hdr req = req { requestHeaders = (auth:requestHeaders req) } + where auth = (hAuthorization, hdrField hdr) + +-- | Client exceptions specific to Hawk. +data HawkException = HawkServerAuthorizationException String + -- ^ The returned @Server-Authorization@ header did not validate. + deriving (Show, Typeable) +instance Exception HawkException + +-- | Signs and executes a request, then checks the server's +-- response. Handles retrying of requests if the server and client +-- clocks are out of sync. +-- +-- A 'HawkException' will be thrown if the server's response fails to +-- authenticate. +withHawk :: (MonadIO m, MonadCatch m) => + Credentials -- ^ Credentials for signing the request. + -> Maybe ExtData -- ^ Optional application-specific data. + -> Maybe PayloadInfo -- ^ Optional payload to sign. + -> ServerAuthorizationCheck -- ^ Whether to verify the server's response. + -> (Request -> m (Response body)) -- ^ The action to run with the request. + -> Request -- ^ The request to sign. + -> m (Response body) -- ^ The result of the action. +withHawk creds ext payload ck http req = withHawkBase creds ext payload ck http req + +withHawkPayload :: (MonadIO m, MonadCatch m) => + Credentials -> Maybe ExtData -> PayloadInfo + -> ServerAuthorizationCheck + -> (Request -> m (Response body)) -> Request -> m (Response body) +withHawkPayload creds ext payload ck http req = withHawkBase creds ext (Just payload) ck http req + +-- | Makes a Hawk signed request. If the server responds saying "Stale +-- timestamp", then retry using an adjusted timestamp. +withHawkBase :: (MonadIO m, MonadThrow m, MonadCatch m) => + Credentials -> Maybe ExtData -> Maybe PayloadInfo + -> ServerAuthorizationCheck + -> (Request -> m (Response body)) -> Request -> m (Response body) +withHawkBase creds ext payload ck http req = do + let handle = makeExpiryHandler creds req + r <- handle $ doSignedRequest 0 creds ext payload ck http req + case r of + Right res -> return res + Left ts -> do + now <- liftIO getPOSIXTime + doSignedRequest (now - ts) creds ext payload ck http req + + +makeExpiryHandler :: MonadCatch m => Credentials -> Request + -> m a -> m (Either NominalDiffTime a) +makeExpiryHandler creds req = E.handle handler . fmap Right + where + handler e@(StatusCodeException s h _) = + case wasStale req creds h s of + Just ts -> return $ Left ts + Nothing -> throwM e + +-- | Signs a request, runs it, then authenticates the response. +doSignedRequest :: (MonadIO m, MonadThrow m) => + NominalDiffTime + -> Credentials -> Maybe ExtData -> Maybe PayloadInfo + -> ServerAuthorizationCheck + -> (Request -> m (Response body)) -> Request + -> m (Response body) +doSignedRequest skew creds ext payload ck http req = do + (arts, req') <- sign creds ext payload skew req + resp <- http req' + auth <- authResponse creds arts ck resp + case auth of + Left e -> throwM $ HawkServerAuthorizationException e + Right _ -> return resp + +-- | Authenticates the server's response if required. +authResponse :: MonadIO m => Credentials -> HeaderArtifacts + -> ServerAuthorizationCheck + -> Response body -> m (Either String (Maybe ServerAuthorizationHeader)) +authResponse creds arts ck resp = do + let body = Nothing -- Just $ getResponseBody r + case ck of + ServerAuthorizationRequired -> + liftIO $ authenticate resp creds arts body ck + ServerAuthorizationNotRequired -> return (Right Nothing) + +wasStale :: Request -> Credentials -> ResponseHeaders -> Status -> Maybe NominalDiffTime +wasStale req creds hdrs s + | secure req && statusCode s == 401 = hawkTs creds hdrs + | otherwise = Nothing + +-- | Gets the WWW-Authenticate header value and returns the server +-- timestamp, if the response contains an authenticated timestamp. +hawkTs :: Credentials -> ResponseHeaders -> Maybe POSIXTime +hawkTs creds = join . join . fmap parseTs . wwwAuthenticate + where + wwwAuthenticate = lookup hWWWAuthenticate + parseTs = rightJust . checkWwwAuthenticateHeader creds diff --git a/src/Network/Hawk/Internal/Client/HeaderParser.hs b/src/Network/Hawk/Internal/Client/HeaderParser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal/Client/HeaderParser.hs @@ -0,0 +1,41 @@ +-- | Internal module. + +module Network.Hawk.Internal.Client.HeaderParser + ( parseWwwAuthenticateHeader + , parseServerAuthorizationHeader + , WwwAuthenticateHeader(..) + , ServerAuthorizationHeader(..) + ) where + +import Data.ByteString (ByteString) +import Data.Time.Clock.POSIX (POSIXTime) +import Network.Hawk.Types +import Control.Monad (join) + +import Network.Hawk.Util + +parseWwwAuthenticateHeader :: ByteString -> Either String WwwAuthenticateHeader +parseWwwAuthenticateHeader = fmap snd . parseHeader wwwKeys wwwAuthHeader + +parseServerAuthorizationHeader :: ByteString -> Either String ServerAuthorizationHeader +parseServerAuthorizationHeader = fmap snd . parseHeader serverKeys serverAuthReplyHeader + +wwwKeys = ["error", "tsm", "ts"] +serverKeys = ["mac", "ext", "hash"] + +wwwAuthHeader :: AuthAttrs -> Either String WwwAuthenticateHeader +wwwAuthHeader m = do + err <- authAttr m "error" + case authAttrMaybe m "ts" of + Just ts' -> do + ts <- readTs ts' + tsm <- authAttr m "tsm" + return $ WwwAuthenticateHeader err (Just ts) (Just tsm) + Nothing -> return $ WwwAuthenticateHeader err Nothing Nothing + +serverAuthReplyHeader :: AuthAttrs -> Either String ServerAuthorizationHeader +serverAuthReplyHeader m = do + mac <- authAttr m "mac" + let hash = authAttrMaybe m "hash" + let ext = authAttrMaybe m "ext" + return $ ServerAuthorizationHeader mac hash ext diff --git a/src/Network/Hawk/Internal/Client/Types.hs b/src/Network/Hawk/Internal/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal/Client/Types.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | Consider this module to be internal, and don't import directly. + +module Network.Hawk.Internal.Client.Types where + +import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Time.Clock.POSIX (POSIXTime) +import GHC.Generics +import Network.HTTP.Types.Method (Method) + +import Network.Hawk.Internal (Authorization) +import Network.Hawk.Types + +-- | ID and key used for encrypting Hawk @Authorization@ header. +data Credentials = Credentials + { ccId :: ClientId + , ccKey :: Key + , ccAlgorithm :: HawkAlgo + } deriving (Show, Generic) + +-- | The result of Hawk header generation. +data Header = Header + { hdrField :: Authorization -- ^ Value of @Authorization@ header. + , hdrArtifacts :: HeaderArtifacts -- ^ The parameters used to generate the header. + } deriving (Show, Generic) + +data Scheme = HTTP | HTTPS deriving (Show, Eq) + +data SplitURL = SplitURL + { urlScheme :: Scheme -- ^ If URL uses the @https@ scheme. + , urlHost :: ByteString -- ^ Hostname or IP. + , urlPort :: Maybe Int -- ^ Port, if given in URL. + , urlPath :: ByteString -- ^ Everything after the hostname and port. + } deriving (Show, Generic) + +defaultPort :: Scheme -> Int +defaultPort HTTP = 80 +defaultPort HTTPS = 443 + +urlPort' :: SplitURL -> Int +urlPort' (SplitURL s _ Nothing _) = defaultPort s +urlPort' (SplitURL _ _ (Just p) _) = p diff --git a/src/Network/Hawk/Internal/JSON.hs b/src/Network/Hawk/Internal/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal/JSON.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE RecordWildCards #-} +module Network.Hawk.Internal.JSON where + +import qualified Data.ByteString.Char8 as S8 +import Data.Aeson +import Data.Aeson.Types (typeMismatch) +import Network.Hawk.Internal.Types (MessageAuth(..)) + +instance ToJSON MessageAuth where + toJSON MessageAuth{..} = object + [ "id" .= msgId + , "ts" .= msgTimestamp + , "nonce" .= S8.unpack msgNonce + , "hash" .= S8.unpack msgHash + , "mac" .= S8.unpack msgMac + ] + +instance FromJSON MessageAuth where + parseJSON (Object v) = MessageAuth + <$> v .: "id" + <*> v .: "ts" + <*> v .:* "nonce" + <*> v .:* "hash" + <*> v .:* "mac" + where v .:* k = S8.pack <$> (v .: k) + parseJSON invalid = typeMismatch "MessageAuth" invalid diff --git a/src/Network/Hawk/Internal/Server.hs b/src/Network/Hawk/Internal/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal/Server.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.Hawk.Internal.Server where + +import Data.ByteString (ByteString) + +import Network.Hawk.Types +import Network.Hawk.Internal.Server.Types +import Network.Hawk.Internal + +serverMac :: Credentials -> HawkType -> HeaderArtifacts -> ByteString +serverMac Credentials{..} = calculateMac scAlgorithm scKey diff --git a/src/Network/Hawk/Internal/Server/Header.hs b/src/Network/Hawk/Internal/Server/Header.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal/Server/Header.hs @@ -0,0 +1,58 @@ +module Network.Hawk.Internal.Server.Header + ( header + , headerSuccess + , headerFail + , timestampMessage + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 +import Data.Time.Clock.POSIX +import Data.Maybe (catMaybes) + +import Network.HTTP.Types.Status (Status, ok200, badRequest400, unauthorized401) +import Network.HTTP.Types.Header (Header, hWWWAuthenticate) + +import Network.Hawk.Internal.Types +import Network.Hawk.Internal.Server +import Network.Hawk.Internal.Server.Types +import Network.Hawk.Internal + +-- | Generates a suitable @Server-Authorization@ header to send back +-- to the client. Credentials and artifacts would be provided by a +-- previous call to 'authenticateRequest' (or 'authenticate'). +-- +-- If a payload is supplied, its hash will be included in the header. +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 + , fmap ((,) "ext") ext] + hash = calculatePayloadHash (scAlgorithm creds) <$> payload + ext = escapeHeaderAttribute <$> haExt arts + mac = serverMac creds HawkResponse (arts { haHash = hash }) + +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) + ] diff --git a/src/Network/Hawk/Internal/Server/Types.hs b/src/Network/Hawk/Internal/Server/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal/Server/Types.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Consider this module to be internal, and don't import directly. + +module Network.Hawk.Internal.Server.Types where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time.Clock.POSIX (POSIXTime) +import Network.HTTP.Types.Method (Method) +import GHC.Generics +import Data.Default +import Network.Hawk.Types + +-- | The end result of authentication. +type AuthResult t = AuthResult' (AuthSuccess t) +-- | An intermediate result of authentication. +type AuthResult' r = Either AuthFail r + +-- | Authentication can fail in multiple ways. This type includes the +-- information necessary to generate a suitable response for the +-- client. In the case of a stale timestamp, the client may try +-- another authenticated request. +data AuthFail = AuthFailBadRequest String (Maybe HeaderArtifacts) + | AuthFailUnauthorized String (Maybe Credentials) (Maybe HeaderArtifacts) + | 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 +-- 'CredentialsFunc'. +data AuthSuccess t = AuthSuccess Credentials HeaderArtifacts t + +instance Show t => Show (AuthSuccess t) where + show (AuthSuccess c a t) = "AuthSuccess " ++ show t + +instance Eq t => Eq (AuthSuccess t) where + AuthSuccess c a t == AuthSuccess d b u = c == d && a == b && t == u + +-- | The result of an 'AuthSuccess'. +authValue :: AuthSuccess t -> t +authValue (AuthSuccess _ _ t) = t + +-- | The error message from an 'AuthFail'. +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 +-- which are relevant to Hawk authentication. +data HawkReq = HawkReq + { hrqMethod :: Method + , hrqUrl :: ByteString + , hrqHost :: ByteString + , hrqPort :: Maybe Int + , hrqAuthorization :: ByteString + , hrqPayload :: Maybe PayloadInfo + , hrqBewit :: Maybe ByteString + , hrqBewitlessUrl :: ByteString + } deriving Show + +instance Default HawkReq where + def = HawkReq "GET" "/" "localhost" Nothing "" Nothing Nothing "" + +-- | The set of data the server requires for key-based hash +-- verification of artifacts. +data Credentials = Credentials + { scKey :: Key -- ^ Key + , scAlgorithm :: HawkAlgo -- ^ HMAC + } deriving (Show, Eq, Generic) + +-- | A user-supplied callback to get credentials from a client +-- identifier. +type CredentialsFunc m t = ClientId -> m (Either String (Credentials, t)) + +-- | User-supplied nonce validation function. It should return 'True' +-- if the nonce is valid. +-- +-- Checking nonces can prevent request replay attacks. If the same key +-- and nonce have already been seen, then the request can be denied. +type NonceFunc = Key -> POSIXTime -> Nonce -> IO Bool + +-- | The nonce should be a short sequence of random ASCII characters. +type Nonce = ByteString diff --git a/src/Network/Hawk/Internal/Types.hs b/src/Network/Hawk/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Internal/Types.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Network.Hawk.Internal.Types where + +import Control.Applicative +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import Data.Time.Clock.POSIX (POSIXTime) +import Network.HTTP.Types.Method (Method) + +import Network.Hawk.Algo + +-- | Identifies a particular client so that their credentials can be +-- looked up. +type ClientId = Text + +-- | Extension data included in verification hash. This can be +-- anything or nothing, depending on what the application needs. +type ExtData = ByteString + +-- | Struct for attributes which will be encoded in the Hawk +-- @Authorization@ header and included in the verification. The +-- terminology (and spelling) come from the original Javascript +-- implementation of Hawk. +data HeaderArtifacts = HeaderArtifacts + { haMethod :: Method -- ^ Signed request method. + -- fixme: replace host/port/resource with SplitURL + , haHost :: ByteString -- ^ Request host. + , haPort :: Maybe Int -- ^ Request port. + , haResource :: ByteString -- ^ Request path and query params. + , haId :: ClientId -- ^ Client identifier. + , haTimestamp :: POSIXTime -- ^ Time of request. + , haNonce :: ByteString -- ^ Nonce value. + , haMac :: ByteString -- ^ Entire header hash. + , haHash :: Maybe ByteString -- ^ Payload hash. + , haExt :: Maybe ExtData -- ^ Optional application-specific data. + , haApp :: Maybe Text -- ^ Oz application, Iron-encoded. + , haDlg :: Maybe Text -- ^ Oz delegated-by application. + } deriving (Show, Eq) + +---------------------------------------------------------------------------- + +-- | Value of @Content-Type@ HTTP headers. +type ContentType = ByteString -- fixme: CI ByteString + +-- | Payload data and content type bundled up for convenience. +data PayloadInfo = PayloadInfo + { payloadContentType :: ContentType + , payloadData :: BL.ByteString + } deriving Show + +---------------------------------------------------------------------------- + +-- | Authorization attributes for a Hawk message. This is generated by +-- 'Network.Hawk.Client.message' and verified by +-- 'Network.Hawk.Server.authenticateMessage'. +data MessageAuth = MessageAuth + { msgId :: ClientId -- ^ User identifier. + , msgTimestamp :: POSIXTime -- ^ Message time. + , msgNonce :: ByteString -- ^ Nonce string. + , msgHash :: ByteString -- ^ Message hash. + , msgMac :: ByteString -- ^ Hash of all message parameters. + } deriving (Show, Eq) + +---------------------------------------------------------------------------- + +-- | Represents the @WWW-Authenticate@ header which the server uses to +-- respond when the client isn't authenticated. +data WwwAuthenticateHeader = WwwAuthenticateHeader + { wahError :: ByteString -- ^ Error message + , wahTs :: Maybe POSIXTime -- ^ Server's timestamp + , wahTsm :: Maybe ByteString -- ^ Timestamp mac + } deriving (Show, Eq) + +-- | Represents the @Server-Authorization@ header which the server +-- sends back to the client. +data ServerAuthorizationHeader = ServerAuthorizationHeader + { sahMac :: ByteString -- ^ Hash of all response parameters. + , sahHash :: Maybe ByteString -- ^ Optional payload hash. + , sahExt :: Maybe ExtData -- ^ Optional application-specific data. + } deriving (Show, Eq) 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,7 +22,7 @@ import qualified Data.Vault.Lazy as V import qualified Network.Hawk.Server as Hawk -import qualified Network.Hawk.Server.Types as Hawk +import qualified Network.Hawk.Types as Hawk -- | Whether the middleware should verify the payload hash by reading -- the entire request body. 'Network.Hawk.Server.authenticatePayload' @@ -43,7 +43,7 @@ -- | Authenticates @GET@ requests with the Hawk bewit scheme, -- according to the provided options and credentials. bewitAuth :: Hawk.AuthReqOpts -> Hawk.CredentialsFunc IO t -> Middleware -bewitAuth opts creds = genHawkAuth $ Hawk.authenticateBewit opts creds +bewitAuth opts creds = genHawkAuth $ Hawk.authenticateBewitRequest opts creds genHawkAuth :: (Request -> IO (Hawk.AuthResult t)) -> Application -> Application genHawkAuth auth app req respond = do 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 @@ -2,18 +2,38 @@ -- | These are functions for checking authenticated requests and -- sending authenticated responses. +-- +-- For an easy way to add Hawk authentication to a "Network.Wai" +-- 'Network.Wai.Application', use the "Network.Hawk.Middleware" +-- module. module Network.Hawk.Server - ( authenticateRequest + ( -- * Authenticating "Network.Wai" requests + authenticateRequest + , authenticatePayload + , authenticateBewitRequest + , AuthReqOpts(..) + -- ** Generic variants , authenticate , authenticateBewit - , authenticatePayload + , authenticateMessage , HawkReq(..) - , header - , AuthReqOpts(..) + -- ** Options for authentication , AuthOpts(..) + , Credentials(..) + , CredentialsFunc + , NonceFunc + , Nonce , def - , module Network.Hawk.Server.Types + -- ** Authentication result + , AuthResult + , AuthResult'(..) + , AuthSuccess(..) + , AuthFail(..) + , authValue + , authFailMessage + -- * Authenticated reponses + , header ) where import Control.Applicative ((<|>)) @@ -25,7 +45,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Byteable (constEqBytes) import Data.CaseInsensitive (CI (..)) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -34,18 +54,19 @@ import Data.Default (Default(..)) import Data.Time.Clock (NominalDiffTime) import Data.Time.Clock.POSIX -import Network.HTTP.Types.Header (Header, hAuthorization, - hContentType, hWWWAuthenticate) +import Network.HTTP.Types.Header (Header, hAuthorization, hContentType) 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, remoteHost, requestMethod, requestHeaderHost, requestHeaders) -import Network.Hawk.Common -import Network.Hawk.Server.Types +import Network.Hawk.Internal.Types +import Network.Hawk.Internal +import Network.Hawk.Internal.Server +import Network.Hawk.Internal.Server.Types +import Network.Hawk.Internal.Server.Header import Network.Hawk.Util import Network.Iron.Util (b64urldec, justRight, mapLeft) @@ -58,22 +79,29 @@ { saHostHeaderName :: Maybe (CI ByteString) -- ^ Alternate name for @Host@ header , saHost :: Maybe ByteString -- ^ Overrides the URL host , saPort :: Maybe ByteString -- ^ Overrides the URL port - , saBewitParam :: ByteString -- ^ Query parameter for bewit authentication + , saBewitParam :: ByteString + -- ^ Query parameter for bewit authentication. Defaults to @"bewit"@. , saOpts :: AuthOpts -- ^ Parameters for 'authenticate' } -- | Bundle of parameters for 'authenticate'. data AuthOpts = AuthOpts { saCheckNonce :: NonceFunc + -- ^ Nonce validation function. Defaults to a function which + -- always returns @True@. , saTimestampSkew :: NominalDiffTime - , saIronLocaltimeOffset :: NominalDiffTime -- fixme: check this is still needed + -- ^ Number of seconds of permitted clock skew for incoming + -- timestamps. Defaults to 60 seconds. Provides a +/- skew which + -- means actual allowed window is double the number of seconds. + , saLocaltimeOffset :: NominalDiffTime + -- ^ Offsets the local time. Defaults to 0. } instance Default AuthReqOpts where def = AuthReqOpts Nothing Nothing Nothing "bewit" def instance Default AuthOpts where - def = AuthOpts (\x t n -> True) 60 0 + def = AuthOpts (\x t n -> return True) 60 0 -- | Checks the @Authorization@ header of a 'Network.Wai.Request' and -- (optionally) a payload. The header will be parsed and verified with @@ -90,45 +118,58 @@ then return $ Left (AuthFailBadRequest "Missing Authorization header" Nothing) else authenticate (saOpts opts) creds hreq -authenticateBewit' opts (creds, t) req bewit +authenticateBewit' (creds, t) req bewit | mac `constEqBytes` (bewitMac bewit) = Right (AuthSuccess creds arts t) | otherwise = Left (AuthFailUnauthorized "Bad mac" (Just creds) (Just arts)) where arts = bewitArtifacts req bewit - mac = serverMac creds arts HawkBewit + mac = serverMac creds HawkBewit arts bewitArtifacts :: HawkReq -> Bewit -> HeaderArtifacts bewitArtifacts HawkReq{..} Bewit{..} = HeaderArtifacts hrqMethod hrqHost hrqPort hrqBewitlessUrl "" bewitExp "" "" Nothing (Just bewitExt) Nothing Nothing --- | Checks the @Authorization@ header of a request according to the --- "bewit" scheme. See "Network.Hawk.URI" for a description of that --- scheme. -authenticateBewit :: MonadIO m => AuthReqOpts -> CredentialsFunc m t - -> Request -> m (AuthResult t) -authenticateBewit opts getCreds req = do - now <- liftIO getPOSIXTime +-- | Checks the @Authorization@ header of a 'Wai.Request' according to +-- the "bewit" scheme. See "Network.Hawk.URI" for a description of +-- that scheme. +authenticateBewitRequest :: MonadIO m => AuthReqOpts -> CredentialsFunc m t + -> Request -> m (AuthResult t) +authenticateBewitRequest opts creds req = + authenticateBewit (saOpts opts) creds (hawkReq opts req Nothing) + +-- | Checks the @Authorization@ header of a request ('HawkReq') +-- according to the "bewit" scheme. +authenticateBewit :: MonadIO m => AuthOpts -> CredentialsFunc m t + -> HawkReq -> m (AuthResult t) +authenticateBewit opts getCreds hrq@HawkReq{..} = do + now <- getServerTime opts case checkBewit hrq now of Right bewit -> do mcreds <- mapLeft unauthorized <$> getCreds (bewitId bewit) return $ case mcreds of - Right creds -> authenticateBewit' opts creds hrq bewit + Right creds -> authenticateBewit' creds hrq bewit Left e -> undefined Left e -> return (Left e) where - hrq = hawkReq opts req Nothing checkBewit :: HawkReq -> POSIXTime -> Either AuthFail Bewit checkBewit HawkReq{..} now = do - encBewit <- checkEmpty hrqBewit checkMethod hrqMethod + checkLength hrqUrl + encBewit <- checkEmpty hrqBewit checkHeader hrqAuthorization bewit <- mapLeft unauthorized $ decodeBewit encBewit checkAttrs bewit checkExpiry bewit now return bewit + -- javascript impl limits query string length to avoid a DoS + -- attack on string matching + checkLength url | BS.length url <= urlMaxLength = Right () + | otherwise = Left (badRequest "Resource path exceeds max length") + urlMaxLength = 4096 + -- need a bewit in the query string checkEmpty (Just "") = Left (unauthorized "Empty bewit") checkEmpty Nothing = Left (unauthorized "") @@ -148,6 +189,9 @@ unauthorized e = AuthFailUnauthorized e Nothing Nothing badRequest e = AuthFailBadRequest e Nothing +-- | Current time, with the server time offset applied. +getServerTime :: MonadIO m => AuthOpts -> m POSIXTime +getServerTime AuthOpts{..} = (+ saLocaltimeOffset) <$> liftIO getPOSIXTime hawkReq :: AuthReqOpts -> Request -> Maybe BL.ByteString -> HawkReq hawkReq AuthReqOpts{..} req body = HawkReq @@ -181,25 +225,78 @@ -- not supplied, it can be verified later with 'authenticatePayload'. authenticate :: MonadIO m => AuthOpts -> CredentialsFunc m t -> HawkReq -> m (AuthResult t) authenticate opts getCreds req@HawkReq{..} = do - now <- liftIO getPOSIXTime case parseServerAuthorizationHeader hrqAuthorization of - Right sah@AuthorizationHeader{..} -> do - creds <- getCreds sahId - return $ case creds of - Right creds' -> authenticate' now opts creds' req sah - Left e -> Left (AuthFailUnauthorized e Nothing (Just (headerArtifacts req sah))) + Right sah -> let arts = headerArtifacts req sah + in authenticateBase HawkHeader opts getCreds arts hrqPayload sah Left err -> return $ Left err -authenticate' :: POSIXTime -> AuthOpts -> (Credentials, t) - -> HawkReq -> AuthorizationHeader -> AuthResult t -authenticate' now opts (creds, t) hrq@HawkReq{..} sah@AuthorizationHeader{..} = do - let arts = headerArtifacts hrq sah - doCheck = authResult creds arts t +-- | Verifies message signature with the given credentials and +-- authorization attributes. +authenticateMessage :: MonadIO m + => AuthOpts -- ^ Options for verification. + -> CredentialsFunc m t -- ^ Credentials lookup function. + -> ByteString -- ^ Destination host. + -> Maybe Int -- ^ Destination port. + -> BL.ByteString -- ^ The message. + -> MessageAuth -- ^ Signed message object. + -> m (AuthResult t) +authenticateMessage opts getCreds host port msg auth = + authenticateBase HawkMessage opts getCreds arts payload sah + where + arts = msgArts host port auth + payload = Just (PayloadInfo "" msg) + sah = msgAuth auth + +msgAuth :: MessageAuth -> AuthorizationHeader +msgAuth MessageAuth{..} = AuthorizationHeader + { sahId = msgId + , sahTs = msgTimestamp + , sahNonce = msgNonce + , sahMac = msgMac + , sahHash = Just msgHash + , sahExt = Nothing + , sahApp = Nothing + , sahDlg = Nothing + } + +msgArts :: ByteString -> Maybe Int -> MessageAuth -> HeaderArtifacts +msgArts host port MessageAuth{..} = HeaderArtifacts + { haMethod = "" + , haHost = host + , haPort = port + , haResource = "" + , haId = "" + , haTimestamp = msgTimestamp + , haNonce = msgNonce + , haMac = "" + , haHash = Just msgHash + , haExt = Nothing + , haApp = Nothing + , haDlg = Nothing + } + +authenticateBase :: MonadIO m => HawkType -> AuthOpts -> CredentialsFunc m t + -> HeaderArtifacts -> Maybe PayloadInfo + -> AuthorizationHeader -> m (AuthResult t) +authenticateBase ty opts getCreds arts payload sah@AuthorizationHeader{..} = do + now <- getServerTime opts + creds <- getCreds sahId + case creds of + Right creds' -> do + nonce <- liftIO $ saCheckNonce opts (scKey (fst creds')) sahTs sahNonce + return $ authenticate' ty now opts creds' nonce arts payload sah + Left e -> return $ Left (AuthFailUnauthorized e Nothing (Just arts)) + +authenticate' :: HawkType -> POSIXTime -> AuthOpts -> (Credentials, t) -> Bool + -> HeaderArtifacts -> Maybe PayloadInfo -> AuthorizationHeader + -> AuthResult t +authenticate' ty now opts (creds, t) nonce arts payload sah@AuthorizationHeader{..} = do + let doCheck = authResult creds arts t doCheckExp = authResultExp now creds arts t - mac = serverMac creds arts HawkHeader + mac = serverMac creds ty arts if mac `constEqBytes` sahMac then do - doCheck $ checkPayloadHash (scAlgorithm creds) sahHash hrqPayload - doCheck $ checkNonce (saCheckNonce opts) (scKey creds) sahNonce sahTs + doCheck $ checkPayloadHash (scAlgorithm creds) sahHash payload + doCheck $ checkNonce nonce doCheckExp $ checkExpiration now (saTimestampSkew opts) sahTs doCheck $ Right () else Left (AuthFailUnauthorized "Bad mac" (Just creds) (Just arts)) @@ -220,67 +317,19 @@ headerArtifacts :: HawkReq -> AuthorizationHeader -> HeaderArtifacts headerArtifacts HawkReq{..} AuthorizationHeader{..} = HeaderArtifacts hrqMethod hrqHost hrqPort hrqUrl - sahId sahTs sahNonce sahMac sahHash sahExt (fmap decodeUtf8 sahApp) sahDlg + sahId sahTs sahNonce sahMac sahHash sahExt sahApp sahDlg -- | Verifies the payload hash as a separate step after other things -- have been check. This is useful when the request body is streamed -- for example. authenticatePayload :: AuthSuccess t -> PayloadInfo -> Either String () authenticatePayload (AuthSuccess c a _) p = - checkPayloadHash (scAlgorithm c) (shaHash a) (Just p) + checkPayloadHash (scAlgorithm c) (haHash a) (Just p) --- | Generates a suitable @Server-Authorization@ header to send back --- to the client. Credentials and artifacts would be provided by a --- previous call to 'authenticateRequest' (or 'authenticate'). --- --- If a payload is supplied, its hash will be included in the header. -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 - , fmap ((,) "ext") ext] - hash = calculatePayloadHash (scAlgorithm creds) <$> payload - ext = escapeHeaderAttribute <$> (shaExt arts) - mac = serverMac creds arts HawkResponse - -serverMac :: Credentials -> HeaderArtifacts -> HawkType -> ByteString -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 -type Nonce = ByteString - -checkNonce :: NonceFunc -> Key -> Nonce -> POSIXTime -> Either String () -checkNonce nonceFunc key nonce ts = if nonceFunc key ts nonce then Right () - else Left "Invalid nonce" +checkNonce :: Bool -> Either String () +checkNonce True = Right () +checkNonce False = Left "Invalid nonce" checkExpiration :: POSIXTime -> NominalDiffTime -> POSIXTime -> Either String () checkExpiration now skew ts = if abs (ts - now) <= skew then Right () @@ -297,9 +346,9 @@ , sahNonce :: ByteString , sahMac :: ByteString , sahHash :: Maybe ByteString -- ^ optional payload hash - , sahExt :: Maybe ByteString -- ^ optional extra data to verify - , sahApp :: Maybe ByteString -- ^ optional oz application id - , sahDlg :: Maybe ByteString -- ^ optional oz delegate + , sahExt :: Maybe ExtData -- ^ optional extra data to verify + , sahApp :: Maybe Text -- ^ optional oz application id + , sahDlg :: Maybe Text -- ^ optional oz delegate } deriving Show parseServerAuthorizationHeader :: ByteString -> AuthResult' AuthorizationHeader @@ -324,7 +373,8 @@ mac <- authAttr m "mac" return $ AuthorizationHeader id ts nonce mac (authAttrMaybe m "hash") (authAttrMaybe m "ext") - (authAttrMaybe m "app") (authAttrMaybe m "dlg") + (decodeUtf8 <$> authAttrMaybe m "app") + (decodeUtf8 <$> authAttrMaybe m "dlg") ---------------------------------------------------------------------------- -- Bewit parsing diff --git a/src/Network/Hawk/Server/Nonce.hs b/src/Network/Hawk/Server/Nonce.hs new file mode 100644 --- /dev/null +++ b/src/Network/Hawk/Server/Nonce.hs @@ -0,0 +1,60 @@ +-- | /Nonces/ prevent replaying of requests. This module provides a +-- nonce validation function which stores previous requests while they +-- are fresh. + +module Network.Hawk.Server.Nonce + ( nonceOpts + , nonceOptsReq + ) where + +import Data.IORef +import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence as Q +import Data.HashSet (HashSet) +import qualified Data.HashSet as S +import Data.Time.Clock.POSIX +import Data.Time.Clock (NominalDiffTime) +import Data.Hashable (Hashable) +import Data.Foldable (toList) + +import Network.Hawk.Types (Key) +import Network.Hawk.Server (AuthOpts(..), AuthReqOpts(..), def, Nonce, NonceFunc) + +-- | Creates an 'Hawk.AuthOpts' with a nonce validation function which +-- remembers previous nonces for as long as they are valid. The @skew@ +-- parameter determines how long a signed request is valid for. +nonceOpts :: NominalDiffTime -> IO AuthOpts +nonceOpts skew = do + ref <- newIORef (Q.empty, S.empty) + let nf = makeNonceFunc skew ref + return $ AuthOpts nf skew 0 + +-- | Creates an 'Hawk.AuthReqOpts' with a nonce validation function +-- which remembers previous nonces for as long as they are valid. The +-- @skew@ parameter determines how long a signed request is valid for. +nonceOptsReq :: NominalDiffTime -> IO AuthReqOpts +nonceOptsReq skew = do + opts <- nonceOpts skew + return $ def { saOpts = opts } + +instance Hashable Key + +-- Maintain both a queue and set. Queue provides fast expiry of stale +-- nonces and the hash set provides a fast test for nonce existence. +type Store = (Seq (Key, Nonce, POSIXTime), HashSet (Key, Nonce)) + +makeNonceFunc :: NominalDiffTime -> IORef Store -> NonceFunc +makeNonceFunc skew ref = \k t n -> do + now <- getPOSIXTime + atomicModifyIORef' ref (update now (abs skew) k n t) + +update :: POSIXTime -> NominalDiffTime -> Key -> Nonce -> POSIXTime -> Store -> (Store, Bool) +update now skew k n t (q, s) = ((q'', s''), fresh) + where + fresh = (not $ S.member (k, n) s) && t + skew >= now - skew + q' | fresh = q |> (k, n, now + skew) + | otherwise = q + s' | fresh = S.insert (k, n) s + | otherwise = s + (dead, q'') = Q.breakl (\(_, _, t) -> t >= now) q' + s'' = S.difference s' (S.fromList [(k, n) | (k, n, t) <- toList dead]) diff --git a/src/Network/Hawk/Server/Types.hs b/src/Network/Hawk/Server/Types.hs deleted file mode 100644 --- a/src/Network/Hawk/Server/Types.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Network.Hawk.Server.Types - ( AuthResult - , AuthResult'(..) - , AuthFail(..) - , authFailMessage - , AuthSuccess(..) - , Credentials(..) - , HeaderArtifacts(..) - , CredentialsFunc - , HawkReq(..) - , module Network.Hawk.Types - ) where - -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Time.Clock.POSIX (POSIXTime) -import Network.HTTP.Types.Method (Method) -import GHC.Generics -import Data.Default -import Network.Hawk.Types - --- | The end result of authentication. -type AuthResult t = AuthResult' (AuthSuccess t) --- | An intermediate result of authentication. -type AuthResult' r = Either AuthFail r - --- | Authentication can fail in multiple ways. This type includes the --- information necessary to generate a suitable response for the --- client. In the case of a stale timestamp, the client may try --- another authenticated request. -data AuthFail = AuthFailBadRequest String (Maybe HeaderArtifacts) - | AuthFailUnauthorized String (Maybe Credentials) (Maybe HeaderArtifacts) - | 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 --- 'CredentialsFunc'. -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 --- which are relevant to Hawk authentication. -data HawkReq = HawkReq - { hrqMethod :: Method - , hrqUrl :: ByteString - , hrqHost :: ByteString - , hrqPort :: Maybe Int - , hrqAuthorization :: ByteString - , hrqPayload :: Maybe PayloadInfo - , hrqBewit :: Maybe ByteString - , hrqBewitlessUrl :: ByteString - } deriving Show - -instance Default HawkReq where - def = HawkReq "GET" "/" "localhost" Nothing "" Nothing Nothing "" - --- | The set of data the server requires for key-based hash --- verification of artifacts. -data Credentials = Credentials - { scKey :: Key -- ^ Key - , scAlgorithm :: HawkAlgo -- ^ HMAC - } deriving (Show, Eq, Generic) - --- | HeaderArtifacts are the attributes which are included in the --- verification. The terminology (and spelling) come from the original --- Javascript implementation of Hawk. -data HeaderArtifacts = HeaderArtifacts - { shaMethod :: Method - , shaHost :: ByteString - , shaPort :: Maybe Int - , shaResource :: ByteString - , shaId :: ClientId - , shaTimestamp :: POSIXTime - , shaNonce :: ByteString - , shaMac :: ByteString -- ^ Entire header hash - , shaHash :: Maybe ByteString -- ^ Payload hash - , shaExt :: Maybe ByteString - , shaApp :: Maybe Text - , shaDlg :: Maybe ByteString - } deriving (Show, Eq) - --- | A user-supplied callback to get credentials from a client --- identifier. -type CredentialsFunc m t = ClientId -> m (Either String (Credentials, t)) diff --git a/src/Network/Hawk/Types.hs b/src/Network/Hawk/Types.hs --- a/src/Network/Hawk/Types.hs +++ b/src/Network/Hawk/Types.hs @@ -1,31 +1,22 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Network.Hawk.Types - ( ClientId - , Key(..) - , ContentType + ( -- ** Artifacts + HeaderArtifacts + , haHash, haExt, haApp, haDlg + , ExtData , PayloadInfo(..) + , ContentType + -- ** Credentials + , ClientId + , Key(..) , module Network.Hawk.Algo + -- ** Headers + , WwwAuthenticateHeader(..) + , ServerAuthorizationHeader(..) + , MessageAuth(..) ) where -import Control.Applicative -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BL -import Data.Text (Text) - -import Network.Hawk.Algo - --- | Identifies a particular client so that their credentials can be --- looked up. -type ClientId = Text - ----------------------------------------------------------------------------- - --- | Value of @Content-Type@ HTTP headers. -type ContentType = ByteString -- fixme: CI ByteString - --- | Payload data and content type bundled up for convenience. -data PayloadInfo = PayloadInfo - { payloadContentType :: ContentType - , payloadData :: BL.ByteString - } deriving Show +import Network.Hawk.Algo +import Network.Hawk.Internal.Types +import Network.Hawk.Internal.JSON diff --git a/src/Network/Hawk/URI.hs b/src/Network/Hawk/URI.hs --- a/src/Network/Hawk/URI.hs +++ b/src/Network/Hawk/URI.hs @@ -33,13 +33,18 @@ import Network.Wai (Request) import Network.Hawk.Types -import Network.Hawk.Server (authenticateBewit, CredentialsFunc, AuthReqOpts, AuthResult) +import Network.Hawk.Server (authenticateBewitRequest, authenticateBewit, CredentialsFunc, AuthReqOpts, AuthOpts, AuthResult, HawkReq) import Network.Hawk.Middleware (bewitAuth) import Network.Hawk.Client (getBewit) --- | See 'Network.Hawk.Server.authenticateBewit'. -authenticate :: MonadIO m => AuthReqOpts -> CredentialsFunc m t +-- | See 'Network.Hawk.Server.authenticateBewitRequest'. +authenticateRequest :: MonadIO m => AuthReqOpts -> CredentialsFunc m t -> Request -> m (AuthResult t) +authenticateRequest = authenticateBewitRequest + +-- | See 'Network.Hawk.Server.authenticateBewit'. +authenticate :: MonadIO m => AuthOpts -> CredentialsFunc m t + -> HawkReq -> m (AuthResult t) authenticate = authenticateBewit -- | See 'Network.Hawk.Middleware.bewitAuth'. diff --git a/src/Network/Hawk/Util.hs b/src/Network/Hawk/Util.hs --- a/src/Network/Hawk/Util.hs +++ b/src/Network/Hawk/Util.hs @@ -9,7 +9,8 @@ , readTsMaybe ) where -import Control.Applicative ((<|>)) +import Control.Applicative (liftA, (<|>)) +import Control.Monad (when, unless) import Data.Attoparsec.ByteString.Char8 import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 @@ -21,7 +22,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock.POSIX -import Network.Hawk.Common +import Network.Hawk.Internal import Network.Hawk.Types parseHeader :: [ByteString] -> (AuthAttrs -> Either String hdr) -> ByteString -> Either String (AuthScheme, hdr) @@ -62,9 +63,13 @@ parseKeys :: [ByteString] -> Parser ByteString parseKeys = choice . map string +-- fixme: js impl only accepts limited chars +-- notInClass "-!#$%&'()*+,./:;<=>?@[]^_`{|}~ a-zA-Z0-9" +-- => "Bad attribute value: attr" +-- inClass "\\" => "Bad header format" val :: Parser ByteString -val = q *> takeTill ((==) '"') <* q - where q = char8 '"' +val = q *> takeTill (inClass "\"\\") <* q + where q = char8 '"' readTs :: ByteString -> Either String POSIXTime readTs = toEither "Invalid timestamp" . readTsMaybe diff --git a/src/Network/Iron.hs b/src/Network/Iron.hs --- a/src/Network/Iron.hs +++ b/src/Network/Iron.hs @@ -64,6 +64,7 @@ , SHA256(SHA256) , IronSalt(..) , urlSafeBase64 + , def ) where import Control.Monad (liftM, when) @@ -115,7 +116,7 @@ } deriving Show -- | Encryption algorithms supported by Iron. -data IronCipher = AES128CTR | AES256CBC deriving Show +data IronCipher = AES128CTR | AES256CBC deriving (Show, Read, Eq, Enum) class IsIronCipher a where ivSize :: a -> Int diff --git a/src/Network/Iron/Util.hs b/src/Network/Iron/Util.hs --- a/src/Network/Iron/Util.hs +++ b/src/Network/Iron/Util.hs @@ -77,6 +77,10 @@ justRight e Nothing = Left e -- | Modifies the left branch of an 'Either'. -mapLeft :: (e -> e') -> Either e a -> Either e' a -mapLeft f (Left e) = Left (f e) -mapLeft _ (Right a) = Right a +mapLeft :: (a -> a') -> Either a b -> Either a' b +mapLeft f (Left a) = Left (f a) +mapLeft _ (Right b) = Right b + +-- | Modifies both branches of an 'Either'. +mapEither :: (a -> a') -> (b -> b') -> Either a b -> Either a' b' +mapEither f g = mapLeft f . fmap g 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 @@ -36,7 +36,8 @@ import Web.Scotty import Data.Time.Clock.POSIX (getPOSIXTime) -import Network.Hawk.Server (AuthSuccess (..), Key (..), HeaderArtifacts (..)) +import Network.Hawk.Types (Key (..), HeaderArtifacts (..)) +import Network.Hawk.Server (AuthSuccess (..)) import qualified Network.Hawk.Server as Hawk import qualified Network.Oz.Boom as Boom import Network.Oz.Internal.Types @@ -84,7 +85,7 @@ app :: ActionM (Either String OzSealedTicket) app = do (creds, arts) <- hawkAuthAction - appCfg <- loadAppAction (shaApp arts) + appCfg <- loadAppAction (haApp arts) Ticket.issue ozSecret appCfg Nothing ozTicketOpts -- fixme: flatten staircases ... use EitherT @@ -162,7 +163,7 @@ Left f -> hawkAuthFail f -- Scotty action to check the Authorization header - hawkAuthAction :: ActionM (Hawk.Credentials, Hawk.HeaderArtifacts) + hawkAuthAction :: ActionM (Hawk.Credentials, HeaderArtifacts) hawkAuthAction = do req <- request -- payload <- fmap Just body -- fixme: check if it's compatible with jsonData diff --git a/src/Network/Oz/Client.hs b/src/Network/Oz/Client.hs --- a/src/Network/Oz/Client.hs +++ b/src/Network/Oz/Client.hs @@ -40,7 +40,7 @@ -- authorization header for making authenticated Oz requests. header :: Text -> Method -> OzSealedTicket -> IO Hawk.Header -- fixme: support hawk header options -header uri method t@OzSealedTicket{..} = Hawk.header uri method creds Nothing Nothing +header uri method t@OzSealedTicket{..} = Hawk.header uri method creds Nothing 0 Nothing where creds = ticketCreds t -- fixme: app and dlg need to get passed to header diff --git a/src/Network/Oz/Server.hs b/src/Network/Oz/Server.hs --- a/src/Network/Oz/Server.hs +++ b/src/Network/Oz/Server.hs @@ -21,8 +21,7 @@ import Network.Hawk.Server (AuthFail (..), AuthResult, AuthResult' (..), AuthSuccess (..), - Credentials(..), - HeaderArtifacts(..)) + Credentials(..)) import qualified Network.Hawk.Server as Hawk import Network.Hawk.Types import qualified Network.Oz.Ticket as Ticket @@ -52,10 +51,10 @@ check :: AuthResult OzSealedTicket -> AuthResult OzSealedTicket check r = r >>= check' where - check' r@(AuthSuccess c a@HeaderArtifacts{..} t@OzSealedTicket{..}) - | ozTicketApp ozTicket /= fromMaybe "" shaApp = + check' r@(AuthSuccess c a t@OzSealedTicket{..}) + | ozTicketApp ozTicket /= fromMaybe "" (haApp a) = Left $ AuthFailUnauthorized "Mismatching application id" (Just c) (Just a) - | ozTicketDlg ozTicket /= fmap decodeUtf8 shaDlg && ozTicketDlg ozTicket /= Nothing = + | ozTicketDlg ozTicket /= haDlg a && ozTicketDlg ozTicket /= Nothing = Left $ AuthFailUnauthorized "Mismatching delegated application id" (Just c) (Just a) | otherwise = Right r diff --git a/src/Network/Oz/Ticket.hs b/src/Network/Oz/Ticket.hs --- a/src/Network/Oz/Ticket.hs +++ b/src/Network/Oz/Ticket.hs @@ -30,7 +30,8 @@ import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import Network.Hawk.Server.Types +import Network.Hawk.Server +import Network.Hawk.Types import qualified Network.Iron as Iron import Network.Oz.JSON import Network.Oz.Types 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 @@ -1,62 +1,152 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, TupleSections #-} module Network.Hawk.Tests (tests) where -import Data.Either (isRight) -import Data.Maybe (isJust) +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, (@?=), (@?)) +import Test.HUnit (Assertion, (@?=), (@?), assertFailure) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck +import Test.QuickCheck.Monadic import Network.Hawk -import Network.Hawk.Server.Types (HawkReq(..), AuthSuccess(..)) +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.Client.Types as Client (HeaderArtifacts(..)) -import qualified Network.Hawk.Server.Types as Server (HeaderArtifacts(..)) +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 "Server" + [ testGroup "Client+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 + , testWWWAuthenticate ] - , testGroup "header" [ testHeader01 ] + , 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 - sc = Right (Server.Credentials key algo, user) - key = "werxhqb98rpaxn39848xrunpaw3489ruxnpa98w4rxn" - algo = if i == "1" then HawkAlgo SHA1 else HawkAlgo SHA256 - user = "steve" +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 ext + 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" @@ -64,17 +154,17 @@ , hrqAuthorization = Client.hdrField hdr } r <- Server.authenticate def credsFunc hrq - isRight r @?= True + assertSuccess r let Right (Server.AuthSuccess creds' arts user) = r user @?= "steve" - Server.shaExt arts @?= Just "some-app-data" + 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) ext + 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)] @@ -83,7 +173,7 @@ 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" + Hawk.haExt arts @?= Just "some-app-data" Server.authenticatePayload s payload @?= Right () -- Client verifies server response @@ -91,32 +181,13 @@ (_, hdr2) = Server.header r (Just payload2) res = mockResponse payload2 [hdr2] creds2' = clientCreds "" creds2 - arts' = clientHeaderArtifacts arts + arts' = arts { haHash = Just $ calculatePayloadHash (Client.ccAlgorithm creds) payload2 } r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired - r2 @?= Right () + isRight r2 @?= True clientCreds :: ClientId -> Server.Credentials -> Client.Credentials clientCreds i (Server.Credentials k a) = Client.Credentials i k a --- fixme: there's possibly a case for merging these two types --- server artifacts have header mac and client id --- dlg is text/bytestring -clientHeaderArtifacts :: Server.HeaderArtifacts -> Client.HeaderArtifacts -clientHeaderArtifacts Server.HeaderArtifacts{..} = Client.HeaderArtifacts - { chaTimestamp = shaTimestamp - , chaNonce = shaNonce - , chaMethod = shaMethod - , chaHost = shaHost - , chaPort = shaPort - , chaResource = shaResource - , chaHash = shaHash - , chaExt = shaExt - , chaApp = shaApp - , chaDlg = decodeUtf8 <$> shaDlg - -- , shaId :: ClientId - -- , shaMac :: ByteString - } - mockRequest :: Method -> ByteString -> ByteString -> ByteString -> PayloadInfo -> RequestHeaders -> Request mockRequest method path qs host (PayloadInfo ct _) hdrs = defaultRequest { requestMethod = method @@ -140,7 +211,7 @@ 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 + 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 @@ -151,9 +222,9 @@ } 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" + 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" @@ -161,17 +232,17 @@ (_, hdr) = Server.header r (Just payload2) res = mockResponse payload2 [hdr] creds2' = clientCreds "" creds2 - arts' = clientHeaderArtifacts arts + arts' = arts { haHash = Just $ calculatePayloadHash (Client.ccAlgorithm creds) payload2 } r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired - r2 @?= Right () + 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) ext + 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 @@ -182,9 +253,9 @@ } 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" + 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" @@ -192,19 +263,23 @@ (_, hdr) = Server.header r Nothing res = mockResponse payload2 [hdr] creds2' = clientCreds "" creds2 - arts' = clientHeaderArtifacts arts + arts2 = arts { haHash = Nothing } - r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired + 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" - -- 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 + 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" @@ -214,10 +289,10 @@ -- authenticate request r <- Server.authenticate def credsFunc hrq - isRight r @?= True + assertSuccess r let Right s@(Server.AuthSuccess creds' arts user) = r user @?= "steve" - Server.shaExt arts @?= Just "some-app-data" + Hawk.haExt arts @?= Just "some-app-data" -- authenticate payload Server.authenticatePayload s payload @?= Right () @@ -231,7 +306,7 @@ 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 + 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" @@ -244,10 +319,10 @@ -- authenticate request r <- Server.authenticate def credsFunc hrq - isRight r @?= True + assertSuccess r let Right s@(Server.AuthSuccess creds' arts user) = r user @?= "steve" - Server.shaExt arts @?= Just "some-app-data" + 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)) @@ -260,7 +335,7 @@ ext = Just "some-app-data" app = "asd23ased" hdr <- Client.headerOz "http://example.com:8080/resource/4?filter=a" "GET" - creds Nothing ext app Nothing + creds Nothing 0 ext app Nothing let hrq = def { hrqUrl = "/resource/4?filter=a" , hrqHost = "example.com" @@ -270,12 +345,12 @@ -- authenticate request r <- Server.authenticate def credsFunc hrq - isRight r @?= True + assertSuccess r 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 + 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" @@ -283,7 +358,7 @@ app = "asd23ased" dlg = "23434szr3q4d" hdr <- Client.headerOz "http://example.com:8080/resource/4?filter=a" "GET" - creds Nothing ext app (Just dlg) + creds Nothing 0 ext app (Just dlg) let hrq = def { hrqUrl = "/resource/4?filter=a" , hrqHost = "example.com" @@ -293,17 +368,16 @@ -- authenticate request r <- Server.authenticate def credsFunc hrq - isRight r @?= True - let Right s@(Server.AuthSuccess creds' arts user) = r + s@(Server.AuthSuccess creds' arts user) <- assertSuccess r user @?= user - Server.shaExt arts @?= Just "some-app-data" - Server.shaApp arts @?= Just app - Server.shaDlg arts @?= Just "23434szr3q4d" + 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 ext + 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" @@ -322,5 +396,605 @@ missing = return () boring = return () -testHeader01 = testCase "returns a valid authorization header (sha1)" $ do +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