packages feed

servant-github-webhook 0.3.2.1 → 0.4.0.0

raw patch · 7 files changed

+159/−19 lines, 7 filesdep +github-webhooksdep +unordered-containersdep ~aesondep ~basedep ~bytestring

Dependencies added: github-webhooks, unordered-containers

Dependency ranges changed: aeson, base, bytestring, servant-server, text, wai

Files

ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for servant-github-webhook +## 0.4.0.0  -- 2018-02-03++* Use constant-time equality to check signatures.+* Add dynamic key capabilities.+ ## 0.3.2.0  -- 2017-12-25  * Support GHC 8.2 / `base` 4.10.
servant-github-webhook.cabal view
@@ -1,8 +1,8 @@--- Initial servant-github-webhook.cabal generated by cabal init.  For +-- Initial servant-github-webhook.cabal generated by cabal init.  For -- further documentation, see http://haskell.org/cabal/users-guide/  name:                servant-github-webhook-version:             0.3.2.1+version:             0.4.0.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.0.1, GHC == 8.2.2+tested-with:         GHC == 8.2.2 extra-source-files:   ChangeLog.md   README.md@@ -45,7 +45,9 @@     bytestring >= 0.10,     cryptonite >=0.23,     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,@@ -82,5 +84,22 @@     bytestring,     servant-server,     servant-github-webhook,+    wai,+    warp++test-suite dynamickey+  type:                exitcode-stdio-1.0+  ghc-options:+    -Wall+  hs-source-dirs:      test/dynamickey+  main-is:             Main.hs+  default-language:    Haskell2010+  build-depends:+    aeson,+    base,+    bytestring,+    servant-server,+    servant-github-webhook,+    text,     wai,     warp
src/Servant/GitHub/Webhook.hs view
@@ -64,6 +64,9 @@ , GitHubKey'(..) , GitHubKey , gitHubKey+, dynamicKey+, repositoryKey, HasRepository+, EventWithHookRepo(..)    -- * Reexports   --@@ -93,11 +96,15 @@ 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 Data.Aeson ( decode', encode, Value(String, Object) )+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as AesonType+import Data.ByteArray ( convert, constEq )+import qualified Data.Text as T import qualified Data.ByteString as BS import Data.ByteString.Lazy ( fromStrict, toStrict ) import qualified Data.ByteString.Base16 as B16+import qualified Data.HashMap.Strict as HashMap import Data.List ( intercalate ) import Data.Maybe ( catMaybes, fromMaybe ) import Data.Monoid ( (<>) )@@ -106,6 +113,8 @@ import qualified Data.Text.Encoding as E import GHC.TypeLits import GitHub.Data.Webhooks+import GitHub.Data.Webhooks.Events (EventHasRepo(..)) -- github-webhooks package+import GitHub.Data.Webhooks.Payload (whRepoFullName) -- github-webhooks package import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Wai ( requestHeaders, strictRequestBody ) import Servant@@ -179,19 +188,72 @@ -- 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 }+newtype GitHubKey' key result = GitHubKey { unGitHubKey :: key -> result -> IO (Maybe BS.ByteString) }  -- | A synonym for strategies producing so-called /global/ keys, in which the -- key index is simply @()@.-type GitHubKey = GitHubKey' ()+type GitHubKey result = GitHubKey' () result  -- | Smart constructor for 'GitHubKey', for a so-called /global/ key.-gitHubKey :: IO BS.ByteString -> GitHubKey-gitHubKey = GitHubKey . const+gitHubKey :: IO BS.ByteString -> GitHubKey result+gitHubKey f = GitHubKey (\_ _ -> Just <$> f) +-- | @dynamicKey keyLookup keyIdLookup@ acquires the key identifier, such as+-- repository or user name, from the result then uses @keyLookup@ to acquire the+-- key (or @Nothing@).+--+-- Dynamic keys allow servers to specify per-user repository keys.  This+-- 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 f lk = GitHubKey (\_ r -> maybe (pure Nothing) f (lk r))++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+-- repository, allowing easy lookup of a per-repository key or, using @takeWhile+-- (/='/')@, lookup of per user keys.+class HasRepository r where+    -- | Extract the @repository.full_name@ field of github json web events.+    getFullName:: r -> Maybe T.Text++instance HasRepository Value where+    getFullName (Object o) = getFullName o+    getFullName _ = Nothing++instance HasRepository AesonType.Object where+    getFullName o =+        do Object r <- HashMap.lookup "repository" o+           String n <- HashMap.lookup "full_name" r+           pure n++-- |For use with 'github-webhooks' package types.  Routes would look like:+--+-- @+--      api = "github-webevent" :> +--          :> GitHubSignedReqBody '[JSON] (EventWithHookRepo IssuesEvent)+--          :> Post '[JSON] ()+-- @+--+-- And the handler would unwrap the event:+--+-- @+-- handler :: EventWithHookRepo IssuesEvent -> Handler ()+-- handler (eventOf -> e) = -- ... expr handling e :: IssuesEvent ...+-- @+newtype EventWithHookRepo e = EventWithHookRepo { eventOf :: e }++instance Aeson.FromJSON e => Aeson.FromJSON (EventWithHookRepo e) where+    parseJSON o = EventWithHookRepo <$> Aeson.parseJSON o++instance EventHasRepo e => HasRepository (EventWithHookRepo e) where+    getFullName = Just . whRepoFullName . repoForEvent . eventOf+ instance forall sublayout context list result (key :: k).   ( HasServer sublayout context-  , HasContextEntry context (GitHubKey' (Demote key))+  , HasContextEntry context (GitHubKey' (Demote key) result)   , Reflect key   , AllCTUnrender list result   )@@ -241,8 +303,17 @@       go         :: (BS.ByteString, Maybe BS.ByteString, result)         -> DelayedIO (Demote key, result)-      go (msg, hdr, v) = do-        key <- liftIO (unGitHubKey (getContextEntry context) keyIndex)+      go tup@(_msg, _hdr, v) = do+        keyM <- liftIO (unGitHubKey (getContextEntry context) keyIndex v)+        case keyM of+            Nothing -> delayedFailFatal err401+            Just key -> verifySigWithKey tup key++      verifySigWithKey+            :: (BS.ByteString, Maybe BS.ByteString, result)+            -> BS.ByteString+            -> DelayedIO (Demote key, result)+      verifySigWithKey (msg, hdr, v) key = do         let sig =               B16.encode $ convert $ hmacGetDigest $ hmac @_ @_ @SHA1 key msg @@ -250,7 +321,7 @@           Nothing -> delayedFailFatal err401           Just h -> do             let h' = BS.drop 5 $ E.encodeUtf8 h -- remove "sha1=" prefix-            if h' == sig+            if constEq h' sig             then pure (keyIndex, v)             else delayedFailFatal err401
stack.yaml view
@@ -1,1 +1,4 @@-resolver: lts-10.0+resolver: lts-10.3+extra-deps:+    - git: https://github.com/onrock-eng/github-webhooks+      commit: 9d5bf07029ed99fca5e53123c7a9c8a8af9819bc
+ test/dynamickey/Main.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++import Control.Monad.IO.Class ( liftIO )+import Data.Aeson ( Object )+import Data.Monoid+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 )+import qualified Data.Text.Encoding as T++main :: IO ()+main = pure ()++realMain :: IO ()+realMain = do+  [key, _] <- C8.lines <$> BS.readFile "test/test-keys"+  run 8080 (app (repositoryKey $ \user -> pure $ Just (T.encodeUtf8 user <> key)))++app :: GitHubKey Object -> 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] ()
test/multikey/Main.hs view
@@ -60,16 +60,16 @@       :> GitHubSignedReqBody' 'Repo2 '[JSON] Object       :> Post '[JSON] () -type MyGitHubKey = GitHubKey' Key+type MyGitHubKey = GitHubKey' Key Object  data Key   = Repo1   | Repo2  constKeys :: BS.ByteString -> BS.ByteString -> MyGitHubKey-constKeys k1 k2 = GitHubKey $ \k -> pure $ case k of-  Repo1 -> k1-  Repo2 -> k2+constKeys k1 k2 = GitHubKey $ \k _ -> pure $ case k of+  Repo1 -> Just k1+  Repo2 -> Just k2  type instance Demote' ('KProxy :: KProxy Key) = Key instance Reflect 'Repo1 where
test/singlekey/Main.hs view
@@ -19,7 +19,7 @@   [key, _] <- C8.lines <$> BS.readFile "test/test-keys"   run 8080 (app (gitHubKey $ pure key)) -app :: GitHubKey -> Application+app :: GitHubKey Object -> Application app key   = serveWithContext     (Proxy :: Proxy API)