module GitHub.WebHook.Handler
( Handler(..)
, Error(..)
, runHandler
) where
import Crypto.Hash
import Control.Applicative
import Data.Aeson (eitherDecodeStrict')
import Data.Aeson.Types (parseEither)
import Data.Monoid
import Data.Text hiding (any)
import qualified Data.Text as T
import Data.Text.Encoding
import Data.ByteString hiding (any)
import qualified Data.ByteString.Char8 as BC8
import Data.UUID
import GitHub.Types
data Handler m = Handler
{ hSecretKeys :: [String]
, hBody :: m ByteString
, hHeader :: ByteString -> m (Maybe ByteString)
}
data Error
= InvalidRequest
| ParseError !Text
| UnsignedRequest
| InvalidSignature
toParseError :: String -> Either Error Payload
toParseError = Left . ParseError . T.pack
verifySecretKey :: ByteString -> ByteString -> String -> Bool
verifySecretKey rawBody sig key = sig == ("sha1=" <> digestToHexByteString
(hmacGetDigest (hmac (BC8.pack key) rawBody :: HMAC SHA1)))
runHandler :: (Applicative m, Monad m) => Handler m -> m (Either Error (UUID, Payload))
runHandler h = do
mbDelivery <- pure . (fromASCIIBytes =<<) =<< hHeader h "X-GitHub-Delivery"
res <- do
rawBody <- hBody h
mbSignature <- hHeader h "X-Hub-Signature"
authenticatedBody <- pure $ case (hSecretKeys h, mbSignature) of
([], Nothing) -> Right rawBody
([], Just _) -> Right rawBody
(_, Nothing) -> Left UnsignedRequest
(secretKeys, Just sig) -> do
if any (verifySecretKey rawBody sig) secretKeys
then Right rawBody
else Left InvalidSignature
mbEventName <- hHeader h "X-GitHub-Event"
pure $ do
eventName <- maybe (Left InvalidRequest) Right mbEventName
body <- authenticatedBody
case eitherDecodeStrict' body of
Left e -> toParseError e
Right value -> either toParseError Right $
parseEither (webhookPayloadParser $ decodeUtf8 eventName) value
pure $ case mbDelivery of
Nothing -> Left InvalidRequest
Just uuid -> fmap ((,) uuid) res