servant-github-webhook 0.4.0.0 → 0.4.1.0
raw patch · 5 files changed
+47/−141 lines, 5 filesdep +transformersdep ~cryptonitedep ~memorydep ~servant
Dependencies added: transformers
Dependency ranges changed: cryptonite, memory, servant, servant-server
Files
- ChangeLog.md +6/−0
- README.md +7/−0
- servant-github-webhook.cabal +13/−9
- src/Servant/GitHub/Webhook.hs +20/−128
- stack.yaml +1/−4
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for servant-github-webhook +## 0.4.1.0 -- 2018-04-07++* Include integration with github-webhooks package.+* Code is adjusted for backwards-compatibility with GHC 7.10.+* `HasServer` instances are updated for servant-0.13 or later, due to `hoistServerWithContext`.+ ## 0.4.0.0 -- 2018-02-03 * Use constant-time equality to check signatures.
README.md view
@@ -3,6 +3,8 @@ [![Build Status][badge-travis]][travis] [![Hackage][badge-hackage]][hackage]+[![servant-github-webhook][badge-stackage-lts]][stackage-lts]+[![servant-github-webhook][badge-stackage-nightly]][stackage-nightly] This library facilitates writing Servant routes that can safely act as GitHub webhooks.@@ -31,3 +33,8 @@ [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++[badge-stackage-lts]: http://stackage.org/package/servant-github-webhook/badge/lts+[stackage-lts]: https://stackage.org/lts/package/servant-github-webhook+[badge-stackage-nightly]: http://stackage.org/package/servant-github-webhook/badge/nightly+[stackage-nightly]: http://stackage.org/nightly/package/servant-github-webhook
servant-github-webhook.cabal view
@@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: servant-github-webhook-version: 0.4.0.0+version: 0.4.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 (c) 2016-2018 category: Web build-type: Simple-tested-with: GHC == 8.2.2+tested-with: GHC == 7.10.3, GHC == 8.2.2 extra-source-files: ChangeLog.md README.md@@ -43,16 +43,17 @@ aeson >=0.11, base16-bytestring >=0.1, bytestring >= 0.10,- cryptonite >=0.23,+ cryptonite >=0.19, github >=0.15, github-webhooks >=0.9, http-types >=0.9, unordered-containers >= 0.2,- memory >=0.14,- servant >=0.11,- servant-server >=0.11,+ memory >=0.13,+ servant >=0.13,+ servant-server >=0.13, string-conversions >=0.4, text >=1.2,+ transformers, wai >=3.2 test-suite multikey@@ -69,7 +70,8 @@ servant-server, servant-github-webhook, wai,- warp+ warp,+ transformers test-suite singlekey type: exitcode-stdio-1.0@@ -85,7 +87,8 @@ servant-server, servant-github-webhook, wai,- warp+ warp,+ transformers test-suite dynamickey type: exitcode-stdio-1.0@@ -102,4 +105,5 @@ servant-github-webhook, text, wai,- warp+ warp,+ transformers
src/Servant/GitHub/Webhook.hs view
@@ -49,9 +49,9 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Servant.GitHub.Webhook ( -- * Servant combinators@@ -85,12 +85,6 @@ -- ** Stringy stuff , parseHeaderMaybe , matchEvent-- -- * Examples- --- -- $example1- --- -- $example2 ) where import Control.Monad.IO.Class ( liftIO )@@ -206,10 +200,16 @@ -- limits the impact of compromized keys and allows the server to acquire the -- key from external sources, such as a live configuration or per-user rows -- in a database.-dynamicKey :: (T.Text -> IO (Maybe BS.ByteString)) -> (result -> Maybe T.Text) -> GitHubKey result+dynamicKey+ :: (T.Text -> IO (Maybe BS.ByteString))+ -> (result -> Maybe T.Text)+ -> GitHubKey result dynamicKey f lk = GitHubKey (\_ r -> maybe (pure Nothing) f (lk r)) -repositoryKey :: HasRepository result => (T.Text -> IO (Maybe BS.ByteString)) -> GitHubKey result+repositoryKey+ :: HasRepository result+ => (T.Text -> IO (Maybe BS.ByteString))+ -> GitHubKey result repositoryKey f = dynamicKey f getFullName -- | The HasRepository class helps extract the full (unique) "name/repo" of a@@ -251,7 +251,7 @@ instance EventHasRepo e => HasRepository (EventWithHookRepo e) where getFullName = Just . whRepoFullName . repoForEvent . eventOf -instance forall sublayout context list result (key :: k).+instance ( HasServer sublayout context , HasContextEntry context (GitHubKey' (Demote key) result) , Reflect key@@ -266,6 +266,10 @@ m = (Demote key, result) -> ServerT sublayout m + hoistServerWithContext _ _ f s = \p -> hoistServerWithContext p1 p2 f (s p) where+ p1 = Proxy :: Proxy sublayout+ p2 = Proxy :: Proxy context+ route :: forall env. Proxy (@@ -315,7 +319,7 @@ -> DelayedIO (Demote key, result) verifySigWithKey (msg, hdr, v) key = do let sig =- B16.encode $ convert $ hmacGetDigest $ hmac @_ @_ @SHA1 key msg+ B16.encode $ convert $ hmacGetDigest (hmac key msg :: HMAC SHA1) case parseHeaderMaybe =<< hdr of Nothing -> delayedFailFatal err401@@ -325,13 +329,17 @@ then pure (keyIndex, v) else delayedFailFatal err401 -instance forall sublayout context events.+instance (Reflect events, HasServer sublayout context) => HasServer (GitHubEvent events :> sublayout) context where type ServerT (GitHubEvent events :> sublayout) m = RepoWebhookEvent -> ServerT sublayout m + hoistServerWithContext _ _ f s = \p -> hoistServerWithContext p1 p2 f (s p) where+ p1 = Proxy :: Proxy sublayout+ p2 = Proxy :: Proxy context+ route :: forall env. Proxy (GitHubEvent events :> sublayout) -> Context context@@ -475,119 +483,3 @@ | 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
stack.yaml view
@@ -1,4 +1,1 @@-resolver: lts-10.3-extra-deps:- - git: https://github.com/onrock-eng/github-webhooks- commit: 9d5bf07029ed99fca5e53123c7a9c8a8af9819bc+resolver: nightly-2018-04-05