{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TupleSections     #-}
module GitHub.WebHook.Handler
  ( Handler (..)
  , Error (..)
  , runHandler
  , removeNulls
  ) where

import           Crypto.Hash           (HMAC, SHA1, digestToHexByteString, hmac,
                                        hmacGetDigest)
import           Data.Aeson            (ToJSON (..), Value (..),
                                        eitherDecodeStrict')
import qualified Data.Aeson.KeyMap     as KeyMap
import           Data.Aeson.Types      (parseEither)
import           Data.ByteString       (ByteString)
import qualified Data.ByteString.Char8 as BC8
import           Data.Text             (Text)
import qualified Data.Text             as Text
import           Data.Text.Encoding    (decodeUtf8)
import           Data.UUID             (UUID, fromASCIIBytes)
import qualified Data.Vector           as Vector

import           GitHub.Types



data Handler m = Handler
    { Handler m -> [String]
hSecretKeys :: [String]
      -- ^ Secret keys which are used to authenticate the incoming request.
      -- If the list is empty then no authentication is required. The handler
      -- tries each key until it finds one which works. This makes it easier
      -- to rotate keys because you can have multiple ones active at any given
      -- point in time.

    , Handler m -> m ByteString
hBody       :: m ByteString
      -- ^ Action which is used to read the request body.

    , Handler m -> ByteString -> m (Maybe ByteString)
hHeader     :: ByteString -> m (Maybe ByteString)
      -- ^ Action which is used to retrieve a particular header from the
      -- request.
    }


data Error
    = InvalidRequest
      -- ^ The incoming request is not well-formed. If that happens it means
      -- GitHub screwed something up, or changed the format of the request.

    | ParseError !Text
      -- ^ The request looks valid but we failed to parse the payload. This
      -- could be because our parsing code is wrong, or because GitHub added
      -- a new event type which we don't handle yet.

    | IncompleteParse Value Payload
      -- ^ The request looks valid but we failed to parse the payload. This
      -- could be because our parsing code is wrong, or because GitHub added
      -- a new event type which we don't handle yet.

    | UnsignedRequest
      -- ^ We were expecting a signed request but no signature was included.
      -- Such requests are rejected beause we don't want to accept requests from
      -- untrusted sources.

    | InvalidSignature
      -- ^ A signature was included in the request but it did not match the
      -- secret key which was providid to the handler. Usually points to
      -- a configuration error on either end.


toParseError :: String -> Either Error Payload
toParseError :: String -> Either Error Payload
toParseError = Error -> Either Error Payload
forall a b. a -> Either a b
Left (Error -> Either Error Payload)
-> (String -> Error) -> String -> Either Error Payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
ParseError (Text -> Error) -> (String -> Text) -> String -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack


removeNulls :: ToJSON a => a -> Value
removeNulls :: a -> Value
removeNulls = Value -> Value
go (Value -> Value) -> (a -> Value) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON
  where
    go :: Value -> Value
go (Array  Array
x) = Array -> Value
Array (Array -> Value) -> (Array -> Array) -> Array -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Value) -> Array -> Array
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map Value -> Value
go (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Array
x
    go (Object Object
x) = Object -> Value
Object (Object -> Value) -> (Object -> Object) -> Object -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Value) -> Object -> Object
forall a b. (a -> b) -> KeyMap a -> KeyMap b
KeyMap.map Value -> Value
go (Object -> Object) -> (Object -> Object) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Bool) -> Object -> Object
forall v. (v -> Bool) -> KeyMap v -> KeyMap v
KeyMap.filter (Bool -> Bool
not (Bool -> Bool) -> (Value -> Bool) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Bool
isEmpty) (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
x
    go         Value
x  = Value
x

    isEmpty :: Value -> Bool
isEmpty Value
Null      = Bool
True
    isEmpty (Array Array
x) = Array -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Array
x
    isEmpty Value
_         = Bool
False


toSuccess :: Value -> Payload -> Either Error Payload
toSuccess :: Value -> Payload -> Either Error Payload
toSuccess Value
value Payload
payload =
  if Payload -> Value
forall a. ToJSON a => a -> Value
removeNulls Payload
payload Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Value
forall a. ToJSON a => a -> Value
removeNulls Value
value
    then Payload -> Either Error Payload
forall a b. b -> Either a b
Right Payload
payload
    else Error -> Either Error Payload
forall a b. a -> Either a b
Left (Error -> Either Error Payload) -> Error -> Either Error Payload
forall a b. (a -> b) -> a -> b
$ Value -> Payload -> Error
IncompleteParse Value
value Payload
payload


verifySecretKey :: ByteString -> ByteString -> String -> Bool
verifySecretKey :: ByteString -> ByteString -> String -> Bool
verifySecretKey ByteString
rawBody ByteString
sig String
key = ByteString
sig ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== (ByteString
"sha1=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Digest SHA1 -> ByteString
forall a. Digest a -> ByteString
digestToHexByteString
    (HMAC SHA1 -> Digest SHA1
forall a. HMAC a -> Digest a
hmacGetDigest (ByteString -> ByteString -> HMAC SHA1
forall a. HashAlgorithm a => ByteString -> ByteString -> HMAC a
hmac (String -> ByteString
BC8.pack String
key) ByteString
rawBody :: HMAC SHA1)))


runHandler :: (Applicative m, Monad m) => Handler m -> m (Either Error (UUID, Payload))
runHandler :: Handler m -> m (Either Error (UUID, Payload))
runHandler Handler m
h = do
    Maybe UUID
mbDelivery <- (ByteString -> Maybe UUID
fromASCIIBytes (ByteString -> Maybe UUID) -> Maybe ByteString -> Maybe UUID
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe ByteString -> Maybe UUID)
-> m (Maybe ByteString) -> m (Maybe UUID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler m -> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
Handler m -> ByteString -> m (Maybe ByteString)
hHeader Handler m
h ByteString
"X-GitHub-Delivery"

    Either Error Payload
res <- do
        ByteString
rawBody     <- Handler m -> m ByteString
forall (m :: * -> *). Handler m -> m ByteString
hBody Handler m
h
        Maybe ByteString
mbSignature <- Handler m -> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
Handler m -> ByteString -> m (Maybe ByteString)
hHeader Handler m
h ByteString
"X-Hub-Signature"

        let authenticatedBody :: Either Error ByteString
authenticatedBody
              = case (Handler m -> [String]
forall (m :: * -> *). Handler m -> [String]
hSecretKeys Handler m
h, Maybe ByteString
mbSignature) of
                  -- No secret key and no signature. Pass along the body
                  -- unverified.
                  ([], Maybe ByteString
Nothing) -> ByteString -> Either Error ByteString
forall a b. b -> Either a b
Right ByteString
rawBody

                  -- Signature is available but no secret keys to verify it.
                  -- This is not a fatal error, we can still process the event.
                  ([], Just ByteString
_) -> ByteString -> Either Error ByteString
forall a b. b -> Either a b
Right ByteString
rawBody

                  -- Secret keys are available but the request is not signed.
                  -- Reject the request.
                  ([String]
_, Maybe ByteString
Nothing) -> Error -> Either Error ByteString
forall a b. a -> Either a b
Left Error
UnsignedRequest

                  -- Both the signature and secret keys are available. Verify
                  -- the signature with the first key which works, otherwise
                  -- reject the request.
                  ([String]
secretKeys, Just ByteString
sig) ->
                      if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> String -> Bool
verifySecretKey ByteString
rawBody ByteString
sig) [String]
secretKeys
                          then ByteString -> Either Error ByteString
forall a b. b -> Either a b
Right ByteString
rawBody
                          else Error -> Either Error ByteString
forall a b. a -> Either a b
Left Error
InvalidSignature

        Maybe ByteString
mbEventName <- Handler m -> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
Handler m -> ByteString -> m (Maybe ByteString)
hHeader Handler m
h ByteString
"X-GitHub-Event"
        Either Error Payload -> m (Either Error Payload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error Payload -> m (Either Error Payload))
-> Either Error Payload -> m (Either Error Payload)
forall a b. (a -> b) -> a -> b
$ do
            ByteString
eventName <- Either Error ByteString
-> (ByteString -> Either Error ByteString)
-> Maybe ByteString
-> Either Error ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Error -> Either Error ByteString
forall a b. a -> Either a b
Left Error
InvalidRequest) ByteString -> Either Error ByteString
forall a b. b -> Either a b
Right Maybe ByteString
mbEventName
            ByteString
body      <- Either Error ByteString
authenticatedBody
            case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict' ByteString
body of
                Left String
e -> String -> Either Error Payload
toParseError String
e
                Right Value
value -> (String -> Either Error Payload)
-> (Payload -> Either Error Payload)
-> Either String Payload
-> Either Error Payload
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Either Error Payload
toParseError (Value -> Payload -> Either Error Payload
toSuccess Value
value) (Either String Payload -> Either Error Payload)
-> Either String Payload -> Either Error Payload
forall a b. (a -> b) -> a -> b
$
                    (Value -> Parser Payload) -> Value -> Either String Payload
forall a b. (a -> Parser b) -> a -> Either String b
parseEither (Text -> Value -> Parser Payload
webhookPayloadParser (Text -> Value -> Parser Payload)
-> Text -> Value -> Parser Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
eventName) Value
value

    Either Error (UUID, Payload) -> m (Either Error (UUID, Payload))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Error (UUID, Payload) -> m (Either Error (UUID, Payload)))
-> Either Error (UUID, Payload) -> m (Either Error (UUID, Payload))
forall a b. (a -> b) -> a -> b
$ case Maybe UUID
mbDelivery of
        Maybe UUID
Nothing   -> Error -> Either Error (UUID, Payload)
forall a b. a -> Either a b
Left Error
InvalidRequest
        Just UUID
uuid -> (Payload -> (UUID, Payload))
-> Either Error Payload -> Either Error (UUID, Payload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UUID
uuid,) Either Error Payload
res