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 @@ -3,7 +3,6 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-| @@ -27,17 +26,16 @@ (Handler(Handler), SomeException, catches, displayException, throwIO) import Control.Monad (when) -import Data.Aeson (ToJSON, defaultOptions, genericToEncoding, toEncoding) +import Data.Aeson (ToJSON) import Data.Functor (void) import Data.Maybe (fromMaybe) import Data.Time (getCurrentTime) import Data.UUID.V4 (nextRandom) -import GHC.Generics (Generic) import GHC.TypeLits (Symbol) -import Network.HostName (getHostName) -import Network.HTTP.Client (HttpException) +import Network.HostName (getHostName) +import Network.HTTP.Client (HttpException) import Network.HTTP.Simple ( JSONException , Request @@ -53,16 +51,18 @@ ) import Network.HTTP.Types.Status (Status(Status), statusCode, statusIsServerError, statusMessage) -import Network.Wai (Middleware, ResponseReceived) +import Network.Wai (Middleware, ResponseReceived) +import Network.Wai.Middleware.Rollbar.Payload (Payload) 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 +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 Network.Wai.Middleware.Rollbar.Payload as Payload +import qualified Rollbar.Item as RI -- | Set up the middleware properly -- The `headers` are what you want removed from @@ -71,7 +71,7 @@ = Settings { accessToken :: RI.AccessToken -- ^ Should have a scope "post_server_item". - , branch :: Maybe RI.Branch + , branch :: Maybe RI.Branch -- ^ Should be the branch of the running application. -- -- Will default to `master` if not set. @@ -128,14 +128,17 @@ rReq <- mkRollbarRequest settings req payload messageBody void $ httpNoBody rReq where - Status{..} = NW.responseStatus res + Status{statusCode, statusMessage} = NW.responseStatus res messageBody = RI.MessageBody <$> myDecodeUtf8 statusMessage referer = myDecodeUtf8 =<< NW.requestHeaderReferer req range = myDecodeUtf8 =<< NW.requestHeaderRange req userAgent = myDecodeUtf8 =<< NW.requestHeaderUserAgent req - payload = RequestPayload - { statusMessage = myDecodeUtf8' statusMessage - , .. + payload = Payload.RequestPayload + { Payload.range + , Payload.referer + , Payload.statusCode + , Payload.statusMessage = myDecodeUtf8' statusMessage + , Payload.userAgent } handleHttpException :: HttpException -> IO () @@ -170,7 +173,12 @@ referer = myDecodeUtf8 =<< NW.requestHeaderReferer req range = myDecodeUtf8 =<< NW.requestHeaderRange req userAgent = myDecodeUtf8 =<< NW.requestHeaderUserAgent req - payload = ExceptionPayload {..} + payload = Payload.ExceptionPayload + { Payload.exception + , Payload.referer + , Payload.range + , Payload.userAgent + } mkRollbarRequest :: forall headers @@ -180,16 +188,25 @@ -> Payload -> Maybe RI.MessageBody -> IO Request -mkRollbarRequest Settings{..} req payload messageBody = do +mkRollbarRequest Settings{accessToken, branch, codeVersion, environment} 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.serverCodeVersion = codeVersion, .. } + let request = Just RI.Request + { RI.get + , RI.headers + , RI.method + , RI.queryString + , RI.rawBody + , RI.url + , RI.userIP + } + let server = Just RI.Server + { RI.branch, RI.host, RI.root, RI.serverCodeVersion = codeVersion } let itemData = (RI.error environment messageBody payload) - { RI.codeVersion, RI.request, RI.server, RI.timestamp, RI.uuid } - pure $ rollbarRequest RI.Item{..} + { RI.codeVersion, RI.request, RI.server, RI.timestamp, RI.uuid } + pure $ rollbarRequest RI.Item{RI.accessToken, RI.itemData} where headers :: RI.MissingHeaders headers headers = RI.MissingHeaders $ NW.requestHeaders req @@ -219,22 +236,3 @@ . setRequestBodyJSON payload . setRequestIgnoreStatus $ defaultRequest - -data 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) - -instance ToJSON Payload where - toEncoding = genericToEncoding defaultOptions diff --git a/src/Network/Wai/Middleware/Rollbar/Payload.hs b/src/Network/Wai/Middleware/Rollbar/Payload.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Rollbar/Payload.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} + +{-| + Module : Network.Wai.Middleware.Rollbar.Payload + Description : The payload to send to Rollbar + Copyright : (c) Hardy Jones, 2018 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental + + Provides the payload for communicating with Rollbar. +-} + +module Network.Wai.Middleware.Rollbar.Payload where + +import Data.Aeson (ToJSON, defaultOptions, genericToEncoding, toEncoding) + +import GHC.Generics (Generic) + +import qualified Data.Text as T + +data 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) + +instance ToJSON Payload where + toEncoding = genericToEncoding defaultOptions diff --git a/src/Rollbar/API.hs b/src/Rollbar/API.hs deleted file mode 100644 --- a/src/Rollbar/API.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -{-| - Module : Rollbar.API - Description : Codifies Rollbar's API - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental - - Provides functions for communicating with Rollbar through the public API. - - See Rollbar's for more details. --} -module Rollbar.API - ( -- * Helpful functions - -- | These functions are probably what you want most of the time. - itemsPOST - , itemsPOST' - , itemsPOSTRaw - , itemsPOSTRaw' - , makeRequest - -- * Response data types - , ItemsPOSTResponse(..) - , ItemsPOSTErrorMessage(..) - , ItemsPOSTSuccessResult(..) - -- * Impure functions - -- | Use with caution. - , itemsPOSTWithException - ) where - -import Control.Monad.IO.Class (MonadIO) - -import Data.Aeson.Types - ( FromJSON(parseJSON) - , SumEncoding(UntaggedValue) - , ToJSON - , defaultOptions - , fieldLabelModifier - , genericParseJSON - , sumEncoding - ) -import Data.Text (Text) - -import GHC.Generics (Generic) - -import Network.HTTP.Client - ( Manager - , Request(host, method, path, port, secure) - , Response - , defaultRequest - , setRequestIgnoreStatus - ) -import Network.HTTP.Simple - ( JSONException - , httpJSON - , httpJSONEither - , setRequestBodyJSON - , setRequestManager - ) - -import Rollbar.Item (Item, RemoveHeaders, UUID4) - --- | The response received from sending an 'Rollbar.Item.Item' to Rollbar. -data ItemsPOSTResponse - = ItemsPOSTSuccess - { err_ItemsPOSTSuccess :: Int - -- ^ This `err` field is always 0. - , result_ItemsPOSTSuccess :: ItemsPOSTSuccessResult - -- ^ The part you probably care about. - } - | ItemsPOSTError - { err_ItemsPOSTError :: Int - -- ^ This `err` field is always 1. - , message_ItemsPOSTError :: Text - -- ^ A human-readable message describing the error. - } - deriving (Eq, Generic, Show) - -instance FromJSON ItemsPOSTResponse where - parseJSON = genericParseJSON defaultOptions - { fieldLabelModifier = takeWhile (/= '_') - , sumEncoding = UntaggedValue - } - --- | The successful response from sending an 'Rollbar.Item.Item' to Rollbar. -newtype ItemsPOSTSuccessResult - = ItemsPOSTSuccessResult - { uuid :: UUID4 - -- ^ 'Rollbar.Item.UUID4' of the item. - -- Matches sent 'Rollbar.Item.UUID4' or generated by Rollbar if missing. - } - deriving (Eq, FromJSON, Generic, Show) - --- | The human readable error message from sending an 'Rollbar.Item.Item' to Rollbar. -newtype ItemsPOSTErrorMessage - = ItemsPOSTErrorMessage Text - deriving (Eq, FromJSON, Generic, Show) - --- | Sends an 'Rollbar.Item.Item' off to Rollbar. --- --- Creates a new 'Network.HTTP.Client.Manager' to send off the request. -itemsPOST - :: (MonadIO f, RemoveHeaders b, ToJSON a) - => Item a b - -> f (Response (Either JSONException ItemsPOSTResponse)) -itemsPOST = itemsPOSTRaw - --- | Sends an 'Rollbar.Item.Item' off to Rollbar. -itemsPOST' - :: (MonadIO f, RemoveHeaders b, ToJSON a) - => Manager - -> Item a b - -> f (Response (Either JSONException ItemsPOSTResponse)) -itemsPOST' = itemsPOSTRaw' - --- | Sends an 'Rollbar.Item.Item' off to Rollbar. --- --- Creates a new 'Network.HTTP.Client.Manager' to send off the request. --- Makes no claims about what you get back. -itemsPOSTRaw - :: (FromJSON c, MonadIO f, RemoveHeaders b, ToJSON a) - => Item a b - -> f (Response (Either JSONException c)) -itemsPOSTRaw = httpJSONEither . makeRequest - --- | Sends an 'Rollbar.Item.Item' off to Rollbar. --- --- Makes no claims about what you get back. -itemsPOSTRaw' - :: (FromJSON c, MonadIO f, RemoveHeaders b, ToJSON a) - => Manager - -> Item a b - -> f (Response (Either JSONException c)) -itemsPOSTRaw' manager = httpJSONEither . setRequestManager manager . makeRequest - --- | Sends an 'Rollbar.Item.Item' off to Rollbar. --- --- Creates a new 'Network.HTTP.Client.Manager' to send off the request. --- Makes no claims about what you get back. --- Throws a 'Network.HTTP.Simple.JSONException' if it cannot parse the response. --- --- Yes, this name is annoying, so are exceptions. -itemsPOSTWithException - :: (FromJSON c, MonadIO f, RemoveHeaders b, ToJSON a) - => Item a b - -> f (Response c) -itemsPOSTWithException = httpJSON . makeRequest - --- | Converts an item into a request ready to send to Rollbar. --- --- If you need a different scheme for sending items, --- you'll probably want to use this along with a function like 'Network.HTTP.Client.httpLbs' --- or 'Network.HTTP.Simple.httpLbs'. --- --- If you want the JSON back and already have a 'Network.HTTP.Client.Manager', --- you can use this function with 'Network.HTTP.Simple.setRequestManager'. --- Then send off the request with something like 'Network.HTTP.Simple.httpJSONEither'. -makeRequest :: (RemoveHeaders headers, ToJSON a) => Item a headers -> Request -makeRequest payload = - setRequestBodyJSON payload - . setRequestIgnoreStatus - $ defaultRequest - { host = "api.rollbar.com" - , method = "POST" - , path = "api/1/item/" - , port = 443 - , secure = True - } diff --git a/src/Rollbar/AccessToken.hs b/src/Rollbar/AccessToken.hs deleted file mode 100644 --- a/src/Rollbar/AccessToken.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-| - Module : Rollbar.AccessToken - Description : The access token for a project on Rollbar. - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental --} - -module Rollbar.AccessToken - ( AccessToken(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.String (IsString) - -import qualified Data.Text as T - --- | Should have the scope "post_server_item". -newtype AccessToken - = AccessToken T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item.hs b/src/Rollbar/Item.hs deleted file mode 100644 --- a/src/Rollbar/Item.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeOperators #-} - -{-| - Module : Rollbar.Item - Description : Datatype for reporting to Rollbar - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental - - Provides a data type that subsumes most of what Rollbar expects for "item"s. - - See Rollbar's - for more details. --} - -module Rollbar.Item - ( -- * Data helpers - -- | These functions are probably what you want to use most of the time. - -- - -- They create a 'Data' with lots of data prefilled. - -- You can then override what you need with record updates. - debug - , info - , warning - , error - , critical - -- * Item - , Item(..) - -- * Item data - , module Rollbar.AccessToken - , AccessToken(..) - - , module Rollbar.Item.Data - , Data(..) - , Context(..) - , Fingerprint(..) - , Framework(..) - , Title(..) - , UUID4(..) - - -- * Required data - , module Rollbar.Item.Body - , Body(..) - , MessageBody(..) - - , module Rollbar.Item.Environment - , Environment(..) - - , module Rollbar.Item.Level - , Level(..) - - -- * Optional data - , module Rollbar.Item.CodeVersion - , CodeVersion(..) - - , module Rollbar.Item.Hardcoded - , Hardcoded(..) - - , module Rollbar.Item.MissingHeaders - , MissingHeaders(..) - - , module Rollbar.Item.Person - , Person(..) - , Email(..) - , Id(..) - , Username(..) - - , module Rollbar.Item.Request - , Get(..) - , IP(..) - , Method(..) - , MissingHeaders(..) - , QueryString(..) - , RawBody(..) - , URL(..) - - , module Rollbar.Item.Server - , Server(..) - , Branch(..) - , Root(..) - ) where - -import Data.Aeson - ( FromJSON - , KeyValue - , ToJSON - , Value(Object) - , object - , pairs - , parseJSON - , toEncoding - , toJSON - , (.:) - , (.=) - ) -import Data.Aeson.Types (typeMismatch) -import Data.Maybe (fromMaybe) - -import GHC.Generics (Generic) - -import Prelude hiding (error) - -import Rollbar.AccessToken -import Rollbar.Item.Body -import Rollbar.Item.CodeVersion -import Rollbar.Item.Data -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 - -import Rollbar.Item.Internal.Notifier -import Rollbar.Item.Internal.Platform - -import System.Info (os) - -import qualified Data.Text as T -import qualified Paths_wai_middleware_rollbar - --- | Creates 'Data' with the level set to 'Debug'. -debug - :: Environment - -> Maybe MessageBody - -> payload - -> Data payload ("Authorization" ': headers) -debug environment messageBody payload = - Data - { body = Message (fromMaybe "" messageBody) payload - , codeVersion = Nothing - , context = Nothing - , custom = Nothing - , environment = environment - , fingerprint = Nothing - , framework = Nothing - , language = Hardcoded - , level = Debug - , notifier = Notifier Hardcoded Paths_wai_middleware_rollbar.version - , person = Nothing - , platform = Platform $ T.pack os - , request = Nothing - , server = Nothing - , timestamp = Nothing - , title = Nothing - , uuid = Nothing - } - --- | Creates 'Data' with the level set to 'Info'. -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 ("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 ("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 ("Authorization" ': headers) -critical environment messageBody payload = - (debug environment messageBody payload) { level = Critical } - --- | The thing we actually give to Rollbar. -data Item a headers - = Item - { accessToken :: AccessToken - -- ^ Should have a scope "post_server_item". - , itemData :: Data a headers - } - deriving (Eq, Generic, Show) - -itemKVs - :: (KeyValue kv, RemoveHeaders headers, ToJSON v) - => Item v headers - -> [kv] -itemKVs Item{..} = - [ "access_token" .= accessToken - , "data" .= itemData - ] - -instance FromJSON a => FromJSON (Item a headers) where - parseJSON (Object o) = Item <$> o .: "access_token" <*> o .: "data" - parseJSON v = typeMismatch "Item a headers" v - -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 deleted file mode 100644 --- a/src/Rollbar/Item/Body.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{-| - Module : Rollbar.Item.Body - Description : The meat of the Rollbar item - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental - - Use this for providing the majority of your specific data to Rollbar. --} - -module Rollbar.Item.Body - ( Body(..) - , MessageBody(..) - ) where - -import Data.Aeson - ( FromJSON - , KeyValue - , ToJSON - , Value(Object) - , object - , pairs - , parseJSON - , toEncoding - , toJSON - , (.:) - , (.=) - ) -import Data.Aeson.Encoding (pair) -import Data.Aeson.Types (typeMismatch) -import Data.String (IsString) - -import GHC.Generics (Generic) - -import qualified Data.Text as T - --- | This is the actual data that you want to give to Rollbar. --- Most of the rest of Rollbar is metadata. -data Body arbitrary - -- | No stack trace, just a message and some arbitrary data. - = Message - { messageBody :: MessageBody - -- ^ The primary message text. - , messageData :: arbitrary - -- ^ Any arbitrary data you want to send with this message. - } - deriving (Eq, Generic, Show) - -bodyKVs :: (KeyValue kv, ToJSON v) => Body v -> [kv] -bodyKVs Message{..} = - [ "body" .= messageBody - , "data" .= messageData - ] - -instance FromJSON arbitrary => FromJSON (Body arbitrary) where - parseJSON (Object o') = do - o <- o' .: "message" - Message <$> o .: "body" <*> o .: "data" - parseJSON v = typeMismatch "Body arbitrary" v - -instance ToJSON arbitrary => ToJSON (Body arbitrary) where - toJSON x = object ["message" .= object (bodyKVs x)] - toEncoding = pairs . pair "message" . pairs . mconcat . bodyKVs - --- | The primary message text to send to Rollbar. -newtype MessageBody - = MessageBody T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/CodeVersion.hs b/src/Rollbar/Item/CodeVersion.hs deleted file mode 100644 --- a/src/Rollbar/Item/CodeVersion.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -{-| - Module : Rollbar.Item.CodeVersion - Description : Metadata for describing versions of software - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental --} - -module Rollbar.Item.CodeVersion - ( CodeVersion(..) - ) where - -import Data.Aeson (FromJSON, ToJSON, parseJSON, toEncoding, toJSON) -import Data.Aeson.Types (typeMismatch) - -import GHC.Generics (Generic) - -import qualified Data.Aeson as A -import qualified Data.Text as T - --- | Rollbar supports different ways to say what version the code is. -data CodeVersion - -- | Good ole SemVer. - -- It's 'T.Text' because who knows if you actually got it right... - = SemVer T.Text - -- | Plain integers. - | Number Int - -- | Should be a Git SHA. - | SHA T.Text - deriving (Eq, Generic, Show) - -prettyCodeVersion :: CodeVersion -> T.Text -prettyCodeVersion (SemVer s) = s -prettyCodeVersion (Number n) = T.pack . show $ n -prettyCodeVersion (SHA h) = h - -instance FromJSON CodeVersion where - parseJSON (A.String s) = case T.splitOn "." s of - [_major, _minor, _patch] -> pure $ SemVer s - _ -> pure $ SHA s - parseJSON (A.Number n) = pure $ Number $ floor n - parseJSON v = typeMismatch "CodeVersion" v - -instance ToJSON CodeVersion where - toJSON = toJSON . prettyCodeVersion - toEncoding = toEncoding . prettyCodeVersion diff --git a/src/Rollbar/Item/Data.hs b/src/Rollbar/Item/Data.hs deleted file mode 100644 --- a/src/Rollbar/Item/Data.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -{-| - Module : Rollbar.Item.Data - Description : Metadata about the item being reported - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental - - The majority of this module is metadata that is reported for each item. --} - -module Rollbar.Item.Data - ( Data(..) - , Context(..) - , Fingerprint(..) - , Framework(..) - , Title(..) - , UUID4(..) - - , RemoveHeaders - ) where - -import Data.Aeson - ( FromJSON - , ToJSON - , Value(String) - , defaultOptions - , genericParseJSON - , genericToEncoding - , genericToJSON - , parseJSON - , toEncoding - , toJSON - ) -import Data.Aeson.Types - (Options, fieldLabelModifier, omitNothingFields, typeMismatch) -import Data.String (IsString) -import Data.Time (UTCTime) -import Data.UUID (UUID, fromText, toText) - -import GHC.Generics (Generic) - -import Rollbar.Item.Body (Body) -import Rollbar.Item.CodeVersion (CodeVersion) -import Rollbar.Item.Environment (Environment) -import Rollbar.Item.Hardcoded (Hardcoded) -import Rollbar.Item.Level (Level) -import Rollbar.Item.Person (Person) -import Rollbar.Item.Request (RemoveHeaders, Request) -import Rollbar.Item.Server (Server) - -import Rollbar.Item.Internal.Notifier (Notifier) -import Rollbar.Item.Internal.Platform (Platform) - -import qualified Data.HashMap.Lazy as HM -import qualified Data.Text as T - --- | The main payload of an item. --- Most of this is metadata. --- --- 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 headers - = Data - { body :: Body body - , codeVersion :: Maybe CodeVersion - , context :: Maybe Context - , custom :: Maybe (HM.HashMap T.Text Value) - , environment :: Environment - , fingerprint :: Maybe Fingerprint - , framework :: Maybe Framework - , language :: Hardcoded "haskell" - , level :: Level - , notifier :: Notifier - -- ^ Metadata about this package. You probably shouldn't create this yourself. - , person :: Maybe Person - , platform :: Platform - -- ^ Metadata about this package. You probably shouldn't create this yourself. - , request :: Maybe (Request headers) - , server :: Maybe Server - , timestamp :: Maybe UTCTime - , title :: Maybe Title - , uuid :: Maybe UUID4 - } - deriving (Eq, Generic, Show) - -instance FromJSON body => FromJSON (Data body headers) where - parseJSON = genericParseJSON options - -instance (RemoveHeaders headers, ToJSON body) => ToJSON (Data body headers) where - toJSON = genericToJSON options - toEncoding = genericToEncoding options - -options :: Options -options = defaultOptions - { fieldLabelModifier = codeVersionModifier - , omitNothingFields = True - } - -codeVersionModifier :: (Eq s, IsString s) => s -> s -codeVersionModifier = \case - "codeVersion" -> "code_version" - str -> str - --- | The framework that is using this package. --- E.g. "scotty", "servant", "yesod" -newtype Framework - = Framework T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) - --- | The place in the code where this item came from. -newtype Context - = Context T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) - --- | How to group the item. -newtype Fingerprint - = Fingerprint T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) - --- | The title of the item. -newtype Title - = Title T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) - --- | A unique identifier for each item. -newtype UUID4 - = UUID4 UUID - deriving (Eq, Generic, Show) - -instance FromJSON UUID4 where - parseJSON v@(String s) = - maybe (typeMismatch "UUID4" v) (pure . UUID4) $ fromText s - parseJSON v = typeMismatch "UUID4" v - -instance ToJSON UUID4 where - toJSON (UUID4 u) = toJSON (toText u) - toEncoding (UUID4 u) = toEncoding (toText u) diff --git a/src/Rollbar/Item/Environment.hs b/src/Rollbar/Item/Environment.hs deleted file mode 100644 --- a/src/Rollbar/Item/Environment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-| - Module : Rollbar.Item.Environment - Description : The environment from which this package is running. - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental --} - -module Rollbar.Item.Environment - ( Environment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.String (IsString) - -import qualified Data.Text as T - --- | Should be something meaningful to your program. --- E.g. "development", "production", "staging" -newtype Environment - = Environment T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Hardcoded.hs b/src/Rollbar/Item/Hardcoded.hs deleted file mode 100644 --- a/src/Rollbar/Item/Hardcoded.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-| - Module : Rollbar.Item.Hardcoded - Description : Provides a way to hard code a value in JSOn - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental - - Probably this could live outside the package... --} - -module Rollbar.Item.Hardcoded - ( Hardcoded(..) - ) where - -import Data.Aeson - (FromJSON, ToJSON, Value(String), parseJSON, toEncoding, toJSON) -import Data.Aeson.Types (typeMismatch) -import Data.Text (pack) - -import GHC.Generics (Generic) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) - --- | This is basically 'Data.Proxy' with the variable restricted to 'Symbol'. --- It's mostly useful so a value can be insert into a JSON blob easily. -data Hardcoded (symbol :: Symbol) - = Hardcoded - deriving (Eq, Generic, Show) - -instance KnownSymbol symbol => ToJSON (Hardcoded symbol) where - toJSON = toJSON . symbolVal - toEncoding = toEncoding . symbolVal - -instance KnownSymbol symbol => FromJSON (Hardcoded symbol) where - parseJSON (String str) - | str == pack (symbolVal (Hardcoded :: Hardcoded symbol)) = pure Hardcoded - parseJSON v = typeMismatch "Hardcoded symbol" v diff --git a/src/Rollbar/Item/Internal/Notifier.hs b/src/Rollbar/Item/Internal/Notifier.hs deleted file mode 100644 --- a/src/Rollbar/Item/Internal/Notifier.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -{-| - Module : Rollbar.Item.Internal.Notifier - Description : Metadata about this actual package - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental - - Mostly, you shouldn't have to worry about this. --} - -module Rollbar.Item.Internal.Notifier - ( Notifier(..) - ) where - -import Data.Aeson - (FromJSON, ToJSON, defaultOptions, genericToEncoding, toEncoding) -import Data.Version (Version) - -import GHC.Generics (Generic) - -import Rollbar.Item.Hardcoded (Hardcoded) - --- | Metadata describing this package. -data Notifier - = Notifier - { name :: Hardcoded "wai-middleware-rollbar" - -- ^ The name of this package - , version :: Version - -- ^ The version of this package - } - deriving (Eq, Generic, Show) - -instance FromJSON Notifier -instance ToJSON Notifier where - toEncoding = genericToEncoding defaultOptions diff --git a/src/Rollbar/Item/Internal/Platform.hs b/src/Rollbar/Item/Internal/Platform.hs deleted file mode 100644 --- a/src/Rollbar/Item/Internal/Platform.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-| - Module : Rollbar.Item.Internal.Platform - Description : Metadata describing the platform this package is running on. - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental - - Mostly, you shouldn't have to worry about this. --} - -module Rollbar.Item.Internal.Platform - ( Platform(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.String (IsString) - -import qualified Data.Text as T - --- | Should be something meaningful to rollbar, like "linux". -newtype Platform - = Platform T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Level.hs b/src/Rollbar/Item/Level.hs deleted file mode 100644 --- a/src/Rollbar/Item/Level.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -{-| - Module : Rollbar.Item.Level - Description : The severity of the item. - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental --} - -module Rollbar.Item.Level - ( Level(..) - ) where - -import Data.Aeson - ( FromJSON - , ToJSON - , defaultOptions - , genericParseJSON - , genericToEncoding - , genericToJSON - , parseJSON - , toEncoding - , toJSON - ) -import Data.Aeson.Types (Options, constructorTagModifier) -import Data.Char (toLower) - -import GHC.Generics (Generic) - --- | Corresponds to the levels Rollbar allows in order of severity. -data Level - = Debug - | Info - | Warning - | Error - | Critical - deriving (Bounded, Enum, Eq, Generic, Ord, Show) - -instance FromJSON Level where - parseJSON = genericParseJSON options - -instance ToJSON Level where - toJSON = genericToJSON options - toEncoding = genericToEncoding options - -options :: Options -options = defaultOptions - { constructorTagModifier = fmap toLower - } diff --git a/src/Rollbar/Item/MissingHeaders.hs b/src/Rollbar/Item/MissingHeaders.hs deleted file mode 100644 --- a/src/Rollbar/Item/MissingHeaders.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# 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 - (FromJSON, KeyValue, ToJSON, object, parseJSON, toJSON, (.=)) -import Data.Bifunctor (bimap) -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 FromJSON (MissingHeaders headers) where - parseJSON v = MissingHeaders . fmap (bimap (mk . BS.pack) BS.pack) <$> parseJSON v - -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/Person.hs b/src/Rollbar/Item/Person.hs deleted file mode 100644 --- a/src/Rollbar/Item/Person.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -{-| - Module : Rollbar.Item.Person - Description : The user this item affects. - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental --} - -module Rollbar.Item.Person - ( Person(..) - , Id(..) - , Username(..) - , Email(..) - ) where - -import Data.Aeson - ( FromJSON - , ToJSON - , defaultOptions - , genericToEncoding - , genericToJSON - , toEncoding - , toJSON - ) -import Data.Aeson.Types (omitNothingFields) -import Data.String (IsString) - -import GHC.Generics (Generic) - -import qualified Data.Text as T - --- | The affected user. --- --- The 'Email' and 'Username' associated with the latest 'Id' --- will overwrite any previous. -data Person - = Person - { id :: Id - , username :: Maybe Username - , email :: Maybe Email - } - deriving (Eq, Generic, Show) - -instance FromJSON Person -instance ToJSON Person where - toJSON = genericToJSON defaultOptions { omitNothingFields = True } - toEncoding = genericToEncoding defaultOptions { omitNothingFields = True } - --- | The user's identifier. This uniquely identifies a 'Person' to Rollbar. -newtype Id - = Id T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) - --- | The user's name. -newtype Username - = Username T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) - --- | The user's email. -newtype Email - = Email T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Request.hs b/src/Rollbar/Item/Request.hs deleted file mode 100644 --- a/src/Rollbar/Item/Request.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-| - Module : Rollbar.Item.Request - Description : Data about the request sent to the server. - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental --} - -module Rollbar.Item.Request - ( Request(..) - , Get(..) - , IP(..) - , Method(..) - , MissingHeaders(..) - , QueryString(..) - , RawBody(..) - , URL(..) - , RemoveHeaders - ) where - -import Data.Aeson - ( FromJSON - , KeyValue - , ToJSON - , Value(Object, String) - , object - , pairs - , parseJSON - , toEncoding - , toJSON - , (.:) - , (.=) - ) -import Data.Aeson.Types (typeMismatch) -import Data.Bifunctor (bimap) -import Data.Maybe (catMaybes, fromMaybe) -import Data.String (IsString) - -import GHC.Generics (Generic) - -import Network.HTTP.Types (Query) -import Network.Socket (SockAddr(SockAddrInet), tupleToHostAddress) - -import Rollbar.Item.MissingHeaders - -import Text.Read (readMaybe) - -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 headers - = Request - { rawBody :: RawBody - , get :: Get - -- ^ Query parameters - , headers :: MissingHeaders headers - , method :: Method - , queryString :: QueryString - -- ^ The entire query string - , url :: URL - , userIP :: IP - -- ^ The client's IP address - } - deriving (Eq, Generic, Show) - --- | The raw request body as a 'BS.ByteString'. -newtype RawBody - = RawBody BS.ByteString - deriving (Eq, Generic, IsString, Show) - -instance FromJSON RawBody where - parseJSON v = RawBody . BS.pack <$> parseJSON v - -instance ToJSON RawBody where - toJSON (RawBody body) = toJSON (myDecodeUtf8 body) - toEncoding (RawBody body) = toEncoding (myDecodeUtf8 body) - --- | The query string parameters as a more useful data structure. -newtype Get - = Get Query - deriving (Eq, Generic, Show) - -instance FromJSON Get where - parseJSON v = Get . fmap (bimap BS.pack (fmap BS.pack)) <$> parseJSON v - -instance ToJSON Get where - toJSON (Get q) = object . catMaybes . queryKVs $ q - toEncoding (Get q) = pairs . mconcat . catMaybes . queryKVs $ q - -queryKVs :: forall kv. (KeyValue kv) => Query -> [Maybe kv] -queryKVs = fmap go - where - go :: (BS.ByteString, Maybe BS.ByteString) -> Maybe kv - go (key', val') = do - key <- myDecodeUtf8 key' - let val = val' >>= myDecodeUtf8 - pure (key .= val) - --- | The HTTP Verb -newtype Method - = Method BS.ByteString - deriving (Eq, Generic, Show) - -instance FromJSON Method where - parseJSON v = Method . BS.pack <$> parseJSON v - -instance ToJSON Method where - toJSON (Method q) = toJSON (myDecodeUtf8 q) - toEncoding (Method q) = toEncoding (myDecodeUtf8 q) - --- | The raw querystring. -newtype QueryString - = QueryString BS.ByteString - deriving (Eq, Generic, Show) - -instance FromJSON QueryString where - parseJSON v = QueryString . BS.pack <$> parseJSON v - -instance ToJSON QueryString where - toJSON (QueryString q) = toJSON (myDecodeUtf8' q) - toEncoding (QueryString q) = toEncoding (myDecodeUtf8' q) - --- | The IP address of the client. -newtype IP - = IP SockAddr - deriving (Eq, Generic, Show) - -instance FromJSON IP where - parseJSON v@(String s) = case T.splitOn "." s of - [a', b', c', d] -> case T.splitOn ":" d of - [e', f'] -> maybe (typeMismatch "IP" v) pure $ do - [a, b, c, e] <- traverse (readMaybe . T.unpack) [a', b', c', e'] - f <- (readMaybe . T.unpack) f' - pure . IP . SockAddrInet f $ tupleToHostAddress (a, b, c, e) - _ -> typeMismatch "IP" v - _ -> typeMismatch "IP" v - parseJSON v = typeMismatch "IP" v - -instance ToJSON IP where - toJSON (IP ip) = toJSON (show ip) - toEncoding (IP ip) = toEncoding (show ip) - -requestKVs :: (KeyValue kv, RemoveHeaders headers) => Request headers -> [kv] -requestKVs Request{..} = - [ "body" .= rawBody - , "GET" .= get - , "headers" .= headers - , "method" .= method - , "query_string" .= queryString - , "url" .= url - , "user_ip" .= userIP - ] - -instance FromJSON (Request headers) where - parseJSON (Object o) = - Request - <$> o .: "body" - <*> o .: "GET" - <*> o .: "headers" - <*> o .: "method" - <*> o .: "query_string" - <*> o .: "url" - <*> o .: "user_ip" - parseJSON v = typeMismatch "Request headers" v - -instance (RemoveHeaders headers) => ToJSON (Request headers) where - toJSON = object . requestKVs - toEncoding = pairs . mconcat . requestKVs - --- | The URL as a slightly more useful structure. -newtype URL - = URL (Maybe BS.ByteString, [T.Text]) - deriving (Eq, Generic, Show) - -prettyURL :: URL -> T.Text -prettyURL (URL (host, parts)) = - T.intercalate "/" (fromMaybe "" (host >>= myDecodeUtf8) : parts) - -instance FromJSON URL where - parseJSON (String s) = case T.splitOn "/" s of - host:parts | "http" `T.isPrefixOf` host -> pure $ URL (Just $ TE.encodeUtf8 host, parts) - parts -> pure $ URL (Nothing, parts) - parseJSON v = typeMismatch "URL" v - -instance ToJSON URL where - toJSON = toJSON . prettyURL - toEncoding = toEncoding . prettyURL - -myDecodeUtf8 :: BS.ByteString -> Maybe T.Text -myDecodeUtf8 = either (const Nothing) Just . TE.decodeUtf8' - -myDecodeUtf8' :: BS.ByteString -> T.Text -myDecodeUtf8' = fromMaybe "" . myDecodeUtf8 diff --git a/src/Rollbar/Item/Server.hs b/src/Rollbar/Item/Server.hs deleted file mode 100644 --- a/src/Rollbar/Item/Server.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{-| - Module : Rollbar.Item.Server - Description : Metadata about the server this package is running on. - Copyright : (c) Hardy Jones, 2017 - License : BSD3 - Maintainer : jones3.hardy@gmail.com - Stability : experimental --} - -module Rollbar.Item.Server - ( Server(..) - , Root(..) - , Branch(..) - ) where - -import Data.Aeson - ( FromJSON - , KeyValue - , ToJSON - , Value(Object) - , object - , pairs - , parseJSON - , toEncoding - , toJSON - , (.:) - , (.=) - ) -import Data.Aeson.Types (typeMismatch) -import Data.Maybe (catMaybes) -import Data.String (IsString) - -import GHC.Generics (Generic) - -import Network.HostName (HostName) - -import Rollbar.Item.CodeVersion (CodeVersion) - -import qualified Data.Text as T - --- | Information about the server using this package. -data Server - = Server - { host :: Maybe HostName - -- ^ The hostname of the server. - , root :: Maybe Root - -- ^ The root directory the server is running in. - , branch :: Maybe Branch - -- ^ The checked out branch the server is running on. - , serverCodeVersion :: Maybe CodeVersion - -- ^ The version of the server. - } - deriving (Eq, Generic, Show) - -serverKVs :: KeyValue kv => Server -> [Maybe kv] -serverKVs Server{..} = - [ ("host" .=) <$> host - , ("root" .=) <$> root - , ("branch" .=) <$> branch - , ("code_version" .=) <$> serverCodeVersion - ] - -instance FromJSON Server where - parseJSON (Object o) = - Server - <$> o .: "host" - <*> o .: "root" - <*> o .: "branch" - <*> o .: "code_version" - parseJSON v = typeMismatch "Server" v - -instance ToJSON Server where - toJSON = object . catMaybes . serverKVs - toEncoding = pairs . mconcat . catMaybes . serverKVs - --- | The root directory. -newtype Root - = Root T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) - --- | The git branch the server is running on. -newtype Branch - = Branch T.Text - deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import qualified Rollbar.Golden -import qualified Rollbar.Item.Data.Test -import qualified Rollbar.Item.MissingHeaders.Test -import qualified Rollbar.Item.Request.Test - -main :: IO () -main = do - Rollbar.Golden.main - Rollbar.Item.Data.Test.props - Rollbar.Item.MissingHeaders.Test.props - Rollbar.Item.Request.Test.props diff --git a/test/Rollbar/Golden.hs b/test/Rollbar/Golden.hs deleted file mode 100644 --- a/test/Rollbar/Golden.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Rollbar.Golden where - -import Data.Proxy (Proxy(Proxy)) - -import Rollbar.Item (Item) -import Rollbar.QuickCheck () - -import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs) -import Test.Hspec (hspec) - -main :: IO () -main = - hspec $ roundtripAndGoldenSpecs (Proxy :: Proxy (Item () '["Authorization"])) diff --git a/test/Rollbar/Item/Data/Test.hs b/test/Rollbar/Item/Data/Test.hs deleted file mode 100644 --- a/test/Rollbar/Item/Data/Test.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# 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) - -import Rollbar.Item -import Rollbar.QuickCheck () - -import Test.QuickCheck (conjoin, 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 - -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 deleted file mode 100644 --- a/test/Rollbar/Item/MissingHeaders/Test.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -module Rollbar.Item.MissingHeaders.Test where - -import Control.Lens ((&), (^@..)) - -import Data.Aeson (encode, toJSON) -import Data.Aeson.Lens (members) - -import Prelude hiding (error) - -import Rollbar.Item.MissingHeaders (MissingHeaders(..)) -import Rollbar.QuickCheck () - -import Test.QuickCheck (conjoin, quickCheck) - -import Data.Set as S - -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 = - "Authorization" `S.notMember` actual - where - actual = toJSON hs ^@.. members & fmap fst & S.fromList - -prop_encodingAuthorizationIsRemoved :: MissingHeaders '["Authorization"] -> Bool -prop_encodingAuthorizationIsRemoved hs = - "Authorization" `S.notMember` actual - where - actual = encode hs ^@.. members & fmap fst & S.fromList - -prop_valueX_AccessTokenIsRemoved :: MissingHeaders '["X-AccessToken"] -> Bool -prop_valueX_AccessTokenIsRemoved hs = - "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 = - "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 = - "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 = - "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 diff --git a/test/Rollbar/Item/Request/Test.hs b/test/Rollbar/Item/Request/Test.hs deleted file mode 100644 --- a/test/Rollbar/Item/Request/Test.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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 (members) -import Data.CaseInsensitive (original) - -import Prelude hiding (error) - -import Rollbar.Item.Request (MissingHeaders(..)) -import Rollbar.QuickCheck () - -import Test.QuickCheck (conjoin, quickCheck) - -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 diff --git a/test/Rollbar/QuickCheck.hs b/test/Rollbar/QuickCheck.hs deleted file mode 100644 --- a/test/Rollbar/QuickCheck.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -module Rollbar.QuickCheck where - -import Data.Bifunctor (bimap) -import Data.CaseInsensitive (mk) -import Data.Proxy (Proxy(Proxy)) - -import GHC.TypeLits (KnownSymbol, symbolVal) - -import Prelude hiding (error) - -import Rollbar.Item - -import Test.QuickCheck -import Test.QuickCheck.Modifiers (getASCIIString) - -import qualified Data.ByteString.Char8 as BSC8 -import qualified Data.Text as T - -instance Arbitrary a => Arbitrary (Item a '["Authorization"]) where - arbitrary = Item <$> arbitrary <*> arbitrary - -instance Arbitrary AccessToken where - arbitrary = AccessToken . T.pack . getASCIIString <$> arbitrary - -instance Arbitrary a => Arbitrary (Data a '["Authorization"]) where - arbitrary = do - env <- Environment . T.pack . getASCIIString <$> arbitrary - message <- fmap (MessageBody . T.pack . getASCIIString) <$> arbitrary - payload <- arbitrary - elements $ (\f -> f env message payload) <$> datas - -datas :: [Environment -> Maybe MessageBody -> a -> Data a '["Authorization"]] -datas = [debug, info, warning, error, critical] - -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/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.8.4 +version: 0.9.0 synopsis: Middleware that communicates to Rollbar. description: Middleware that communicates to Rollbar. homepage: https://github.com/joneshf/wai-middleware-rollbar#readme @@ -17,62 +17,19 @@ library hs-source-dirs: src exposed-modules: Network.Wai.Middleware.Rollbar - , Rollbar.API - , Rollbar.AccessToken - , Rollbar.Item - , Rollbar.Item.Body - , Rollbar.Item.CodeVersion - , Rollbar.Item.Data - , Rollbar.Item.Environment - , Rollbar.Item.Hardcoded - , Rollbar.Item.Level - , Rollbar.Item.MissingHeaders - , Rollbar.Item.Person - , Rollbar.Item.Request - , Rollbar.Item.Server - - , Rollbar.Item.Internal.Notifier - , Rollbar.Item.Internal.Platform - other-modules: Paths_wai_middleware_rollbar + , Network.Wai.Middleware.Rollbar.Payload build-depends: base >= 4.9 && < 5 , aeson >= 1.0 && < 1.3 , bytestring >= 0.10 && < 0.11 - , case-insensitive >= 1.2 && < 1.3 , hostname >= 1.0 && < 1.1 , http-client >= 0.5 && < 0.6 , http-conduit >= 2.2 && < 2.4 , http-types >= 0.9 && < 0.13 - , network >= 2.6 && < 2.7 + , rollbar-hs >= 0.1 && < 0.2 , text >= 1.2 && < 1.3 , time >= 1.6 && < 1.9 - , unordered-containers >= 0.2 && < 0.3 , uuid >= 1.3 && < 1.4 , 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.Golden - , Rollbar.Item.Data.Test - , Rollbar.Item.MissingHeaders.Test - , Rollbar.Item.Request.Test - , Rollbar.QuickCheck - build-depends: base - , QuickCheck >= 2.9 && < 2.12 - , aeson - , bytestring - , case-insensitive - , containers >= 0.5 && < 0.6 - , hspec >= 2.4 && < 2.5 - , hspec-golden-aeson >= 0.2 && < 0.6 - , lens >= 4.15 && < 4.17 - , lens-aeson >= 1.0 && < 1.1 - , text - , wai-middleware-rollbar default-language: Haskell2010 ghc-options: -Wall