diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for servant-github-webhook +## 0.3.1.0 -- 2017-08-06 + +* Drop support for GHC <8. +* Drop support for Servant <0.11. +* Switch from Crypto package to cryptonite package. +* Now servant-github-webhook builds with stack. + ## 0.3.0.0 -- 2016-09-22 * Pass reflected key index to the handler function for GitHubSignedReqBody. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,9 @@ -[![Build Status](https://travis-ci.org/tsani/servant-github-webhook.svg?branch=master)](https://travis-ci.org/tsani/servant-github-webhook) - servant-github-webhook ====================== +[![Build Status][badge-travis]][travis] +[![Hackage][badge-hackage]][hackage] + This library facilitates writing Servant routes that can safely act as GitHub webhooks. @@ -10,13 +11,23 @@ * Dispatching to routes based on the type of repository event. * Automatic verification of request signatures. + * Route protection expressed in the type system, so webhook routes and + regular routes cannot be confused. -See the -[documentation](https://hackage.haskell.org/package/servant-github-webhook-0.2.0.0/docs/Servant-GitHub-Webhook.html) -for more details about how the library works, and how to use it. +Why use servant-github-webhook? +------------------------------- -TODO ------ +A webhook server needs to be publicly hosted. How can legitimate requests sent +by GitHub be distinguished from (malicious) requests sent by other clients? - * `servant-client` and `servant-docs` instances. - * Tests. +When a webhook is configured on a repository, a *secret key* is added. This key +is used by GitHub to compute a *signature* of the request body that it sends; +this signature is included in the request headers. The routing combinators in +servant-github-webhook compute the signature of the received request body using +the same key, and check that the signature in the request headers matches. If +it does, then the request is legitimate. + +[hackage]: https://hackage.haskell.org/package/servant-github-webhook +[badge-hackage]: https://img.shields.io/hackage/v/servant-github-webhook.svg +[travis]: https://travis-ci.org/tsani/servant-github-webhook?branch=master +[badge-travis]: https://travis-ci.org/tsani/servant-github-webhook.svg?branch=master diff --git a/servant-github-webhook.cabal b/servant-github-webhook.cabal --- a/servant-github-webhook.cabal +++ b/servant-github-webhook.cabal @@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: servant-github-webhook -version: 0.3.0.2 +version: 0.3.1.0 synopsis: Servant combinators to facilitate writing GitHub webhooks. description: This package provides servant combinators that make writing safe GitHub @@ -19,7 +19,7 @@ copyright: Jacob Thomas Errington 2016 category: Web build-type: Simple -tested-with: GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 8.0.1, GHC == 8.0.2 extra-source-files: ChangeLog.md README.md @@ -41,14 +41,15 @@ ghc-options: -Wall build-depends: - aeson >=0.11 && <1.1, + aeson >=0.11 && <1.2, base16-bytestring >=0.1 && <0.2, bytestring >= 0.10 && <0.11, - Crypto >=4.2 && <4.3, - github >=0.15 && <0.16, + cryptonite >=0.23 && <0.25, + github >=0.15 && <0.17, http-types >=0.9 && <0.10, - servant >=0.8 && <0.10, - servant-server >=0.8 && <0.10, + memory >=0.14 && <0.15, + servant >=0.11 && <0.12, + servant-server >=0.11 && <0.12, string-conversions >=0.4 && <0.5, text >=1.2 && <1.3, wai >=3.2 && <3.3 diff --git a/src/Servant/GitHub/Webhook.hs b/src/Servant/GitHub/Webhook.hs --- a/src/Servant/GitHub/Webhook.hs +++ b/src/Servant/GitHub/Webhook.hs @@ -38,8 +38,6 @@ retrieve. -} -{-# LANGUAGE CPP #-} - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -48,21 +46,13 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} --- GHC 8 seems to have improved its decidability check for type family --- instances and class instances. In particular, without UndecidableInstances --- enabled, the Demote' instance for lists, which we need, will not compile. --- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, --- won't compile on GHC < 8 because the instance head is no smaller than the --- instance head. -#if __GLASGOW_HASKELL__ < 800 -{-# LANGUAGE UndecidableInstances #-} -#endif - module Servant.GitHub.Webhook ( -- * Servant combinators GitHubSignedReqBody'' @@ -101,11 +91,13 @@ ) 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.HMAC ( hmac_sha1 ) import Data.List ( intercalate ) import Data.Maybe ( catMaybes, fromMaybe ) import Data.Monoid ( (<>) ) @@ -222,36 +214,45 @@ -> Delayed env ((Demote key, result) -> Server sublayout) -> Router env route _ context subserver - = route (Proxy :: Proxy sublayout) context (addBodyCheck subserver go) + = route (Proxy :: Proxy sublayout) context (addBodyCheck subserver ct go) where lookupSig = lookup "X-Hub-Signature" keyIndex :: Demote key keyIndex = reflect (Proxy :: Proxy key) - go :: DelayedIO (Demote key, result) - go = withRequest $ \req -> do + ct :: DelayedIO (BS.ByteString, Maybe BS.ByteString, result) + ct = withRequest $ \req -> do let hdrs = requestHeaders req - key <- BS.unpack <$> - liftIO (unGitHubKey (getContextEntry context) keyIndex) - msg <- BS.unpack <$> liftIO (toStrict <$> strictRequestBody req) - let sig = B16.encode $ BS.pack $ hmac_sha1 key msg - let contentTypeH = fromMaybe "application/octet-stream" - $ lookup hContentType $ hdrs + let contentTypeH = + fromMaybe "application/octet-stream" $ lookup hContentType hdrs + + msg <- liftIO (toStrict <$> strictRequestBody req) + let mrqbody = handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) $ - fromStrict (BS.pack msg) + fromStrict msg case mrqbody of Nothing -> delayedFailFatal err415 Just (Left e) -> delayedFailFatal err400 { errBody = cs e } - Just (Right v) -> case parseHeaderMaybe =<< lookupSig hdrs 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 + 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)