packages feed

hsoz 0.0.0.3 → 0.0.0.4

raw patch · 35 files changed

+2217/−824 lines, 35 filesdep +exceptionsdep +hashabledep +optparse-applicativedep −wreqdep ~basedep ~http-clientdep ~http-conduitnew-component:exe:iron

Dependencies added: exceptions, hashable, optparse-applicative, unordered-containers

Dependencies removed: wreq

Dependency ranges changed: base, http-client, http-conduit

Files

README.md view
@@ -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
example/BewitClient.hs view
@@ -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"
example/BewitServer.hs view
@@ -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
example/HawkClient.hs view
@@ -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
example/HawkServer.hs view
@@ -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
+ example/Iron.hs view
@@ -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
example/OzServer.hs view
@@ -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
hsoz.cabal view
@@ -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 <dev@rodney.id.au> 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
src/Network/Hawk/Client.hs view
@@ -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
− src/Network/Hawk/Client/HeaderParser.hs 
@@ -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
− src/Network/Hawk/Client/Types.hs 
@@ -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)
− src/Network/Hawk/Common.hs 
@@ -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"
+ src/Network/Hawk/Internal.hs view
@@ -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"
+ src/Network/Hawk/Internal/Client.hs view
@@ -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
+ src/Network/Hawk/Internal/Client/HeaderParser.hs view
@@ -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
+ src/Network/Hawk/Internal/Client/Types.hs view
@@ -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
+ src/Network/Hawk/Internal/JSON.hs view
@@ -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
+ src/Network/Hawk/Internal/Server.hs view
@@ -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
+ src/Network/Hawk/Internal/Server/Header.hs view
@@ -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)+            ]
+ src/Network/Hawk/Internal/Server/Types.hs view
@@ -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
+ src/Network/Hawk/Internal/Types.hs view
@@ -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)
src/Network/Hawk/Middleware.hs view
@@ -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
src/Network/Hawk/Server.hs view
@@ -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
+ src/Network/Hawk/Server/Nonce.hs view
@@ -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])
− src/Network/Hawk/Server/Types.hs 
@@ -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))
src/Network/Hawk/Types.hs view
@@ -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
src/Network/Hawk/URI.hs view
@@ -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'.
src/Network/Hawk/Util.hs view
@@ -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
src/Network/Iron.hs view
@@ -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
src/Network/Iron/Util.hs view
@@ -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
src/Network/Oz/Application.hs view
@@ -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
src/Network/Oz/Client.hs view
@@ -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
src/Network/Oz/Server.hs view
@@ -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
src/Network/Oz/Ticket.hs view
@@ -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
test/Network/Hawk/Tests.hs view
@@ -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