-- |
-- @travis-ci.com@ webhook authentication middleware.
--
-- See <https://docs.travis-ci.com/user/notifications/#Configuring-webhook-notifications>
-- for more information about webhooks.
--
-- In brief:
--
-- * Configure @travis-ci.com@ to send webhook notifications to your
-- @WAI@-based web server (such as @<https://hackage.haskell.org/package/warp warp>@).
-- * Use the 'authenticate' middleware to reject requests that don't
-- originate from @travis-ci.com@.
--
-- For example,
--
-- > -- In .travis.yml
-- > notifications:
-- > webhooks: http://my-domain.com/my-webhook-path
--
-- @
-- -- In code
-- TravisCI.'authenticate' ["my-webhook-path"]
-- @
--
-- See the bottom of this module for a longer example.
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
{-# language ScopedTypeVariables #-}
module Network.Wai.Middleware.TravisCI
( -- * Authentication
authenticate
-- ** Payload
, payload
-- * Exceptions
, TravisException(..)
-- * Example
-- $example
) where
import Control.Exception (Exception, throwIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Crypto.Hash.Algorithms (SHA1(SHA1))
import Crypto.PubKey.RSA (PublicKey(..))
import Data.Aeson (Value)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Network.HTTP.Types.Method (methodPost)
import Network.HTTP.Types.Status (status401)
import Network.HTTP.Types.URI (urlDecode)
import Network.Wai
(Middleware, Request, pathInfo, requestHeaders, requestMethod,
responseBuilder, strictRequestBody, vault)
import System.IO.Unsafe (unsafePerformIO)
import qualified Crypto.PubKey.RSA.PKCS15 as RSA (verify)
import qualified Data.Aeson as Aeson (decodeStrict)
import qualified Data.ByteString.Base64 as Base64 (decode)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as LazyByteString (stripPrefix, toStrict)
import qualified Data.Vault.Lazy as Vault (Key, insert, lookup, newKey)
-- | Only allow @travis-ci.com@ to @POST@ to the given path.
authenticate :: [Text] -> Middleware
authenticate path app request respond
| pathInfo request == path && requestMethod request == methodPost =
runMaybeT (authenticate_ request) >>= \case
Nothing ->
respond (responseBuilder status401 [] mempty)
Just value ->
let
request' :: Request
request' =
request { vault = Vault.insert vaultKey value (vault request) }
in
app request' respond
| otherwise =
app request respond
authenticate_ :: Request -> MaybeT IO Value
authenticate_ request = do
-- base64-decode the "Signature" header.
Just signature :: Maybe ByteString <-
pure (lookup "Signature" (requestHeaders request))
Right decodedSignature :: Either String ByteString <-
pure (Base64.decode signature)
-- Strip the "payload=" prefix from the request body, and url-decode the rest
-- to JSON (converting '+' to ' ').
body :: Lazy.ByteString <-
lift (strictRequestBody request)
Just body' :: Maybe Lazy.ByteString <-
pure (LazyByteString.stripPrefix "payload=" body)
let blob :: ByteString
blob =
urlDecode True (LazyByteString.toStrict body')
-- Verify the integrity of the payload
True <-
pure (RSA.verify (Just SHA1) travisPublicKey blob decodedSignature)
case Aeson.decodeStrict blob of
Nothing ->
lift (throwIO (TravisNoParse request))
Just value ->
pure value
-- | Retrieve the payload from an authenticated 'Request'.
--
-- This function /must/ be called on a 'Request' that was handled by the
-- 'authenticate' middleware. Otherwise, it will throw a 'TravisNoValue'
-- exception.
payload :: Request -> IO Value
payload request =
case Vault.lookup vaultKey (vault request) of
Nothing ->
throwIO (TravisNoValue request)
Just value ->
pure value
vaultKey :: Vault.Key Value
vaultKey =
unsafePerformIO Vault.newKey
{-# NOINLINE vaultKey #-}
-- Generated by ./print-pubkey.hs
travisPublicKey :: PublicKey
travisPublicKey =
PublicKey
{ public_size = 256
, public_n = 19821984571100721174801937457620616356826278863666395036092491929968642594870725800923165481927748936859185399099979204381315728615128617444471137310746875196305929578050077446870746964906791330757456711951792309209038242837017485691295115541567831580835001588720735252888165382117234029106545628408874399235402888561554376487524095653749826630076731478525532204204020975763080559118060924301943137668090191150244001738568733144533640931922256928565150196822324795442691411243969309366712382022175061865838244539628949282108447947299901919930392874255274028887037524853653490377264637621196465886362559811007585585749
, public_e = 65537
}
-- |
data TravisException
= TravisNoParse Request
-- ^ JSON-decoding an authenticated payload failed. This should never
-- happen; it means Travis CI signed and sent a payload that was not valid
-- JSON.
| TravisNoValue Request
-- ^ A call to 'payload' failed because there was no 'Value' inserted into
-- the request vault by the 'authenticate' middleware. This should never
-- happen, but if it does, it's your fault; it means you called 'payload'
-- on a 'Request' that did not pass through the 'authenticate' middleware.
deriving Show
instance Exception TravisException
-- $example
--
-- @
-- {-\# language OverloadedStrings #-}
--
-- import Network.Wai -- wai
-- import Network.Wai.Handler.Warp (run) -- warp
-- import Network.HTTP.Types -- http-types
--
-- import qualified Network.Wai.Middleware.TravisCI as TravisCI
--
-- main :: IO ()
-- main =
-- 'Network.Wai.Handler.Warp.run' 8000 (middleware app)
--
-- middleware :: 'Network.Wai.Middleware'
-- middleware =
-- TravisCI.'authenticate' ["travis"] -- (1)
--
-- app :: 'Network.Wai.Application'
-- app request respond =
-- case 'Network.Wai.pathInfo' request of
-- ["travis"] -> do -- (2)
-- payload <- TravisCI.'payload' request -- (3)
-- print payload
-- _ -> pure ()
-- respond ('Network.Wai.responseLBS' 'Networh.HTTP.Types.status200' [] "")
-- @
--
-- Above is a minimal @WAI@ application that authenticates @POST@s to @/travis@,
-- then prints out the parsed payload (an @aeson@ 'Value').
--
-- * At @(1)@, we define the middleware, which authenticates every @POST@ to
-- @/travis@.
--
-- * At @(2)@, we handle these @POST@s in our application.
--
-- * At @(3)@, we parse the JSON payload, whose schema is, unsurprisingly,
-- barely defined at all. See
-- <https://docs.travis-ci.com/user/notifications/#Webhooks-Delivery-Format>
-- for more information.