module Network.Hawk.Client
( header
, headerOz
, getBewit
, authenticate
, ServerAuthorizationCheck(..)
, Credentials(..)
, 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
header :: Text
-> Method
-> Credentials
-> Maybe PayloadInfo
-> Maybe Text
-> IO Header
header url method creds payload ext = headerBase url method creds payload ext Nothing Nothing
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
data ServerAuthorizationCheck = ServerAuthorizationNotRequired
| ServerAuthorizationRequired
deriving Show
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 ()
responseHeader :: HeaderName -> Response body -> Maybe ByteString
responseHeader h = lookup h . responseHeaders
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"
getBewit :: Credentials -> NominalDiffTime -> Maybe ByteString -> NominalDiffTime
-> ByteString -> IO (Maybe ByteString)
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 ]