diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/servant-github-webhook.cabal b/servant-github-webhook.cabal --- a/servant-github-webhook.cabal +++ b/servant-github-webhook.cabal @@ -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 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 @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,1 +1,4 @@ -resolver: lts-10.0 +resolver: lts-10.3 +extra-deps: + - git: https://github.com/onrock-eng/github-webhooks + commit: 9d5bf07029ed99fca5e53123c7a9c8a8af9819bc diff --git a/test/dynamickey/Main.hs b/test/dynamickey/Main.hs new file mode 100644 --- /dev/null +++ b/test/dynamickey/Main.hs @@ -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] () diff --git a/test/multikey/Main.hs b/test/multikey/Main.hs --- a/test/multikey/Main.hs +++ b/test/multikey/Main.hs @@ -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 diff --git a/test/singlekey/Main.hs b/test/singlekey/Main.hs --- a/test/singlekey/Main.hs +++ b/test/singlekey/Main.hs @@ -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)