{-|
Module : Servant.GitHub.Webhook
Description : Easily write safe GitHub webhook handlers with Servant
Copyright : (c) Jacob Thomas Errington, 2016
License : MIT
Maintainer : servant-github-webhook@mail.jerrington.me
Stability : experimental
The GitHub webhook machinery will attach three headers to the HTTP requests
that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@.
The former two headers correspond with the 'GitHubEvent' and
'GitHubSignedReqBody''' routing combinators. This library ignores the
@X-Github-Delivery@ header; if you would like to access its value, then use the
builtin 'Header' combinator from Servant.
Usage of the library is straightforward: protect routes with the 'GitHubEvent'
combinator to ensure that the route is only reached for specific
'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write
under that route with 'GitHubSignedReqBody'. It is advised to always include a
'GitHubSignedReqBody''', as this is the only way you can be sure that it is
GitHub who is sending the request, and not a malicious user. If you don't care
about the request body, then simply use Aeson\'s 'Object' type as the
deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and
ignore the @Object@ in the handler.
The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in
order to extract the signing key. This is the same key that must be entered in
the configuration of the webhook on GitHub. See 'GitHubKey'' for more details.
In order to support multiple keys on a per-route basis, the basic combinator
@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this,
create a datatype, e.g. @KeyIndex@ whose constructors identify the different
keys you will be using. Generally, this means one constructor per repository.
Use the @DataKinds@ extension to promote this datatype to a kind, and write an
instance of 'Reflect' for each promoted constructor of your datatype. Finally,
create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is
the datatype you've built up. Thus, your function can determine which key to
retrieve.
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Servant.GitHub.Webhook
( -- * Servant combinators
GitHubSignedReqBody''
, GitHubSignedReqBody'
, GitHubSignedReqBody
, GitHubEvent
-- ** Security
, GitHubKey'(..)
, GitHubKey
, gitHubKey
-- * Reexports
--
-- | We reexport a few datatypes that are typically needed to use the
-- library.
, RepoWebhookEvent(..)
, KProxy(..)
-- * Implementation details
-- ** Type-level programming machinery
, Demote
, Demote'
, Reflect(..)
-- ** Stringy stuff
, parseHeaderMaybe
, matchEvent
-- * Examples
--
-- $example1
--
-- $example2
) where
import Control.Monad.IO.Class ( liftIO )
import Crypto.Hash.Algorithms ( SHA1 )
import Crypto.MAC.HMAC ( hmac, HMAC(..) )
import Data.Aeson ( decode', encode )
import Data.ByteArray ( convert )
import qualified Data.ByteString as BS
import Data.ByteString.Lazy ( fromStrict, toStrict )
import qualified Data.ByteString.Base16 as B16
import Data.List ( intercalate )
import Data.Maybe ( catMaybes, fromMaybe )
import Data.Monoid ( (<>) )
import Data.Proxy
import Data.String.Conversions ( cs )
import qualified Data.Text.Encoding as E
import GHC.TypeLits
import GitHub.Data.Webhooks
import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai ( requestHeaders, strictRequestBody )
import Servant
import Servant.API.ContentTypes ( AllCTUnrender(..) )
import Servant.Server.Internal
-- | A clone of Servant's 'ReqBody' combinator, except that it will also
-- verify the signature provided by GitHub in the @X-Hub-Signature@ header by
-- computing the SHA1 HMAC of the request body and comparing.
--
-- The use of this combinator will require that the router context contain an
-- appropriate 'GitHubKey'' entry. Specifically, the type parameter of
-- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the
-- index @key@ used here. Consequently, it will be necessary to use
-- 'serveWithContext' instead of 'serve'.
--
-- Other routes are not tried upon the failure of this combinator, and a 401
-- response is generated.
--
-- Use of this datatype directly is discouraged, since the choice of the index
-- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use
-- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just
-- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for
-- the implementation of the 'HasServer' instance for the datatype.
data GitHubSignedReqBody''
(proxy :: KProxy k)
(key :: k)
(list :: [*])
(result :: *) where
-- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first
-- type argument given just the second one.
--
-- Use this type synonym if you are creating a webhook server to handle
-- webhooks from multiple repositories, with different secret keys.
type GitHubSignedReqBody' (key :: k)
= GitHubSignedReqBody'' ('KProxy :: KProxy k) key
-- | A convenient alias for a trivial key index.
--
-- USe this type synonym if you are creating a webhook server to handle only
-- webhooks from a single repository, or for mutliple repositories using the
-- same secret key.
type GitHubSignedReqBody = GitHubSignedReqBody' '()
-- | A routing combinator that succeeds only for a webhook request that matches
-- one of the given 'RepoWebhookEvent' given in the type-level list @events@.
--
-- If the list contains 'WebhookWildcardEvent', then all events will be
-- matched.
--
-- The combinator will require that its associated handler take a
-- 'RepoWebhookEvent' parameter, and the matched event will be passed to the
-- handler. This allows the handler to determine which event triggered it from
-- the list.
--
-- Other routes are tried if there is a mismatch.
data GitHubEvent (events :: [RepoWebhookEvent]) where
-- | A wrapper for an IO strategy to obtain the signing key for the webhook as
-- configured in GitHub. The strategy is executed each time the
-- 'GitHubSignedReqBody''s routing logic is executed.
--
-- We allow the use of @IO@ here so that you can fetch the key from a cache or
-- a database. If the key is a constant or read only once, just use 'pure'.
--
-- The type @key@ used here must correspond with @'Demote' k@ where @k@ is the
-- kind whose types are used as indices in 'GitHubSignedReqBody''.
--
-- If you don't care about indices and just want to write a webhook using a
-- global key, see 'GitHubKey' which fixes @key@ to @()@ and use 'gitHubKey',
-- which fills the newtype with a constant function.
newtype GitHubKey' key = GitHubKey { unGitHubKey :: key -> IO BS.ByteString }
-- | A synonym for strategies producing so-called /global/ keys, in which the
-- key index is simply @()@.
type GitHubKey = GitHubKey' ()
-- | Smart constructor for 'GitHubKey', for a so-called /global/ key.
gitHubKey :: IO BS.ByteString -> GitHubKey
gitHubKey = GitHubKey . const
instance forall sublayout context list result (key :: k).
( HasServer sublayout context
, HasContextEntry context (GitHubKey' (Demote key))
, Reflect key
, AllCTUnrender list result
)
=> HasServer
(GitHubSignedReqBody'' ('KProxy :: KProxy k) key list result :> sublayout)
context where
type ServerT
(GitHubSignedReqBody'' ('KProxy :: KProxy k) key list result :> sublayout)
m
= (Demote key, result) -> ServerT sublayout m
route
:: forall env.
Proxy (
GitHubSignedReqBody'' ('KProxy :: KProxy k) key list result
:> sublayout
)
-> Context context
-> Delayed env ((Demote key, result) -> Server sublayout)
-> Router env
route _ context subserver
= route (Proxy :: Proxy sublayout) context (addBodyCheck subserver ct go)
where
lookupSig = lookup "X-Hub-Signature"
keyIndex :: Demote key
keyIndex = reflect (Proxy :: Proxy key)
ct :: DelayedIO (BS.ByteString, Maybe BS.ByteString, result)
ct = withRequest $ \req -> do
let hdrs = requestHeaders req
let contentTypeH =
fromMaybe "application/octet-stream" $ lookup hContentType hdrs
msg <- liftIO (toStrict <$> strictRequestBody req)
let mrqbody =
handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) $
fromStrict msg
case mrqbody of
Nothing -> delayedFailFatal err415
Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
Just (Right v) -> pure (msg, lookupSig hdrs, v)
go
:: (BS.ByteString, Maybe BS.ByteString, result)
-> DelayedIO (Demote key, result)
go (msg, hdr, v) = do
key <- liftIO (unGitHubKey (getContextEntry context) keyIndex)
let sig =
B16.encode $ convert $ hmacGetDigest $ hmac @_ @_ @SHA1 key msg
case parseHeaderMaybe =<< hdr of
Nothing -> delayedFailFatal err401
Just h -> do
let h' = BS.drop 5 $ E.encodeUtf8 h -- remove "sha1=" prefix
if h' == sig
then pure (keyIndex, v)
else delayedFailFatal err401
instance forall sublayout context events.
(Reflect events, HasServer sublayout context)
=> HasServer (GitHubEvent events :> sublayout) context where
type ServerT (GitHubEvent events :> sublayout) m
= RepoWebhookEvent -> ServerT sublayout m
route
:: forall env. Proxy (GitHubEvent events :> sublayout)
-> Context context
-> Delayed env (RepoWebhookEvent -> Server sublayout)
-> Router env
route Proxy context subserver
= route
(Proxy :: Proxy sublayout)
context
(addAuthCheck subserver go)
where
lookupGHEvent = lookup "X-Github-Event"
events :: [RepoWebhookEvent]
events = reflect (Proxy :: Proxy events)
eventNames :: String
eventNames = intercalate ", " $ (cs . encode) <$> events
go :: DelayedIO RepoWebhookEvent
go = withRequest $ \req -> do
case lookupGHEvent (requestHeaders req) of
Nothing -> delayedFail err401
Just h -> do
case catMaybes $ map (`matchEvent` h) events of
[] -> delayedFail err404
{ errBody = cs $ "supported events: " <> eventNames }
(event:_) -> pure event
-- | Type function that reflects a kind to a type.
type family Demote' (kparam :: KProxy k) :: *
-- | Convient alias for 'Demote'' that allows us to avoid using 'KProxy'
-- explicitly.
type Demote (a :: k) = Demote' ('KProxy :: KProxy k)
type instance Demote' ('KProxy :: KProxy ()) = ()
type instance Demote' ('KProxy :: KProxy Symbol) = String
type instance Demote' ('KProxy :: KProxy [k]) = [Demote' ('KProxy :: KProxy k)]
type instance Demote' ('KProxy :: KProxy RepoWebhookEvent) = RepoWebhookEvent
-- | Class of types that can be reflected to values.
class Reflect (a :: k) where
reflect :: Proxy (a :: k) -> Demote a
instance KnownSymbol s => Reflect (s :: Symbol) where
reflect = symbolVal
instance Reflect '() where
reflect _ = ()
instance Reflect '[] where
reflect _ = []
instance (Reflect x, Reflect xs) => Reflect (x ': xs) where
reflect _ = reflect x : reflect xs where
x = Proxy :: Proxy x
xs = Proxy :: Proxy xs
instance Reflect 'WebhookWildcardEvent where
reflect _ = WebhookWildcardEvent
instance Reflect 'WebhookCommitCommentEvent where
reflect _ = WebhookCommitCommentEvent
instance Reflect 'WebhookCreateEvent where
reflect _ = WebhookCreateEvent
instance Reflect 'WebhookDeleteEvent where
reflect _ = WebhookDeleteEvent
instance Reflect 'WebhookDeploymentEvent where
reflect _ = WebhookDeploymentEvent
instance Reflect 'WebhookDeploymentStatusEvent where
reflect _ = WebhookDeploymentStatusEvent
instance Reflect 'WebhookForkEvent where
reflect _ = WebhookForkEvent
instance Reflect 'WebhookGollumEvent where
reflect _ = WebhookGollumEvent
instance Reflect 'WebhookIssueCommentEvent where
reflect _ = WebhookIssueCommentEvent
instance Reflect 'WebhookIssuesEvent where
reflect _ = WebhookIssuesEvent
instance Reflect 'WebhookMemberEvent where
reflect _ = WebhookMemberEvent
instance Reflect 'WebhookPageBuildEvent where
reflect _ = WebhookPageBuildEvent
instance Reflect 'WebhookPingEvent where
reflect _ = WebhookPingEvent
instance Reflect 'WebhookPublicEvent where
reflect _ = WebhookPublicEvent
instance Reflect 'WebhookPullRequestReviewCommentEvent where
reflect _ = WebhookPullRequestReviewCommentEvent
instance Reflect 'WebhookPullRequestEvent where
reflect _ = WebhookPullRequestEvent
instance Reflect 'WebhookPushEvent where
reflect _ = WebhookPushEvent
instance Reflect 'WebhookReleaseEvent where
reflect _ = WebhookReleaseEvent
instance Reflect 'WebhookStatusEvent where
reflect _ = WebhookStatusEvent
instance Reflect 'WebhookTeamAddEvent where
reflect _ = WebhookTeamAddEvent
instance Reflect 'WebhookWatchEvent where
reflect _ = WebhookWatchEvent
-- | Helper that parses a header using a 'FromHttpApiData' instance and
-- discards the parse error message if any.
parseHeaderMaybe :: FromHttpApiData a => BS.ByteString -> Maybe a
parseHeaderMaybe = eitherMaybe . parseHeader where
eitherMaybe :: Either e a -> Maybe a
eitherMaybe e = case e of
Left _ -> Nothing
Right x -> Just x
-- | Determines whether a given webhook event matches a given raw
-- representation of one. The result is 'Nothing' if there is no match. This
-- function accounts for the 'WebhookWildcardEvent' matching everything, so it
-- returns the result of parsing the raw representation when trying to match
-- against the wildcard.
matchEvent :: RepoWebhookEvent -> BS.ByteString -> Maybe RepoWebhookEvent
matchEvent WebhookWildcardEvent s = decode' (fromStrict s') where
s' = "\"" <> s <> "\""
matchEvent e name
| toStrict (encode e) == name' = Just e
| otherwise = Nothing
where name' = "\"" <> name <> "\""
-- $example1
--
-- === Using a global key
--
-- > {-# LANGUAGE DataKinds #-}
-- > {-# LANGUAGE TypeFamilies #-}
-- > {-# LANGUAGE TypeOperators #-}
-- >
-- > module Main
-- > ( main
-- > ) where
-- >
-- > import Control.Monad.IO.Class ( liftIO )
-- > import Data.Aeson ( Object )
-- > import qualified Data.ByteString as BS
-- > import qualified Data.ByteString.Char8 as C8
-- > import Servant
-- > import Servant.GitHub.Webhook
-- > import Network.Wai ( Application )
-- > import Network.Wai.Handler.Warp ( run )
-- >
-- > main :: IO ()
-- > main = do
-- > [key, _] <- C8.lines <$> BS.readFile "test/test-keys"
-- > run 8080 (app (gitHubKey $ pure key))
-- >
-- > app :: GitHubKey -> Application
-- > app key
-- > = serveWithContext
-- > (Proxy :: Proxy API)
-- > (key :. EmptyContext)
-- > server
-- >
-- > server :: Server API
-- > server = anyEvent
-- >
-- > anyEvent :: RepoWebhookEvent -> ((), Object) -> Handler ()
-- > anyEvent e _
-- > = liftIO $ putStrLn $ "got event: " ++ show e
-- >
-- > type API
-- > = "repo1"
-- > :> GitHubEvent '[ 'WebhookPushEvent ]
-- > :> GitHubSignedReqBody '[JSON] Object
-- > :> Post '[JSON] ()
-- $example2
--
-- === Using multiple keys
--
-- > {-# LANGUAGE DataKinds #-}
-- > {-# LANGUAGE TypeFamilies #-}
-- > {-# LANGUAGE TypeOperators #-}
-- >
-- > module Main
-- > ( main
-- > ) where
-- >
-- > import Control.Monad.IO.Class ( liftIO )
-- > import Data.Aeson ( Object )
-- > import qualified Data.ByteString as BS
-- > import qualified Data.ByteString.Char8 as C8
-- > import Network.Wai ( Application )
-- > import Network.Wai.Handler.Warp ( run )
-- > import Servant
-- > import Servant.GitHub.Webhook
-- >
-- > main :: IO ()
-- > main = do
-- > [k1, k2] <- C8.lines <$> BS.readFile "test/test-keys"
-- > run 8080 (app (constKeys k1 k2))
-- >
-- > app :: MyGitHubKey -> Application
-- > app k = serveWithContext api (k :. EmptyContext) server
-- >
-- > server :: Server WebhookApi
-- > server = repo1any :<|> repo2any
-- >
-- > repo1any :: RepoWebhookEvent -> (Key, Object) -> Handler ()
-- > repo1any WebhookPingEvent _ = liftIO $ putStrLn "got ping on repo1!"
-- > repo1any e _ = liftIO $ putStrLn $ "got event on repo 1: " ++ show e
-- >
-- > repo2any :: RepoWebhookEvent -> (Key, Object) -> Handler ()
-- > repo2any e _ = liftIO $ putStrLn $ "got event on repo 2: " ++ show e
-- >
-- > api :: Proxy WebhookApi
-- > api = Proxy
-- >
-- > type WebhookApi
-- > = "repo1"
-- > :> GitHubEvent '[ 'WebhookWildcardEvent ]
-- > :> GitHubSignedReqBody' 'Repo1 '[JSON] Object
-- > :> Post '[JSON] ()
-- > :<|>
-- > "repo2"
-- > :> GitHubEvent '[ 'WebhookWildcardEvent ]
-- > :> GitHubSignedReqBody' 'Repo2 '[JSON] Object
-- > :> Post '[JSON] ()
-- >
-- > type MyGitHubKey = GitHubKey' Key
-- >
-- > data Key
-- > = Repo1
-- > | Repo2
-- >
-- > constKeys :: BS.ByteString -> BS.ByteString -> MyGitHubKey
-- > constKeys k1 k2 = GitHubKey $ \k -> pure $ case k of
-- > Repo1 -> k1
-- > Repo2 -> k2
-- >
-- > type instance Demote' ('KProxy :: KProxy Key) = Key
-- > instance Reflect 'Repo1 where
-- > reflect _ = Repo1
-- > instance Reflect 'Repo2 where
-- > reflect _ = Repo2