-- |
-- @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.