diff --git a/src/Network/Wai/Middleware/Rollbar.hs b/src/Network/Wai/Middleware/Rollbar.hs --- a/src/Network/Wai/Middleware/Rollbar.hs +++ b/src/Network/Wai/Middleware/Rollbar.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| Module : Network.Wai.Middleware.Rollbar @@ -17,10 +20,11 @@ More to come shortly. -} -module Network.Wai.Middleware.Rollbar (requests) where +module Network.Wai.Middleware.Rollbar (Settings(..), exceptions, requests) where import Control.Concurrent (forkIO) -import Control.Exception (Handler(Handler), catches, displayException) +import Control.Exception + (Handler(Handler), SomeException, catches, displayException, throwIO) import Control.Monad (when) import Data.Aeson (ToJSON, defaultOptions, genericToEncoding, toEncoding) @@ -30,6 +34,7 @@ import Data.UUID.V4 (nextRandom) import GHC.Generics (Generic) +import GHC.TypeLits (Symbol) import Network.HostName (getHostName) import Network.HTTP.Client (HttpException) @@ -53,64 +58,80 @@ import System.Environment (getExecutablePath) import System.IO (hPutStrLn, stderr) +import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Network.Wai as NW import qualified Rollbar.Item as RI +-- | Set up the middleware properly +-- The `headers` are what you want removed from +-- the request headers sent to Rollbar. +data Settings (headers :: [Symbol]) + = Settings + { accessToken :: RI.AccessToken + -- ^ Should have a scope "post_server_item". + , environment :: RI.Environment + -- ^ Should be something meaningful to your program + -- + -- E.g. "development" or "production" + } + +-- | Middleware that catches exceptions, sends an item to Rollbar, +-- and rethrows the exception. +-- +-- Sends additional metadata including the request information. +exceptions :: RI.RemoveHeaders headers => Settings headers -> Middleware +exceptions settings app req handler = app req handler `catches` + [ Handler $ handleSomeException settings req + ] + -- | Middleware that watches responses -- and sends an item to Rollbar if it is a server error (5xx). -- -- Sends additional metadata including the request information. -requests :: RI.AccessToken -> RI.Environment -> Middleware -requests accessToken environment app req handler' = app req handler +requests :: RI.RemoveHeaders headers => Settings headers -> Middleware +requests settings app req handler' = app req handler where handler :: NW.Response -> IO ResponseReceived handler res = do - _ <- forkIO $ handle500 accessToken environment req res + _ <- forkIO $ handle500 settings req res handler' res -handle500 :: RI.AccessToken -> RI.Environment -> NW.Request -> NW.Response -> IO () -handle500 accessToken environment req res = - when (statusIsServerError $ NW.responseStatus res) (send accessToken environment req res) +handle500 + :: RI.RemoveHeaders headers + => Settings headers + -> NW.Request + -> NW.Response + -> IO () +handle500 settings req res = + when (statusIsServerError $ NW.responseStatus res) (send settings req res) `catches` [ Handler handleHttpException , Handler handleJSONException ] -send :: RI.AccessToken -> RI.Environment -> NW.Request -> NW.Response -> IO () -send accessToken environment req res = do - uuid <- Just . RI.UUID4 <$> nextRandom - timestamp <- Just <$> getCurrentTime - host <- Just <$> getHostName - root <- Just . RI.Root . T.pack <$> getExecutablePath - let request = Just RI.Request {..} - let server = Just RI.Server { RI.branch = Nothing, RI.serverCodeVersion = Nothing, .. } - let itemData = (RI.error environment messageBody payload) - { RI.request, RI.server, RI.timestamp, RI.uuid } - let rReq = rollbarRequest RI.Item{..} +send + :: forall headers + . RI.RemoveHeaders headers + => Settings headers + -> NW.Request + -> NW.Response + -> IO () +send settings req res = do + rReq <- mkRollbarRequest settings req payload messageBody void $ httpNoBody rReq where Status{..} = NW.responseStatus res - headers = RI.Headers $ NW.requestHeaders req messageBody = RI.MessageBody <$> myDecodeUtf8 statusMessage - rawBody = "" - get = RI.Get $ NW.queryString req - method = RI.Method $ NW.requestMethod req - queryString = RI.QueryString $ NW.rawQueryString req - url = RI.URL (NW.requestHeaderHost req, NW.pathInfo req) - userIP = RI.IP $ NW.remoteHost req referer = myDecodeUtf8 =<< NW.requestHeaderReferer req range = myDecodeUtf8 =<< NW.requestHeaderRange req userAgent = myDecodeUtf8 =<< NW.requestHeaderUserAgent req - payload = Payload + payload = RequestPayload { statusMessage = myDecodeUtf8' statusMessage , .. } - myDecodeUtf8 = either (const Nothing) Just . TE.decodeUtf8' - myDecodeUtf8' = fromMaybe "" . myDecodeUtf8 - handleHttpException :: HttpException -> IO () handleHttpException e = do hPutStrLn stderr "Ran into an exception while sending a request to Rollbar:" @@ -121,7 +142,68 @@ hPutStrLn stderr "Ran into an exception while parsing JSON response from Rollbar:" hPutStrLn stderr $ displayException e -rollbarRequest :: ToJSON a => RI.Item a -> Network.HTTP.Simple.Request +handleSomeException + :: forall a headers + . RI.RemoveHeaders headers + => Settings headers + -> NW.Request + -> SomeException + -> IO a +handleSomeException settings req e = do + rReq <- mkRollbarRequest settings req payload messageBody + _ <- httpNoBody rReq + throwIO e + where + exception = T.pack $ displayException e + messageBody = Just $ RI.MessageBody $ + T.intercalate " " + [ "Uncaught exception at:" + , myDecodeUtf8' $ NW.requestMethod req + , T.intercalate "/" $ NW.pathInfo req + ] + referer = myDecodeUtf8 =<< NW.requestHeaderReferer req + range = myDecodeUtf8 =<< NW.requestHeaderRange req + userAgent = myDecodeUtf8 =<< NW.requestHeaderUserAgent req + payload = ExceptionPayload {..} + +mkRollbarRequest + :: forall headers + . RI.RemoveHeaders headers + => Settings headers + -> NW.Request + -> Payload + -> Maybe RI.MessageBody + -> IO Request +mkRollbarRequest Settings{..} req payload messageBody = do + uuid <- Just . RI.UUID4 <$> nextRandom + timestamp <- Just <$> getCurrentTime + host <- Just <$> getHostName + root <- Just . RI.Root . T.pack <$> getExecutablePath + let request = Just RI.Request {..} + let server = Just RI.Server { RI.branch = Nothing, RI.serverCodeVersion = Nothing, .. } + let itemData = (RI.error environment messageBody payload) + { RI.request, RI.server, RI.timestamp, RI.uuid } + pure $ rollbarRequest RI.Item{..} + where + headers :: RI.MissingHeaders headers + headers = RI.MissingHeaders $ NW.requestHeaders req + rawBody = "" + get = RI.Get $ NW.queryString req + method = RI.Method $ NW.requestMethod req + queryString = RI.QueryString $ NW.rawQueryString req + url = RI.URL (NW.requestHeaderHost req, NW.pathInfo req) + userIP = RI.IP $ NW.remoteHost req + +myDecodeUtf8 :: BS.ByteString -> Maybe T.Text +myDecodeUtf8 = either (const Nothing) Just . TE.decodeUtf8' + +myDecodeUtf8' :: BS.ByteString -> T.Text +myDecodeUtf8' = fromMaybe "" . myDecodeUtf8 + +rollbarRequest + :: (RI.RemoveHeaders headers, ToJSON a) + => RI.Item a headers + -> Network.HTTP.Simple.Request rollbarRequest payload = setRequestMethod "POST" . setRequestSecure True @@ -133,12 +215,18 @@ $ defaultRequest data Payload - = Payload + = RequestPayload { statusCode :: Int , statusMessage :: T.Text , userAgent :: Maybe T.Text , range :: Maybe T.Text , referer :: Maybe T.Text + } + | ExceptionPayload + { exception :: T.Text + , userAgent :: Maybe T.Text + , range :: Maybe T.Text + , referer :: Maybe T.Text } deriving (Generic, Show) diff --git a/src/Rollbar/Item.hs b/src/Rollbar/Item.hs --- a/src/Rollbar/Item.hs +++ b/src/Rollbar/Item.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} {-| Module : Rollbar.Item @@ -59,6 +61,9 @@ , module Rollbar.Item.Hardcoded , Hardcoded(..) + , module Rollbar.Item.MissingHeaders + , MissingHeaders(..) + , module Rollbar.Item.Person , Person(..) , Email(..) @@ -67,9 +72,9 @@ , module Rollbar.Item.Request , Get(..) - , Headers(..) , IP(..) , Method(..) + , MissingHeaders(..) , QueryString(..) , RawBody(..) , URL(..) @@ -95,6 +100,7 @@ import Rollbar.Item.Environment import Rollbar.Item.Hardcoded import Rollbar.Item.Level +import Rollbar.Item.MissingHeaders import Rollbar.Item.Person import Rollbar.Item.Request import Rollbar.Item.Server @@ -108,7 +114,11 @@ import qualified Paths_wai_middleware_rollbar -- | Creates 'Data' with the level set to 'Debug'. -debug :: Environment -> Maybe MessageBody -> payload -> Data payload +debug + :: Environment + -> Maybe MessageBody + -> payload + -> Data payload ("Authorization" ': headers) debug environment messageBody payload = Data { body = Message (fromMaybe "" messageBody) payload @@ -132,40 +142,59 @@ } -- | Creates 'Data' with the level set to 'Info'. -info :: Environment -> Maybe MessageBody -> payload -> Data payload +info + :: Environment + -> Maybe MessageBody + -> payload + -> Data payload ("Authorization" ': headers) info environment messageBody payload = (debug environment messageBody payload) { level = Info } -- | Creates 'Data' with the level set to 'Warning'. -warning :: Environment -> Maybe MessageBody -> payload -> Data payload +warning + :: Environment + -> Maybe MessageBody + -> payload + -> Data payload ("Authorization" ': headers) warning environment messageBody payload = (debug environment messageBody payload) { level = Warning } -- | Creates 'Data' with the level set to 'Error'. -error :: Environment -> Maybe MessageBody -> payload -> Data payload +error + :: Environment + -> Maybe MessageBody + -> payload + -> Data payload ("Authorization" ': headers) error environment messageBody payload = (debug environment messageBody payload) { level = Error } -- | Creates 'Data' with the level set to 'Critical'. -critical :: Environment -> Maybe MessageBody -> payload -> Data payload +critical + :: Environment + -> Maybe MessageBody + -> payload + -> Data payload ("Authorization" ': headers) critical environment messageBody payload = (debug environment messageBody payload) { level = Critical } -- | The thing we actually give to Rollbar. -data Item a +data Item a headers = Item { accessToken :: AccessToken -- ^ Should have a scope "post_server_item". - , itemData :: Data a + , itemData :: Data a headers } deriving (Eq, Generic, Show) -itemKVs :: (KeyValue kv, ToJSON v) => Item v -> [kv] +itemKVs + :: (KeyValue kv, RemoveHeaders headers, ToJSON v) + => Item v headers + -> [kv] itemKVs Item{..} = [ "access_token" .= accessToken , "data" .= itemData ] -instance ToJSON a => ToJSON (Item a) where +instance (RemoveHeaders headers, ToJSON a) => ToJSON (Item a headers) where toJSON = object . itemKVs toEncoding = pairs . mconcat . itemKVs diff --git a/src/Rollbar/Item/Body.hs b/src/Rollbar/Item/Body.hs --- a/src/Rollbar/Item/Body.hs +++ b/src/Rollbar/Item/Body.hs @@ -19,8 +19,10 @@ , MessageBody(..) ) where -import Data.Aeson (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) -import Data.String (IsString) +import Data.Aeson + (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) +import Data.Aeson.Encoding (pair) +import Data.String (IsString) import GHC.Generics (Generic) @@ -45,8 +47,8 @@ ] instance ToJSON arbitrary => ToJSON (Body arbitrary) where - toJSON = object . bodyKVs - toEncoding = pairs . mconcat . bodyKVs + toJSON x = object ["message" .= object (bodyKVs x)] + toEncoding = pairs . pair "message" . pairs . mconcat . bodyKVs -- | The primary message text to send to Rollbar. newtype MessageBody diff --git a/src/Rollbar/Item/Data.hs b/src/Rollbar/Item/Data.hs --- a/src/Rollbar/Item/Data.hs +++ b/src/Rollbar/Item/Data.hs @@ -22,6 +22,8 @@ , Framework(..) , Title(..) , UUID4(..) + + , RemoveHeaders ) where import Data.Aeson @@ -46,7 +48,7 @@ import Rollbar.Item.Hardcoded (Hardcoded) import Rollbar.Item.Level (Level) import Rollbar.Item.Person (Person) -import Rollbar.Item.Request (Request) +import Rollbar.Item.Request (RemoveHeaders, Request) import Rollbar.Item.Server (Server) import Rollbar.Item.Internal.Notifier (Notifier) @@ -60,7 +62,7 @@ -- -- N.B. While it's entirely possible for you to create one of these yourself, -- it's usually easier to use helpers like 'info' and 'error'. -data Data body +data Data body headers = Data { body :: Body body , codeVersion :: CodeVersion @@ -77,7 +79,7 @@ , person :: Maybe Person , platform :: Platform -- ^ Metadata about this package. You probably shouldn't create this yourself. - , request :: Maybe Request + , request :: Maybe (Request headers) , server :: Maybe Server , timestamp :: Maybe UTCTime , title :: Maybe Title @@ -85,7 +87,7 @@ } deriving (Eq, Generic, Show) -instance ToJSON body => ToJSON (Data body) where +instance (RemoveHeaders headers, ToJSON body) => ToJSON (Data body headers) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = codeVersionModifier , omitNothingFields = True diff --git a/src/Rollbar/Item/MissingHeaders.hs b/src/Rollbar/Item/MissingHeaders.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/MissingHeaders.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{-| + Module : Rollbar.Item.MissingHeaders + Description : Headers with some missing from the JSON instance. + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental +-} + +module Rollbar.Item.MissingHeaders + ( MissingHeaders(..) + , RemoveHeaders + ) where + +import Data.Aeson (KeyValue, ToJSON, object, toJSON, (.=)) +import Data.CaseInsensitive (mk, original) +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy(Proxy)) + +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) + +import Network.HTTP.Types (Header, RequestHeaders) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +-- | The request headers with some missing +-- +-- This is useful for removing sensitive information +-- like the `Authorization` header. +newtype MissingHeaders (headers :: [Symbol]) + = MissingHeaders RequestHeaders + deriving (Eq, Show) + +-- | Remove the headers given from the underlying request headers. +class RemoveHeaders (headers :: [Symbol]) where + removeHeaders :: MissingHeaders headers -> RequestHeaders + +instance RemoveHeaders '[] where + removeHeaders (MissingHeaders rhs) = rhs + +instance (KnownSymbol header, RemoveHeaders headers) + => RemoveHeaders (header ': headers) where + removeHeaders (MissingHeaders rhs) = + removeHeaders (MissingHeaders $ filter go rhs :: MissingHeaders headers) + where + go (rh, _) = + rh /= (mk . BSC8.pack $ symbolVal (Proxy :: Proxy header)) + +instance RemoveHeaders headers => ToJSON (MissingHeaders headers) where + toJSON = object . catMaybes . requestHeadersKVs . removeHeaders + +requestHeadersKVs :: forall kv. KeyValue kv => RequestHeaders -> [Maybe kv] +requestHeadersKVs = fmap go + where + go :: Header -> Maybe kv + go (key', val') = do + key <- myDecodeUtf8 $ original key' + val <- myDecodeUtf8 val' + pure (key .= val) + +myDecodeUtf8 :: BS.ByteString -> Maybe T.Text +myDecodeUtf8 = either (const Nothing) Just . TE.decodeUtf8' diff --git a/src/Rollbar/Item/Request.hs b/src/Rollbar/Item/Request.hs --- a/src/Rollbar/Item/Request.hs +++ b/src/Rollbar/Item/Request.hs @@ -16,36 +16,37 @@ module Rollbar.Item.Request ( Request(..) , Get(..) - , Headers(..) , IP(..) , Method(..) + , MissingHeaders(..) , QueryString(..) , RawBody(..) , URL(..) + , RemoveHeaders ) where -import Data.Aeson - (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) -import Data.CaseInsensitive (original) -import Data.Maybe (catMaybes, fromMaybe) -import Data.String (IsString) +import Data.Aeson (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) import GHC.Generics (Generic) -import Network.HTTP.Types (Header, Query, RequestHeaders) +import Network.HTTP.Types (Query) import Network.Socket (SockAddr) +import Rollbar.Item.MissingHeaders + import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.Encoding as TE -- | Data sent to the server -data Request +data Request headers = Request { rawBody :: RawBody , get :: Get -- ^ Query parameters - , headers :: Headers + , headers :: MissingHeaders headers , method :: Method , queryString :: QueryString -- ^ The entire query string @@ -82,24 +83,6 @@ let val = val' >>= myDecodeUtf8 pure (key .= val) --- | The request headers -newtype Headers - = Headers RequestHeaders - deriving (Eq, Generic, Show) - -instance ToJSON Headers where - toJSON (Headers hs) = object . catMaybes . requestHeadersKVs $ hs - toEncoding (Headers hs) = pairs . mconcat . catMaybes . requestHeadersKVs $ hs - -requestHeadersKVs :: forall kv. KeyValue kv => RequestHeaders -> [Maybe kv] -requestHeadersKVs = fmap go - where - go :: Header -> Maybe kv - go (key', val') = do - key <- myDecodeUtf8 $ original key' - val <- myDecodeUtf8 val' - pure (T.pack (show key) .= val) - -- | The HTTP Verb newtype Method = Method BS.ByteString @@ -127,7 +110,7 @@ toJSON (IP ip) = toJSON (show ip) toEncoding (IP ip) = toEncoding (show ip) -requestKVs :: KeyValue kv => Request -> [kv] +requestKVs :: (KeyValue kv, RemoveHeaders headers) => Request headers -> [kv] requestKVs Request{..} = [ "body" .= rawBody , "GET" .= get @@ -138,7 +121,7 @@ , "user_ip" .= userIP ] -instance ToJSON Request where +instance (RemoveHeaders headers) => ToJSON (Request headers) where toJSON = object . requestKVs toEncoding = pairs . mconcat . requestKVs diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Test.QuickCheck (conjoin, quickCheck) + +import qualified Rollbar.Item.Data.Test +import qualified Rollbar.Item.MissingHeaders.Test +import qualified Rollbar.Item.Request.Test + +main :: IO () +main = do + Rollbar.Item.Data.Test.props + Rollbar.Item.MissingHeaders.Test.props + Rollbar.Item.Request.Test.props diff --git a/test/Rollbar/Item/Data/Test.hs b/test/Rollbar/Item/Data/Test.hs new file mode 100644 --- /dev/null +++ b/test/Rollbar/Item/Data/Test.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Rollbar.Item.Data.Test where + +import Control.Lens ((^@..)) + +import Data.Aeson (encode, toJSON) +import Data.Aeson.Lens (key, members) +import Data.Text (Text, pack) + +import Prelude hiding (error) + +import Rollbar.Item + +import Test.QuickCheck + (Arbitrary, Property, arbitrary, conjoin, elements, quickCheck) + +props :: IO () +props = + quickCheck $ conjoin + [ prop_valueDataBodyHasRequiredKey + , prop_encodingDataBodyHasRequiredKey + ] + +prop_valueDataBodyHasRequiredKey :: Data () '["Authorization"] -> Bool +prop_valueDataBodyHasRequiredKey x = + length ms == 1 && fst (head ms) `elem` requiredBodyKeys + where + ms = toJSON x ^@.. key "body" . members + +prop_encodingDataBodyHasRequiredKey :: Data () '["Authorization"] -> Bool +prop_encodingDataBodyHasRequiredKey x = + length ms == 1 && fst (head ms) `elem` requiredBodyKeys + where + ms = encode x ^@.. key "body" . members + +instance Arbitrary a => Arbitrary (Data a '["Authorization"]) where + arbitrary = do + env <- Environment . pack <$> arbitrary + message <- fmap (MessageBody . pack) <$> arbitrary + payload <- arbitrary + elements $ (\f -> f env message payload) <$> datas + +datas :: [Environment -> Maybe MessageBody -> a -> Data a '["Authorization"]] +datas = [debug, info, warning, error, critical] + +requiredBodyKeys :: [Text] +requiredBodyKeys = ["trace", "trace_chain", "message", "crash_report"] diff --git a/test/Rollbar/Item/MissingHeaders/Test.hs b/test/Rollbar/Item/MissingHeaders/Test.hs new file mode 100644 --- /dev/null +++ b/test/Rollbar/Item/MissingHeaders/Test.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Rollbar.Item.MissingHeaders.Test where + +import Control.Lens ((&), (^@..)) + +import Data.Aeson (encode, toJSON) +import Data.Aeson.Lens (key, members) +import Data.Bifunctor (bimap) +import Data.CaseInsensitive (mk, original) +import Data.Proxy (Proxy(Proxy)) +import Data.Text (Text, pack) + +import GHC.TypeLits (KnownSymbol, symbolVal) + +import Prelude hiding (error) + +import Rollbar.Item.MissingHeaders (MissingHeaders(..)) + +import Test.QuickCheck + (Arbitrary, Gen, Property, arbitrary, conjoin, elements, quickCheck) + +import Data.ByteString.Char8 as BSC8 +import Data.Set as S +import Data.Text.Encoding as TE + +props :: IO () +props = do + quickCheck $ conjoin + [ prop_valueAuthorizationIsRemoved + , prop_encodingAuthorizationIsRemoved + ] + + quickCheck $ conjoin + [ prop_valueX_AccessTokenIsRemoved + , prop_encodingX_AccessTokenIsRemoved + ] + + quickCheck $ conjoin + [ prop_valueAllHeadersAreRemoved + , prop_encodingAllHeadersAreRemoved + ] + +prop_valueAuthorizationIsRemoved :: MissingHeaders '["Authorization"] -> Bool +prop_valueAuthorizationIsRemoved hs@(MissingHeaders rhs) = + "Authorization" `S.notMember` actual + where + actual = toJSON hs ^@.. members & fmap fst & S.fromList + +prop_encodingAuthorizationIsRemoved :: MissingHeaders '["Authorization"] -> Bool +prop_encodingAuthorizationIsRemoved hs@(MissingHeaders rhs) = + "Authorization" `S.notMember` actual + where + actual = encode hs ^@.. members & fmap fst & S.fromList + +prop_valueX_AccessTokenIsRemoved :: MissingHeaders '["X-AccessToken"] -> Bool +prop_valueX_AccessTokenIsRemoved hs@(MissingHeaders rhs) = + "X-AccessToken" `S.notMember` actual + where + actual = toJSON hs ^@.. members & fmap fst & S.fromList + +prop_encodingX_AccessTokenIsRemoved :: MissingHeaders '["X-AccessToken"] -> Bool +prop_encodingX_AccessTokenIsRemoved hs@(MissingHeaders rhs) = + "X-AccessToken" `S.notMember` actual + where + actual = encode hs ^@.. members & fmap fst & S.fromList + +prop_valueAllHeadersAreRemoved + :: MissingHeaders + '["Authorization", "this is made up", "Server", "X-AccessToken"] + -> Bool +prop_valueAllHeadersAreRemoved hs@(MissingHeaders rhs) = + "Authorization" `S.notMember` actual + && "this is made up" `S.notMember` actual + && "Server" `S.notMember` actual + && "X-AccessToken" `S.notMember` actual + where + actual = toJSON hs ^@.. members & fmap fst & S.fromList + +prop_encodingAllHeadersAreRemoved + :: MissingHeaders + '["Authorization", "this is made up", "Server", "X-AccessToken"] + -> Bool +prop_encodingAllHeadersAreRemoved hs@(MissingHeaders rhs) = + "Authorization" `S.notMember` actual + && "this is made up" `S.notMember` actual + && "Server" `S.notMember` actual + && "X-AccessToken" `S.notMember` actual + where + actual = encode hs ^@.. members & fmap fst & S.fromList + +instance Arbitrary (MissingHeaders '[]) where + arbitrary = do + xs <- arbitrary + let hs = bimap (mk . BSC8.pack) BSC8.pack <$> xs + pure . MissingHeaders $ hs + +instance (KnownSymbol header, Arbitrary (MissingHeaders headers)) + => Arbitrary (MissingHeaders (header ': headers)) where + arbitrary = do + MissingHeaders hs <- arbitrary :: Gen (MissingHeaders headers) + let name = mk . BSC8.pack $ symbolVal (Proxy :: Proxy header) + value <- BSC8.pack <$> arbitrary + pure . MissingHeaders $ (name, value) : hs diff --git a/test/Rollbar/Item/Request/Test.hs b/test/Rollbar/Item/Request/Test.hs new file mode 100644 --- /dev/null +++ b/test/Rollbar/Item/Request/Test.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Rollbar.Item.Request.Test where + +import Control.Lens ((&), (^@..)) + +import Data.Aeson (encode, toJSON) +import Data.Aeson.Lens (key, members) +import Data.Bifunctor (bimap) +import Data.CaseInsensitive (mk, original) +import Data.Text (Text, pack) + +import Prelude hiding (error) + +import Rollbar.Item.Request (MissingHeaders(..), RemoveHeaders) + +import Test.QuickCheck + (Arbitrary, Property, arbitrary, conjoin, elements, quickCheck) + +import Data.ByteString.Char8 as BSC8 +import Data.Set as S +import Data.Text.Encoding as TE + +props :: IO () +props = + quickCheck $ conjoin + [ prop_valueHeadersArentWrapped + , prop_encodingHeadersArentWrapped + ] + +prop_valueHeadersArentWrapped :: MissingHeaders '["Authorization"] -> Bool +prop_valueHeadersArentWrapped hs@(MissingHeaders rhs) = + actual `S.isSubsetOf` expected + where + actual = toJSON hs ^@.. members & fmap fst & S.fromList + expected = S.fromList $ either (const "") id . TE.decodeUtf8' . original . fst <$> rhs + +prop_encodingHeadersArentWrapped :: MissingHeaders '["Authorization"] -> Bool +prop_encodingHeadersArentWrapped hs@(MissingHeaders rhs) = + actual `S.isSubsetOf` expected + where + actual = encode hs ^@.. members & fmap fst & S.fromList + expected = S.fromList $ either (const "") id . TE.decodeUtf8' . original . fst <$> rhs + +instance Arbitrary (MissingHeaders ("Authorization" ': headers)) where + arbitrary = do + xs <- arbitrary + pure . MissingHeaders $ bimap (mk . BSC8.pack) BSC8.pack <$> xs diff --git a/wai-middleware-rollbar.cabal b/wai-middleware-rollbar.cabal --- a/wai-middleware-rollbar.cabal +++ b/wai-middleware-rollbar.cabal @@ -1,5 +1,5 @@ name: wai-middleware-rollbar -version: 0.2.0 +version: 0.3.0 synopsis: Middleware that communicates to Rollbar. description: Middleware that communicates to Rollbar. homepage: https://github.com/joneshf/wai-middleware-rollbar#readme @@ -25,6 +25,7 @@ , Rollbar.Item.Environment , Rollbar.Item.Hardcoded , Rollbar.Item.Level + , Rollbar.Item.MissingHeaders , Rollbar.Item.Person , Rollbar.Item.Request , Rollbar.Item.Server @@ -48,6 +49,26 @@ , wai >= 3.2 && < 3.3 default-language: Haskell2010 ghc-options: -Wall + +test-suite doc-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Rollbar.Item.Data.Test + , Rollbar.Item.MissingHeaders.Test + , Rollbar.Item.Request.Test + build-depends: base + , aeson + , bytestring + , case-insensitive + , containers >= 0.5 && < 0.6 + , lens >= 4.15 && < 4.16 + , lens-aeson >= 1.0 && < 1.1 + , QuickCheck >= 2.9 && < 2.10 + , text + , wai-middleware-rollbar + default-language: Haskell2010 source-repository head type: git