├── .github └── workflows │ └── cabal.yml ├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── servant-github-webhook.cabal ├── src └── Servant │ └── GitHub │ └── Webhook.hs ├── stack.yaml └── test ├── dynamickey └── Main.hs ├── multikey └── Main.hs └── singlekey └── Main.hs /.github/workflows/cabal.yml: -------------------------------------------------------------------------------- 1 | # https://github.com/haskell/actions/tree/main/setup 2 | 3 | name: build 4 | on: 5 | push: 6 | branches: [main, master] 7 | pull_request: 8 | branches: [main, master] 9 | 10 | permissions: 11 | contents: read 12 | 13 | jobs: 14 | build: 15 | name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} 16 | runs-on: ${{ matrix.os }} 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | os: [ubuntu-latest] 21 | ghc-version: ['9.6', '9.4', '9.2', '9.0'] 22 | 23 | steps: 24 | - uses: actions/checkout@v3 25 | 26 | - name: Set up GHC ${{ matrix.ghc-version }} 27 | uses: haskell/actions/setup@v2 28 | id: setup 29 | with: 30 | ghc-version: ${{ matrix.ghc-version }} 31 | # Defaults, added for clarity: 32 | cabal-version: 'latest' 33 | cabal-update: true 34 | 35 | - name: Configure the build 36 | run: | 37 | cabal configure --enable-tests --enable-benchmarks --disable-documentation 38 | cabal build --dry-run 39 | # The last step generates dist-newstyle/cache/plan.json for the cache key. 40 | 41 | - name: Restore cached dependencies 42 | uses: actions/cache/restore@v3 43 | id: cache 44 | env: 45 | key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} 46 | with: 47 | path: ${{ steps.setup.outputs.cabal-store }} 48 | key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} 49 | restore-keys: ${{ env.key }}- 50 | 51 | - name: Install dependencies 52 | run: cabal build all --only-dependencies 53 | 54 | # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. 55 | - name: Save cached dependencies 56 | uses: actions/cache/save@v3 57 | # Caches are immutable, trying to save with the same key would error. 58 | if: ${{ steps.cache.outputs.cache-primary-key != steps.cache.outputs.cache-matched-key }} 59 | with: 60 | path: ${{ steps.setup.outputs.cabal-store }} 61 | key: ${{ steps.cache.outputs.cache-primary-key }} 62 | 63 | - name: Build 64 | run: cabal build all 65 | 66 | - name: Run tests 67 | run: cabal test all 68 | 69 | - name: Check cabal file 70 | run: cabal check 71 | 72 | - name: Build documentation 73 | run: cabal haddock all 74 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.cabal-sandbox/ 2 | /cabal.sandbox.config 3 | /dist/ 4 | /dist-newstyle/ 5 | /test/test-keys 6 | /.stack-work/ 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # make_travis_yml_2.hs 'servant-github-webhook.cabal' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | sudo: false 8 | 9 | cache: 10 | directories: 11 | - $HOME/.stack 12 | 13 | before_install: 14 | # Download and unpack the stack executable 15 | - mkdir -p ~/.local/bin 16 | - export PATH=$HOME/.local/bin:$PATH 17 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 18 | 19 | install: 20 | - stack --version 21 | - stack --no-terminal build 22 | 23 | # Here starts the actual work to be performed for the package under test; 24 | # any command which exits with a non-zero exit code causes the build to fail. 25 | script: 26 | - stack --no-terminal --skip-ghc-check test 27 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | All contributions are welcome! Just submit a PR and try to preserve the 2 | existing code style. 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for servant-github-webhook 2 | 3 | ## 0.4.2.0 -- 2019-08-21 4 | 5 | * Add some more Reflect instances 6 | 7 | ## 0.4.1.0 -- 2018-04-07 8 | 9 | * Include integration with github-webhooks package. 10 | * Code is adjusted for backwards-compatibility with GHC 7.10. 11 | * `HasServer` instances are updated for servant-0.13 or later, due to `hoistServerWithContext`. 12 | 13 | ## 0.4.0.0 -- 2018-02-03 14 | 15 | * Use constant-time equality to check signatures. 16 | * Add dynamic key capabilities. 17 | 18 | ## 0.3.2.0 -- 2017-12-25 19 | 20 | * Support GHC 8.2 / `base` 4.10. 21 | * Bump up version bound for `github` to 0.18. 22 | 23 | ## 0.3.1.0 -- 2017-08-06 24 | 25 | * Drop support for GHC <8. 26 | * Drop support for Servant <0.11. 27 | * Switch from Crypto package to cryptonite package. 28 | * Now servant-github-webhook builds with stack. 29 | 30 | ## 0.3.0.0 -- 2016-09-22 31 | 32 | * Pass reflected key index to the handler function for GitHubSignedReqBody. 33 | This allows for more generic handler functions, as they can determine 34 | programmatically which repository they are responding to. 35 | 36 | ## 0.2.0.1 -- 2016-09-13 37 | 38 | * Improve documentation (formatting and typos) and examples (remove unnecessary 39 | verbosity). 40 | 41 | ## 0.2.0.0 -- 2016-09-11 42 | 43 | * Generalize `GitHubSignedReqBody` combinator to `GitHubSignedReqBody''` to 44 | allow for configuring multiple signing keys, on a per-route basis. 45 | * Make `GitHubKey` take a function instead of simply an `IO` action. 46 | * Reexport `KProxy`, to make writing `Demote'` instances easier. 47 | 48 | ## 0.1.0.0 -- 2016-09-10 49 | 50 | Initial release. 51 | 52 | * Implement `GitHubSignedReqBody` combinator for automatic signature 53 | verification during routing. 54 | * Implement `GitHubEvent` combinator for dispatching to routes based on the 55 | webhook type. 56 | * Known issue: only one global `GitHubKey` can be used across all routes. 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Jacob Thomas Errington 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | servant-github-webhook 2 | ====================== 3 | 4 | [![Build status](https://github.com/tsani/servant-github-webhook/actions/workflows/cabal.yml/badge.svg)](https://github.com/tsani/servant-github-webhook/actions/workflows/cabal.yml) 5 | [![Build Status][badge-travis]][travis] 6 | [![Hackage][badge-hackage]][hackage] 7 | [![servant-github-webhook][badge-stackage-lts]][stackage-lts] 8 | [![servant-github-webhook][badge-stackage-nightly]][stackage-nightly] 9 | 10 | This library facilitates writing Servant routes that can safely act as GitHub 11 | webhooks. 12 | 13 | Features: 14 | 15 | * Dispatching to routes based on the type of repository event. 16 | * Automatic verification of request signatures. 17 | * Route protection expressed in the type system, so webhook routes and 18 | regular routes cannot be confused. 19 | 20 | Why use servant-github-webhook? 21 | ------------------------------- 22 | 23 | A webhook server needs to be publicly hosted. How can legitimate requests sent 24 | by GitHub be distinguished from (malicious) requests sent by other clients? 25 | 26 | When a webhook is configured on a repository, a *secret key* is added. This key 27 | is used by GitHub to compute a *signature* of the request body that it sends; 28 | this signature is included in the request headers. The routing combinators in 29 | servant-github-webhook compute the signature of the received request body using 30 | the same key, and check that the signature in the request headers matches. If 31 | it does, then the request is legitimate. 32 | 33 | [hackage]: https://hackage.haskell.org/package/servant-github-webhook 34 | [badge-hackage]: https://img.shields.io/hackage/v/servant-github-webhook.svg 35 | [travis]: https://travis-ci.org/tsani/servant-github-webhook?branch=master 36 | [badge-travis]: https://travis-ci.org/tsani/servant-github-webhook.svg?branch=master 37 | 38 | [badge-stackage-lts]: http://stackage.org/package/servant-github-webhook/badge/lts 39 | [stackage-lts]: https://stackage.org/lts/package/servant-github-webhook 40 | [badge-stackage-nightly]: http://stackage.org/package/servant-github-webhook/badge/nightly 41 | [stackage-nightly]: http://stackage.org/nightly/package/servant-github-webhook 42 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /servant-github-webhook.cabal: -------------------------------------------------------------------------------- 1 | -- Initial servant-github-webhook.cabal generated by cabal init. For 2 | -- further documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: servant-github-webhook 5 | version: 0.4.2.0 6 | synopsis: Servant combinators to facilitate writing GitHub webhooks. 7 | description: 8 | This package provides servant combinators that make writing safe GitHub 9 | webhooks very simple. 10 | . 11 | It features automatic verification of the digital signatures provided by 12 | GitHub in the webhook HTTP requests as well as route dispatching based on 13 | repository event type. 14 | homepage: https://github.com/tsani/servant-github-webhook 15 | license: MIT 16 | license-file: LICENSE 17 | author: Jacob Thomas Errington 18 | maintainer: servant-github-webhook@mail.jerrington.me 19 | copyright: Jacob Thomas Errington (c) 2016-2018 20 | category: Web 21 | build-type: Simple 22 | tested-with: GHC == 8.6.5 23 | extra-source-files: 24 | ChangeLog.md 25 | README.md 26 | stack.yaml 27 | cabal-version: >=1.10 28 | bug-reports: https://github.com/tsani/servant-github-webhook/issues 29 | 30 | source-repository head 31 | type: git 32 | location: https://github.com/tsani/servant-github-webhook.git 33 | 34 | library 35 | exposed-modules: 36 | Servant.GitHub.Webhook 37 | hs-source-dirs: src 38 | default-language: Haskell2010 39 | ghc-options: 40 | -Wall 41 | build-depends: 42 | base ==4.*, 43 | aeson >=2.0.1.0, 44 | base16-bytestring >=0.1, 45 | bytestring >= 0.10, 46 | cryptonite >=0.19, 47 | github >=0.15, 48 | github-webhooks >=0.12, 49 | http-types >=0.9, 50 | unordered-containers >= 0.2, 51 | memory >=0.13, 52 | servant >=0.13, 53 | servant-server >=0.13, 54 | string-conversions >=0.4, 55 | text >=1.2, 56 | transformers, 57 | wai >=3.2 58 | 59 | test-suite multikey 60 | type: exitcode-stdio-1.0 61 | ghc-options: 62 | -Wall 63 | hs-source-dirs: test/multikey 64 | main-is: Main.hs 65 | default-language: Haskell2010 66 | build-depends: 67 | aeson, 68 | base, 69 | bytestring, 70 | servant-server, 71 | servant-github-webhook, 72 | wai, 73 | warp, 74 | transformers 75 | 76 | test-suite singlekey 77 | type: exitcode-stdio-1.0 78 | ghc-options: 79 | -Wall 80 | hs-source-dirs: test/singlekey 81 | main-is: Main.hs 82 | default-language: Haskell2010 83 | build-depends: 84 | aeson, 85 | base, 86 | bytestring, 87 | servant-server, 88 | servant-github-webhook, 89 | wai, 90 | warp, 91 | transformers 92 | 93 | test-suite dynamickey 94 | type: exitcode-stdio-1.0 95 | ghc-options: 96 | -Wall 97 | hs-source-dirs: test/dynamickey 98 | main-is: Main.hs 99 | default-language: Haskell2010 100 | build-depends: 101 | aeson, 102 | base, 103 | bytestring, 104 | servant-server, 105 | servant-github-webhook, 106 | text, 107 | wai, 108 | warp, 109 | transformers 110 | -------------------------------------------------------------------------------- /src/Servant/GitHub/Webhook.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Servant.GitHub.Webhook 3 | Description : Easily write safe GitHub webhook handlers with Servant 4 | Copyright : (c) Jacob Thomas Errington, 2016 5 | License : MIT 6 | Maintainer : servant-github-webhook@mail.jerrington.me 7 | Stability : experimental 8 | 9 | The GitHub webhook machinery will attach three headers to the HTTP requests 10 | that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. 11 | The former two headers correspond with the 'GitHubEvent' and 12 | 'GitHubSignedReqBody''' routing combinators. This library ignores the 13 | @X-Github-Delivery@ header; if you would like to access its value, then use the 14 | builtin 'Header' combinator from Servant. 15 | 16 | Usage of the library is straightforward: protect routes with the 'GitHubEvent' 17 | combinator to ensure that the route is only reached for specific 18 | 'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write 19 | under that route with 'GitHubSignedReqBody'. It is advised to always include a 20 | 'GitHubSignedReqBody''', as this is the only way you can be sure that it is 21 | GitHub who is sending the request, and not a malicious user. If you don't care 22 | about the request body, then simply use Aeson\'s 'Object' type as the 23 | deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and 24 | ignore the @Object@ in the handler. 25 | 26 | The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in 27 | order to extract the signing key. This is the same key that must be entered in 28 | the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. 29 | 30 | In order to support multiple keys on a per-route basis, the basic combinator 31 | @GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, 32 | create a datatype, e.g. @KeyIndex@ whose constructors identify the different 33 | keys you will be using. Generally, this means one constructor per repository. 34 | Use the @DataKinds@ extension to promote this datatype to a kind, and write an 35 | instance of 'Reflect' for each promoted constructor of your datatype. Finally, 36 | create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is 37 | the datatype you've built up. Thus, your function can determine which key to 38 | retrieve. 39 | -} 40 | 41 | {-# LANGUAGE DataKinds #-} 42 | {-# LANGUAGE FlexibleContexts #-} 43 | {-# LANGUAGE FlexibleInstances #-} 44 | {-# LANGUAGE GADTs #-} 45 | {-# LANGUAGE KindSignatures #-} 46 | {-# LANGUAGE InstanceSigs #-} 47 | {-# LANGUAGE MultiParamTypeClasses #-} 48 | {-# LANGUAGE OverloadedStrings #-} 49 | {-# LANGUAGE PartialTypeSignatures #-} 50 | {-# LANGUAGE PolyKinds #-} 51 | {-# LANGUAGE ScopedTypeVariables #-} 52 | {-# LANGUAGE TypeFamilies #-} 53 | {-# LANGUAGE TypeOperators #-} 54 | {-# LANGUAGE UndecidableInstances #-} 55 | 56 | module Servant.GitHub.Webhook 57 | ( -- * Servant combinators 58 | GitHubSignedReqBody'' 59 | , GitHubSignedReqBody' 60 | , GitHubSignedReqBody 61 | , GitHubEvent 62 | 63 | -- ** Security 64 | , GitHubKey'(..) 65 | , GitHubKey 66 | , gitHubKey 67 | , dynamicKey 68 | , repositoryKey, HasRepository 69 | , EventWithHookRepo(..) 70 | 71 | -- * Reexports 72 | -- 73 | -- | We reexport a few datatypes that are typically needed to use the 74 | -- library. 75 | , RepoWebhookEvent(..) 76 | , KProxy(..) 77 | 78 | -- * Implementation details 79 | 80 | -- ** Type-level programming machinery 81 | , Demote 82 | , Demote' 83 | , Reflect(..) 84 | 85 | -- ** Stringy stuff 86 | , parseHeaderMaybe 87 | , matchEvent 88 | ) where 89 | 90 | import Control.Monad.IO.Class ( liftIO ) 91 | import Crypto.Hash.Algorithms ( SHA1 ) 92 | import Crypto.MAC.HMAC ( hmac, HMAC(..) ) 93 | import Data.Aeson ( decode', encode, Value(String, Object) ) 94 | import qualified Data.Aeson as Aeson 95 | import qualified Data.Aeson.Types as AesonType 96 | import qualified Data.Aeson.KeyMap as AesonKeyMap 97 | import Data.ByteArray ( convert, constEq ) 98 | import qualified Data.Text as T 99 | import qualified Data.ByteString as BS 100 | import Data.ByteString.Lazy ( fromStrict, toStrict ) 101 | import qualified Data.ByteString.Base16 as B16 102 | import Data.List ( intercalate ) 103 | import Data.Maybe ( catMaybes, fromMaybe ) 104 | import Data.Monoid ( (<>) ) 105 | import Data.Proxy 106 | import Data.String.Conversions ( cs ) 107 | import qualified Data.Text.Encoding as E 108 | import GHC.TypeLits 109 | import GitHub.Data.Webhooks 110 | import GitHub.Data.Webhooks.Events (EventHasRepo(..)) -- github-webhooks package 111 | import GitHub.Data.Webhooks.Payload (whRepoFullName) -- github-webhooks package 112 | import Network.HTTP.Types hiding (Header, ResponseHeaders) 113 | import Network.Wai ( requestHeaders, strictRequestBody ) 114 | import Servant 115 | import Servant.API.ContentTypes ( AllCTUnrender(..) ) 116 | import Servant.Server.Internal 117 | 118 | 119 | -- | A clone of Servant's 'ReqBody' combinator, except that it will also 120 | -- verify the signature provided by GitHub in the @X-Hub-Signature@ header by 121 | -- computing the SHA1 HMAC of the request body and comparing. 122 | -- 123 | -- The use of this combinator will require that the router context contain an 124 | -- appropriate 'GitHubKey'' entry. Specifically, the type parameter of 125 | -- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the 126 | -- index @key@ used here. Consequently, it will be necessary to use 127 | -- 'serveWithContext' instead of 'serve'. 128 | -- 129 | -- Other routes are not tried upon the failure of this combinator, and a 401 130 | -- response is generated. 131 | -- 132 | -- Use of this datatype directly is discouraged, since the choice of the index 133 | -- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use 134 | -- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just 135 | -- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for 136 | -- the implementation of the 'HasServer' instance for the datatype. 137 | data GitHubSignedReqBody'' 138 | (proxy :: KProxy k) 139 | (key :: k) 140 | (list :: [*]) 141 | (result :: *) where 142 | 143 | -- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first 144 | -- type argument given just the second one. 145 | -- 146 | -- Use this type synonym if you are creating a webhook server to handle 147 | -- webhooks from multiple repositories, with different secret keys. 148 | type GitHubSignedReqBody' (key :: k) 149 | = GitHubSignedReqBody'' ('KProxy :: KProxy k) key 150 | 151 | -- | A convenient alias for a trivial key index. 152 | -- 153 | -- USe this type synonym if you are creating a webhook server to handle only 154 | -- webhooks from a single repository, or for mutliple repositories using the 155 | -- same secret key. 156 | type GitHubSignedReqBody = GitHubSignedReqBody' '() 157 | 158 | -- | A routing combinator that succeeds only for a webhook request that matches 159 | -- one of the given 'RepoWebhookEvent' given in the type-level list @events@. 160 | -- 161 | -- If the list contains 'WebhookWildcardEvent', then all events will be 162 | -- matched. 163 | -- 164 | -- The combinator will require that its associated handler take a 165 | -- 'RepoWebhookEvent' parameter, and the matched event will be passed to the 166 | -- handler. This allows the handler to determine which event triggered it from 167 | -- the list. 168 | -- 169 | -- Other routes are tried if there is a mismatch. 170 | data GitHubEvent (events :: [RepoWebhookEvent]) where 171 | 172 | -- | A wrapper for an IO strategy to obtain the signing key for the webhook as 173 | -- configured in GitHub. The strategy is executed each time the 174 | -- 'GitHubSignedReqBody''s routing logic is executed. 175 | -- 176 | -- We allow the use of @IO@ here so that you can fetch the key from a cache or 177 | -- a database. If the key is a constant or read only once, just use 'pure'. 178 | -- 179 | -- The type @key@ used here must correspond with @'Demote' k@ where @k@ is the 180 | -- kind whose types are used as indices in 'GitHubSignedReqBody''. 181 | -- 182 | -- If you don't care about indices and just want to write a webhook using a 183 | -- global key, see 'GitHubKey' which fixes @key@ to @()@ and use 'gitHubKey', 184 | -- which fills the newtype with a constant function. 185 | newtype GitHubKey' key result = GitHubKey { unGitHubKey :: key -> result -> IO (Maybe BS.ByteString) } 186 | 187 | -- | A synonym for strategies producing so-called /global/ keys, in which the 188 | -- key index is simply @()@. 189 | type GitHubKey result = GitHubKey' () result 190 | 191 | -- | Smart constructor for 'GitHubKey', for a so-called /global/ key. 192 | gitHubKey :: IO BS.ByteString -> GitHubKey result 193 | gitHubKey f = GitHubKey (\_ _ -> Just <$> f) 194 | 195 | -- | @dynamicKey keyLookup keyIdLookup@ acquires the key identifier, such as 196 | -- repository or user name, from the result then uses @keyLookup@ to acquire the 197 | -- key (or @Nothing@). 198 | -- 199 | -- Dynamic keys allow servers to specify per-user repository keys. This 200 | -- limits the impact of compromized keys and allows the server to acquire the 201 | -- key from external sources, such as a live configuration or per-user rows 202 | -- in a database. 203 | dynamicKey 204 | :: (T.Text -> IO (Maybe BS.ByteString)) 205 | -> (result -> Maybe T.Text) 206 | -> GitHubKey result 207 | dynamicKey f lk = GitHubKey (\_ r -> maybe (pure Nothing) f (lk r)) 208 | 209 | repositoryKey 210 | :: HasRepository result 211 | => (T.Text -> IO (Maybe BS.ByteString)) 212 | -> GitHubKey result 213 | repositoryKey f = dynamicKey f getFullName 214 | 215 | -- | The HasRepository class helps extract the full (unique) "name/repo" of a 216 | -- repository, allowing easy lookup of a per-repository key or, using @takeWhile 217 | -- (/='/')@, lookup of per user keys. 218 | class HasRepository r where 219 | -- | Extract the @repository.full_name@ field of github json web events. 220 | getFullName:: r -> Maybe T.Text 221 | 222 | instance HasRepository Value where 223 | getFullName (Object o) = getFullName o 224 | getFullName _ = Nothing 225 | 226 | instance HasRepository AesonType.Object where 227 | getFullName o = 228 | do Object r <- AesonKeyMap.lookup "repository" o 229 | String n <- AesonKeyMap.lookup "full_name" r 230 | pure n 231 | 232 | -- |For use with 'github-webhooks' package types. Routes would look like: 233 | -- 234 | -- @ 235 | -- api = "github-webevent" :> 236 | -- :> GitHubSignedReqBody '[JSON] (EventWithHookRepo IssuesEvent) 237 | -- :> Post '[JSON] () 238 | -- @ 239 | -- 240 | -- And the handler would unwrap the event: 241 | -- 242 | -- @ 243 | -- handler :: EventWithHookRepo IssuesEvent -> Handler () 244 | -- handler (eventOf -> e) = -- ... expr handling e :: IssuesEvent ... 245 | -- @ 246 | newtype EventWithHookRepo e = EventWithHookRepo { eventOf :: e } 247 | 248 | instance Aeson.FromJSON e => Aeson.FromJSON (EventWithHookRepo e) where 249 | parseJSON o = EventWithHookRepo <$> Aeson.parseJSON o 250 | 251 | instance EventHasRepo e => HasRepository (EventWithHookRepo e) where 252 | getFullName = Just . whRepoFullName . repoForEvent . eventOf 253 | 254 | instance 255 | ( HasServer sublayout context 256 | , HasContextEntry context (GitHubKey' (Demote key) result) 257 | , Reflect key 258 | , AllCTUnrender list result 259 | ) 260 | => HasServer 261 | (GitHubSignedReqBody'' ('KProxy :: KProxy k) key list result :> sublayout) 262 | context where 263 | 264 | type ServerT 265 | (GitHubSignedReqBody'' ('KProxy :: KProxy k) key list result :> sublayout) 266 | m 267 | = (Demote key, result) -> ServerT sublayout m 268 | 269 | hoistServerWithContext _ _ f s = \p -> hoistServerWithContext p1 p2 f (s p) where 270 | p1 = Proxy :: Proxy sublayout 271 | p2 = Proxy :: Proxy context 272 | 273 | route 274 | :: forall env. 275 | Proxy ( 276 | GitHubSignedReqBody'' ('KProxy :: KProxy k) key list result 277 | :> sublayout 278 | ) 279 | -> Context context 280 | -> Delayed env ((Demote key, result) -> Server sublayout) 281 | -> Router env 282 | route _ context subserver 283 | = route (Proxy :: Proxy sublayout) context (addBodyCheck subserver ct go) 284 | where 285 | lookupSig = lookup "X-Hub-Signature" 286 | 287 | keyIndex :: Demote key 288 | keyIndex = reflect (Proxy :: Proxy key) 289 | 290 | ct :: DelayedIO (BS.ByteString, Maybe BS.ByteString, result) 291 | ct = withRequest $ \req -> do 292 | let hdrs = requestHeaders req 293 | let contentTypeH = 294 | fromMaybe "application/octet-stream" $ lookup hContentType hdrs 295 | 296 | msg <- liftIO (toStrict <$> strictRequestBody req) 297 | 298 | let mrqbody = 299 | handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) $ 300 | fromStrict msg 301 | 302 | case mrqbody of 303 | Nothing -> delayedFailFatal err415 304 | Just (Left e) -> delayedFailFatal err400 { errBody = cs e } 305 | Just (Right v) -> pure (msg, lookupSig hdrs, v) 306 | 307 | go 308 | :: (BS.ByteString, Maybe BS.ByteString, result) 309 | -> DelayedIO (Demote key, result) 310 | go tup@(_msg, _hdr, v) = do 311 | keyM <- liftIO (unGitHubKey (getContextEntry context) keyIndex v) 312 | case keyM of 313 | Nothing -> delayedFailFatal err401 314 | Just key -> verifySigWithKey tup key 315 | 316 | verifySigWithKey 317 | :: (BS.ByteString, Maybe BS.ByteString, result) 318 | -> BS.ByteString 319 | -> DelayedIO (Demote key, result) 320 | verifySigWithKey (msg, hdr, v) key = do 321 | let sig = 322 | B16.encode $ convert $ hmacGetDigest (hmac key msg :: HMAC SHA1) 323 | 324 | case parseHeaderMaybe =<< hdr of 325 | Nothing -> delayedFailFatal err401 326 | Just h -> do 327 | let h' = BS.drop 5 $ E.encodeUtf8 h -- remove "sha1=" prefix 328 | if constEq h' sig 329 | then pure (keyIndex, v) 330 | else delayedFailFatal err401 331 | 332 | instance 333 | (Reflect events, HasServer sublayout context) 334 | => HasServer (GitHubEvent events :> sublayout) context where 335 | 336 | type ServerT (GitHubEvent events :> sublayout) m 337 | = RepoWebhookEvent -> ServerT sublayout m 338 | 339 | hoistServerWithContext _ _ f s = \p -> hoistServerWithContext p1 p2 f (s p) where 340 | p1 = Proxy :: Proxy sublayout 341 | p2 = Proxy :: Proxy context 342 | 343 | route 344 | :: forall env. Proxy (GitHubEvent events :> sublayout) 345 | -> Context context 346 | -> Delayed env (RepoWebhookEvent -> Server sublayout) 347 | -> Router env 348 | route Proxy context subserver 349 | = route 350 | (Proxy :: Proxy sublayout) 351 | context 352 | (addAuthCheck subserver go) 353 | where 354 | lookupGHEvent = lookup "X-Github-Event" 355 | 356 | events :: [RepoWebhookEvent] 357 | events = reflect (Proxy :: Proxy events) 358 | 359 | eventNames :: String 360 | eventNames = intercalate ", " $ (cs . encode) <$> events 361 | 362 | go :: DelayedIO RepoWebhookEvent 363 | go = withRequest $ \req -> do 364 | case lookupGHEvent (requestHeaders req) of 365 | Nothing -> delayedFail err401 366 | Just h -> do 367 | case catMaybes $ map (`matchEvent` h) events of 368 | [] -> delayedFail err404 369 | { errBody = cs $ "supported events: " <> eventNames } 370 | (event:_) -> pure event 371 | 372 | -- | Type function that reflects a kind to a type. 373 | type family Demote' (kparam :: KProxy k) :: * 374 | 375 | -- | Convient alias for 'Demote'' that allows us to avoid using 'KProxy' 376 | -- explicitly. 377 | type Demote (a :: k) = Demote' ('KProxy :: KProxy k) 378 | 379 | type instance Demote' ('KProxy :: KProxy ()) = () 380 | type instance Demote' ('KProxy :: KProxy Symbol) = String 381 | type instance Demote' ('KProxy :: KProxy [k]) = [Demote' ('KProxy :: KProxy k)] 382 | type instance Demote' ('KProxy :: KProxy RepoWebhookEvent) = RepoWebhookEvent 383 | 384 | -- | Class of types that can be reflected to values. 385 | class Reflect (a :: k) where 386 | reflect :: Proxy (a :: k) -> Demote a 387 | 388 | instance KnownSymbol s => Reflect (s :: Symbol) where 389 | reflect = symbolVal 390 | 391 | instance Reflect '() where 392 | reflect _ = () 393 | 394 | instance Reflect '[] where 395 | reflect _ = [] 396 | 397 | instance (Reflect x, Reflect xs) => Reflect (x ': xs) where 398 | reflect _ = reflect x : reflect xs where 399 | x = Proxy :: Proxy x 400 | xs = Proxy :: Proxy xs 401 | 402 | instance Reflect 'WebhookWildcardEvent where 403 | reflect _ = WebhookWildcardEvent 404 | 405 | instance Reflect 'WebhookCheckSuiteEvent where 406 | reflect _ = WebhookCheckSuiteEvent 407 | 408 | instance Reflect 'WebhookCheckRunEvent where 409 | reflect _ = WebhookCheckRunEvent 410 | 411 | instance Reflect 'WebhookCommitCommentEvent where 412 | reflect _ = WebhookCommitCommentEvent 413 | 414 | instance Reflect 'WebhookCreateEvent where 415 | reflect _ = WebhookCreateEvent 416 | 417 | instance Reflect 'WebhookDeleteEvent where 418 | reflect _ = WebhookDeleteEvent 419 | 420 | instance Reflect 'WebhookDeploymentEvent where 421 | reflect _ = WebhookDeploymentEvent 422 | 423 | instance Reflect 'WebhookDeploymentStatusEvent where 424 | reflect _ = WebhookDeploymentStatusEvent 425 | 426 | instance Reflect 'WebhookForkEvent where 427 | reflect _ = WebhookForkEvent 428 | 429 | instance Reflect 'WebhookGollumEvent where 430 | reflect _ = WebhookGollumEvent 431 | 432 | instance Reflect 'WebhookInstallationEvent where 433 | reflect _ = WebhookInstallationEvent 434 | 435 | instance Reflect 'WebhookRepositoryEvent where 436 | reflect _ = WebhookRepositoryEvent 437 | 438 | instance Reflect 'WebhookInstallationRepositoriesEvent where 439 | reflect _ = WebhookInstallationRepositoriesEvent 440 | 441 | instance Reflect 'WebhookIssueCommentEvent where 442 | reflect _ = WebhookIssueCommentEvent 443 | 444 | instance Reflect 'WebhookIssuesEvent where 445 | reflect _ = WebhookIssuesEvent 446 | 447 | instance Reflect 'WebhookMemberEvent where 448 | reflect _ = WebhookMemberEvent 449 | 450 | instance Reflect 'WebhookPageBuildEvent where 451 | reflect _ = WebhookPageBuildEvent 452 | 453 | instance Reflect 'WebhookPingEvent where 454 | reflect _ = WebhookPingEvent 455 | 456 | instance Reflect 'WebhookPublicEvent where 457 | reflect _ = WebhookPublicEvent 458 | 459 | instance Reflect 'WebhookPullRequestReviewCommentEvent where 460 | reflect _ = WebhookPullRequestReviewCommentEvent 461 | 462 | instance Reflect 'WebhookPullRequestEvent where 463 | reflect _ = WebhookPullRequestEvent 464 | 465 | instance Reflect 'WebhookPushEvent where 466 | reflect _ = WebhookPushEvent 467 | 468 | instance Reflect 'WebhookReleaseEvent where 469 | reflect _ = WebhookReleaseEvent 470 | 471 | instance Reflect 'WebhookStatusEvent where 472 | reflect _ = WebhookStatusEvent 473 | 474 | instance Reflect 'WebhookTeamAddEvent where 475 | reflect _ = WebhookTeamAddEvent 476 | 477 | instance Reflect 'WebhookWatchEvent where 478 | reflect _ = WebhookWatchEvent 479 | 480 | -- | Helper that parses a header using a 'FromHttpApiData' instance and 481 | -- discards the parse error message if any. 482 | parseHeaderMaybe :: FromHttpApiData a => BS.ByteString -> Maybe a 483 | parseHeaderMaybe = eitherMaybe . parseHeader where 484 | eitherMaybe :: Either e a -> Maybe a 485 | eitherMaybe e = case e of 486 | Left _ -> Nothing 487 | Right x -> Just x 488 | 489 | -- | Determines whether a given webhook event matches a given raw 490 | -- representation of one. The result is 'Nothing' if there is no match. This 491 | -- function accounts for the 'WebhookWildcardEvent' matching everything, so it 492 | -- returns the result of parsing the raw representation when trying to match 493 | -- against the wildcard. 494 | matchEvent :: RepoWebhookEvent -> BS.ByteString -> Maybe RepoWebhookEvent 495 | matchEvent WebhookWildcardEvent s = decode' (fromStrict s') where 496 | s' = "\"" <> s <> "\"" 497 | matchEvent e name 498 | | toStrict (encode e) == name' = Just e 499 | | otherwise = Nothing 500 | where name' = "\"" <> name <> "\"" 501 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.1 2 | 3 | extra-deps: 4 | - github-0.22 5 | - binary-instances-1 6 | - github-webhooks-0.12.0 7 | -------------------------------------------------------------------------------- /test/dynamickey/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | import Control.Monad.IO.Class ( liftIO ) 6 | import Data.Aeson ( Object ) 7 | import Data.Monoid 8 | import qualified Data.ByteString as BS 9 | import qualified Data.ByteString.Char8 as C8 10 | import Servant 11 | import Servant.GitHub.Webhook 12 | import Network.Wai ( Application ) 13 | import Network.Wai.Handler.Warp ( run ) 14 | import qualified Data.Text.Encoding as T 15 | 16 | main :: IO () 17 | main = pure () 18 | 19 | realMain :: IO () 20 | realMain = do 21 | [key, _] <- C8.lines <$> BS.readFile "test/test-keys" 22 | run 8080 (app (repositoryKey $ \user -> pure $ Just (T.encodeUtf8 user <> key))) 23 | 24 | app :: GitHubKey Object -> Application 25 | app key 26 | = serveWithContext 27 | (Proxy :: Proxy API) 28 | (key :. EmptyContext) 29 | server 30 | 31 | server :: Server API 32 | server = anyEvent 33 | 34 | anyEvent :: RepoWebhookEvent -> ((), Object) -> Handler () 35 | anyEvent e _ 36 | = liftIO $ putStrLn $ "got event: " ++ show e 37 | 38 | type API 39 | = "repo1" 40 | :> GitHubEvent '[ 'WebhookPushEvent ] 41 | :> GitHubSignedReqBody '[JSON] Object 42 | :> Post '[JSON] () 43 | -------------------------------------------------------------------------------- /test/multikey/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Main 6 | ( main 7 | ) where 8 | 9 | import Control.Monad.IO.Class ( liftIO ) 10 | import Data.Aeson ( Object ) 11 | import qualified Data.ByteString as BS 12 | import qualified Data.ByteString.Char8 as C8 13 | import Network.Wai ( Application ) 14 | import Network.Wai.Handler.Warp ( run ) 15 | import Servant 16 | import Servant.GitHub.Webhook 17 | 18 | -- | Entry point for travis. 19 | -- We don't actually have automated tests, so we use a dummy main for travis, 20 | -- so that /running/ the tests passes, but compiling may not. 21 | main :: IO () 22 | main = pure () 23 | 24 | realMain :: IO () 25 | realMain = do 26 | [k1, k2] <- C8.lines <$> BS.readFile "test/test-keys" 27 | run 8080 (app (constKeys k1 k2)) 28 | 29 | app :: MyGitHubKey -> Application 30 | app k = serveWithContext api (k :. EmptyContext) server 31 | 32 | server :: Server WebhookApi 33 | server = (repo1ping :<|> repo1any) :<|> repo2any 34 | 35 | repo1ping :: RepoWebhookEvent -> (Key, Object) -> Handler () 36 | repo1ping _ _ = liftIO $ putStrLn "got ping on repo1!" 37 | 38 | repo1any :: RepoWebhookEvent -> (Key, Object) -> Handler () 39 | repo1any e _ = liftIO $ putStrLn $ "got event on repo 1: " ++ show e 40 | 41 | repo2any :: RepoWebhookEvent -> (Key, Object) -> Handler () 42 | repo2any e _ = liftIO $ putStrLn $ "got event on repo 2: " ++ show e 43 | 44 | api :: Proxy WebhookApi 45 | api = Proxy 46 | 47 | type WebhookApi 48 | = "repo1" :> ( 49 | GitHubEvent '[ 'WebhookPingEvent ] 50 | :> GitHubSignedReqBody' 'Repo1 '[JSON] Object 51 | :> Post '[JSON] () 52 | :<|> 53 | GitHubEvent '[ 'WebhookWildcardEvent ] 54 | :> GitHubSignedReqBody' 'Repo1 '[JSON] Object 55 | :> Post '[JSON] () 56 | ) 57 | :<|> 58 | "repo2" 59 | :> GitHubEvent '[ 'WebhookWildcardEvent ] 60 | :> GitHubSignedReqBody' 'Repo2 '[JSON] Object 61 | :> Post '[JSON] () 62 | 63 | type MyGitHubKey = GitHubKey' Key Object 64 | 65 | data Key 66 | = Repo1 67 | | Repo2 68 | 69 | constKeys :: BS.ByteString -> BS.ByteString -> MyGitHubKey 70 | constKeys k1 k2 = GitHubKey $ \k _ -> pure $ case k of 71 | Repo1 -> Just k1 72 | Repo2 -> Just k2 73 | 74 | type instance Demote' ('KProxy :: KProxy Key) = Key 75 | instance Reflect 'Repo1 where 76 | reflect _ = Repo1 77 | instance Reflect 'Repo2 where 78 | reflect _ = Repo2 79 | -------------------------------------------------------------------------------- /test/singlekey/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | import Control.Monad.IO.Class ( liftIO ) 6 | import Data.Aeson ( Object ) 7 | import qualified Data.ByteString as BS 8 | import qualified Data.ByteString.Char8 as C8 9 | import Servant 10 | import Servant.GitHub.Webhook 11 | import Network.Wai ( Application ) 12 | import Network.Wai.Handler.Warp ( run ) 13 | 14 | main :: IO () 15 | main = pure () 16 | 17 | realMain :: IO () 18 | realMain = do 19 | [key, _] <- C8.lines <$> BS.readFile "test/test-keys" 20 | run 8080 (app (gitHubKey $ pure key)) 21 | 22 | app :: GitHubKey Object -> Application 23 | app key 24 | = serveWithContext 25 | (Proxy :: Proxy API) 26 | (key :. EmptyContext) 27 | server 28 | 29 | server :: Server API 30 | server = anyEvent 31 | 32 | anyEvent :: RepoWebhookEvent -> ((), Object) -> Handler () 33 | anyEvent e _ 34 | = liftIO $ putStrLn $ "got event: " ++ show e 35 | 36 | type API 37 | = "repo1" 38 | :> GitHubEvent '[ 'WebhookPushEvent ] 39 | :> GitHubSignedReqBody '[JSON] Object 40 | :> Post '[JSON] () 41 | --------------------------------------------------------------------------------