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