{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module      : Network.Pusher.Internal.Auth
-- Description : Functions to perform authentication (generate auth signatures)
-- Copyright   : (c) Will Sewell, 2016
-- Licence     : MIT
-- Maintainer  : me@willsewell.com
-- Stability   : stable
--
-- This module contains helper functions for authenticating HTTP requests, as
-- well as publicly facing functions for authentication private and presence
-- channel users; these functions are re-exported in the main Pusher module.
module Network.Pusher.Internal.Auth
  ( authenticatePresence,
    authenticatePresenceWithEncoder,
    authenticatePrivate,
    makeQS,
  )
where

import qualified Crypto.Hash as Hash
import qualified Crypto.MAC.HMAC as HMAC
import qualified Data.Aeson as A
import qualified Data.Aeson.Text as A
import Data.Bifunctor (first)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BC
import Data.Char (toLower)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL
import Data.Word (Word64)
import GHC.Exts (sortWith)
import Network.HTTP.Types (Query)
import Network.Pusher.Data (Token (..))
import Network.Pusher.Internal.Util (show')

-- | Generate the required query string parameters required to send API requests
--  to Pusher.
makeQS ::
  Token ->
  B.ByteString ->
  B.ByteString ->
  -- | Any additional parameters.
  Query ->
  B.ByteString ->
  Word64 ->
  Query
makeQS :: Token
-> ByteString
-> ByteString
-> Query
-> ByteString
-> Word64
-> Query
makeQS Token
token ByteString
method ByteString
path Query
params ByteString
body Word64
timestamp =
  -- Generate all required parameters and add them to the list of existing ones
  -- Parameters are:
  -- - In alphabetical order
  -- - Keys are lower case
  let allParams :: Query
allParams =
        Query -> Query
forall b. [(ByteString, b)] -> [(ByteString, b)]
alphabeticalOrder (Query -> Query) -> (Query -> Query) -> Query -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> Query
forall b. [(ByteString, b)] -> [(ByteString, b)]
lowercaseKeys (Query -> Query) -> (Query -> Query) -> Query -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Query
params Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++) (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$
          [ (ByteString
"auth_key", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Token -> ByteString
tokenKey Token
token),
            (ByteString
"auth_timestamp", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> ByteString
forall a b. (Show a, IsString b) => a -> b
show' Word64
timestamp),
            (ByteString
"auth_version", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"1.0"),
            ( ByteString
"body_md5",
              ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just
                (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B16.encode
                (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest MD5 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ByteString -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash ByteString
body :: Hash.Digest Hash.MD5)
            )
          ]
      -- Generate the auth signature from the list of parameters
      authSig :: ByteString
authSig =
        ByteString -> ByteString -> ByteString
authSignature (Token -> ByteString
tokenSecret Token
token) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          ByteString -> [ByteString] -> ByteString
B.intercalate
            ByteString
"\n"
            [ByteString
method, ByteString
path, Query -> ByteString
formQueryString Query
allParams]
   in -- Add the auth string to the list
      ((ByteString
"auth_signature", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
authSig) (ByteString, Maybe ByteString) -> Query -> Query
forall a. a -> [a] -> [a]
: Query
allParams)
  where
    alphabeticalOrder :: [(ByteString, b)] -> [(ByteString, b)]
alphabeticalOrder = ((ByteString, b) -> ByteString)
-> [(ByteString, b)] -> [(ByteString, b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (ByteString, b) -> ByteString
forall a b. (a, b) -> a
fst
    lowercaseKeys :: [(ByteString, c)] -> [(ByteString, c)]
lowercaseKeys = ((ByteString, c) -> (ByteString, c))
-> [(ByteString, c)] -> [(ByteString, c)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString) -> (ByteString, c) -> (ByteString, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Char -> Char) -> ByteString -> ByteString
BC.map Char -> Char
toLower))

-- | Render key-value tuple mapping of query string parameters into a string.
formQueryString :: Query -> B.ByteString
formQueryString :: Query -> ByteString
formQueryString = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"&" ([ByteString] -> ByteString)
-> (Query -> [ByteString]) -> Query -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Maybe ByteString) -> ByteString)
-> Query -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> ByteString
forall p. (Semigroup p, IsString p) => (p, Maybe p) -> p
formQueryItem
  where
    formQueryItem :: (p, Maybe p) -> p
formQueryItem (p
k, Just p
v) = p
k p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
"=" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
v
    formQueryItem (p
k, Maybe p
Nothing) = p
k

-- | Create a Pusher auth signature of a string using the provided credentials.
authSignature :: B.ByteString -> B.ByteString -> B.ByteString
authSignature :: ByteString -> ByteString -> ByteString
authSignature ByteString
appSecret ByteString
authString =
  ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    HMAC SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac ByteString
appSecret ByteString
authString :: HMAC.HMAC Hash.SHA256)

-- | Generate an auth signature of the form "app_key:auth_sig" for a user of a
--  private channel.
authenticatePrivate :: Token -> T.Text -> T.Text -> B.ByteString
authenticatePrivate :: Token -> Text -> Text -> ByteString
authenticatePrivate Token
token Text
socketID Text
channel =
  let sig :: ByteString
sig =
        ByteString -> ByteString -> ByteString
authSignature
          (Token -> ByteString
tokenSecret Token
token)
          (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
socketID Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
channel)
   in Token -> ByteString
tokenKey Token
token ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sig

-- | Generate an auth signature of the form "app_key:auth_sig" for a user of a
--  presence channel.
authenticatePresence ::
  A.ToJSON a => Token -> T.Text -> T.Text -> a -> B.ByteString
authenticatePresence :: Token -> Text -> Text -> a -> ByteString
authenticatePresence =
  (a -> Text) -> Token -> Text -> Text -> a -> ByteString
forall a. (a -> Text) -> Token -> Text -> Text -> a -> ByteString
authenticatePresenceWithEncoder
    (Text -> Text
TL.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TL.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Builder
forall a. ToJSON a => a -> Builder
A.encodeToTextBuilder (Value -> Builder) -> (a -> Value) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
A.toJSON)

-- | As above, but allows the encoder of the user data to be specified. This is
--  useful for testing because the encoder can be mocked; aeson's encoder enodes
--  JSON object fields in arbitrary orders, which makes it impossible to test.
authenticatePresenceWithEncoder ::
  -- | The encoder of the user data.
  (a -> T.Text) ->
  Token ->
  T.Text ->
  T.Text ->
  a ->
  B.ByteString
authenticatePresenceWithEncoder :: (a -> Text) -> Token -> Text -> Text -> a -> ByteString
authenticatePresenceWithEncoder a -> Text
userEncoder Token
token Text
socketID Text
channel a
userData =
  let authString :: ByteString
authString =
        Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
          Text
socketID Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
channel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
userEncoder a
userData
      sig :: ByteString
sig = ByteString -> ByteString -> ByteString
authSignature (Token -> ByteString
tokenSecret Token
token) ByteString
authString
   in Token -> ByteString
tokenKey Token
token ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sig