diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,26 @@ -## [*Unreleased*](https://github.com/pbrisbin/bugsnag-haskell/compare/v0.0.3.0...master) +## [_Unreleased_](https://github.com/pbrisbin/bugsnag-haskell/compare/v0.0.4.0...master) -None +None. +## [v0.0.4.0](https://github.com/pbrisbin/bugsnag-haskell/compare/v0.0.3.1...v0.0.4.0) + +- Fixed serialization of headers in BugsnagRequest + + Previously, headers were a list of: + + ``` + [(CI ByteString, ByteString)] + ``` + + So they serialized as an array, but Bugsnag only accepts objects for headers. + + To solve this, the `newtype BugsnagRequestHeaders` wraps the headers and has a + correct `ToJSON` instance. + +## [v0.0.3.1](https://github.com/pbrisbin/bugsnag-haskell/compare/v0.0.3.0...v0.0.3.1) + +- Tag SomeException with the underlying exception class + ## [v0.0.3.0](https://github.com/pbrisbin/bugsnag-haskell/compare/v0.0.2.2...v0.0.3.0) - Fix sensitive request header redacting @@ -29,17 +48,20 @@ ## [v0.0.1.3](https://github.com/pbrisbin/bugsnag-haskell/compare/v0.0.1.2...v0.0.1.3) -- Redact sensitive request headers by default [#31](https://github.com/pbrisbin/bugsnag-haskell/issues/31) +- Redact sensitive request headers by default + [#31](https://github.com/pbrisbin/bugsnag-haskell/issues/31) **NOTE**: this wasn't actually working at this point. It is actually fixed in v0.0.3.0. -- Deprecate Settings that should be `BeforeNotify` values [#32](https://github.com/pbrisbin/bugsnag-haskell/issues/32) +- Deprecate Settings that should be `BeforeNotify` values + [#32](https://github.com/pbrisbin/bugsnag-haskell/issues/32) - `bugsnagShouldNotify` operates after any `BeforeNotify` changes ## [v0.0.1.2](https://github.com/pbrisbin/bugsnag-haskell/tree/v0.0.1.2) -- Make App Version an opaque `Text`, not a structured `Version` ([@MaxGabriel](https://github.com/pbrisbin/bugsnag-haskell/pull/29)) +- Make App Version an opaque `Text`, not a structured `Version` + ([@MaxGabriel](https://github.com/pbrisbin/bugsnag-haskell/pull/29)) ## [v0.0.1.1](https://github.com/pbrisbin/bugsnag-haskell/tree/v0.0.1.1) diff --git a/DocTest.hs b/DocTest.hs --- a/DocTest.hs +++ b/DocTest.hs @@ -1,6 +1,21 @@ -module Main (main) where +module Main + ( main + ) +where +import Prelude + +import Data.Aeson +import qualified Data.Yaml as Yaml import Test.DocTest +newtype Package = Package [String] + +instance FromJSON Package where + parseJSON = + withObject "Package" $ \o -> Package <$> o .: "default-extensions" + main :: IO () -main = doctest ["-isrc", "src/"] +main = do + Package extensions <- Yaml.decodeFileThrow "package.yaml" + doctest $ ["-isrc", "src/"] <> map ("-X" <>) extensions diff --git a/bugsnag-haskell.cabal b/bugsnag-haskell.cabal --- a/bugsnag-haskell.cabal +++ b/bugsnag-haskell.cabal @@ -1,13 +1,13 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: a71bc66ddcfe6442810073ecaf19f31bea964f76eced2a28882753d54c829618 +-- hash: 29c38ed61343fc8899e7a70afac5583415798394fe6c7c1a6fbbf30575f59cd9 name: bugsnag-haskell -version: 0.0.3.1 +version: 0.0.4.0 synopsis: Bugsnag error reporter for Haskell description: Please see README.md category: Web @@ -35,6 +35,7 @@ Network.Bugsnag.App Network.Bugsnag.BeforeNotify Network.Bugsnag.Breadcrumb + Network.Bugsnag.BugsnagRequestHeaders Network.Bugsnag.CodeIndex Network.Bugsnag.Device Network.Bugsnag.Event @@ -56,7 +57,8 @@ Paths_bugsnag_haskell hs-source-dirs: src - ghc-options: -Wall + default-extensions: BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies + ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-import-lists -Wno-all-missed-specialisations build-depends: Glob >=0.9.0 , aeson >=1.3.0.0 @@ -85,7 +87,8 @@ Paths_bugsnag_haskell hs-source-dirs: examples/cli - ghc-options: -Wall + default-extensions: BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies + ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-import-lists -Wno-all-missed-specialisations build-depends: base >=4.11.0 && <5 , bugsnag-haskell @@ -99,7 +102,8 @@ Paths_bugsnag_haskell hs-source-dirs: examples/simple - ghc-options: -Wall + default-extensions: BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies + ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-import-lists -Wno-all-missed-specialisations build-depends: base >=4.11.0 && <5 , bugsnag-haskell @@ -113,7 +117,8 @@ Paths_bugsnag_haskell hs-source-dirs: examples/warp - ghc-options: -Wall + default-extensions: BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies + ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-import-lists -Wno-all-missed-specialisations build-depends: base >=4.11.0 && <5 , bugsnag-haskell @@ -129,11 +134,11 @@ Paths_bugsnag_haskell hs-source-dirs: examples/yesod - ghc-options: -Wall + default-extensions: BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies + ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-import-lists -Wno-all-missed-specialisations build-depends: base >=4.11.0 && <5 , bugsnag-haskell - , exceptions , unliftio , wai , warp @@ -149,10 +154,13 @@ Paths_bugsnag_haskell hs-source-dirs: ./. - ghc-options: -Wall -Wall + default-extensions: BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies + ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-import-lists -Wno-all-missed-specialisations build-depends: - base >=4.11.0 && <5 + aeson + , base >=4.11.0 && <5 , doctest + , yaml default-language: Haskell2010 test-suite spec @@ -165,7 +173,8 @@ Paths_bugsnag_haskell hs-source-dirs: test - ghc-options: -Wall + default-extensions: BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies + ghc-options: -Weverything -Wno-safe -Wno-unsafe -Wno-missing-import-lists -Wno-all-missed-specialisations build-depends: aeson , aeson-qq diff --git a/examples/cli/Main.hs b/examples/cli/Main.hs --- a/examples/cli/Main.hs +++ b/examples/cli/Main.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where +module Main + ( main + ) +where + +import Prelude import Control.Exception (catch) import Network.Bugsnag diff --git a/examples/simple/Main.hs b/examples/simple/Main.hs --- a/examples/simple/Main.hs +++ b/examples/simple/Main.hs @@ -1,7 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -module Main (main) where +module Main + ( main + ) +where + +import Prelude + import Control.Exception (toException) import Network.Bugsnag @@ -9,7 +14,7 @@ main = do settings <- newBugsnagSettings "BUGSNAG_API_KEY" - notifyBugsnag settings $ toException - $ bugsnagException "Error" "message" - [ $(currentStackFrame) "myFunction" - ] + notifyBugsnag settings $ toException $ bugsnagException + "Error" + "message" + [$(currentStackFrame) "myFunction"] diff --git a/examples/warp/Main.hs b/examples/warp/Main.hs --- a/examples/warp/Main.hs +++ b/examples/warp/Main.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where +module Main + ( main + ) +where +import Prelude + import Control.Concurrent (forkIO) import Control.Exception (SomeException) import Control.Monad (void, when) @@ -15,9 +19,9 @@ warpSettings = do settings <- newBugsnagSettings "BUGSNAG_API_KEY" - pure - $ setPort 3000 - $ setOnException (bugsnagOnException settings) defaultSettings + pure $ setPort 3000 $ setOnException + (bugsnagOnException settings) + defaultSettings -- N.B. This may some day be provided by a bugsnag-warp package bugsnagOnException :: BugsnagSettings -> Maybe Request -> SomeException -> IO () diff --git a/examples/yesod/Main.hs b/examples/yesod/Main.hs --- a/examples/yesod/Main.hs +++ b/examples/yesod/Main.hs @@ -1,12 +1,16 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +#if __GLASGOW_HASKELL__ >= 808 +{-# OPTIONS_GHC -fno-warn-missing-deriving-strategies #-} +#endif + module Main (main) where + +import Prelude import Control.Exception (SomeException, fromException, toException) import Control.Monad (unless) diff --git a/src/Data/Aeson/Ext.hs b/src/Data/Aeson/Ext.hs --- a/src/Data/Aeson/Ext.hs +++ b/src/Data/Aeson/Ext.hs @@ -1,16 +1,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} + -- | -- -- Orphan instances and shared @'Generic'@ JSON options. -- module Data.Aeson.Ext ( bsAesonOptions - ) where + ) +where +import Prelude + import Data.Aeson import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI import Data.Char (toLower) import Data.List (stripPrefix) import Data.Maybe (fromMaybe) @@ -19,9 +21,6 @@ instance ToJSON ByteString where toJSON = String . decodeUtf8 -instance ToJSON a => ToJSON (CI a) where - toJSON = toJSON . CI.original - -- | Our custom Aeson @'Options'@ -- -- Omits @'Nothing'@ fields, and drops/lowers accordingly: @@ -49,4 +48,4 @@ lowerFirst :: String -> String lowerFirst [] = [] -lowerFirst (x:rest) = toLower x : rest +lowerFirst (x : rest) = toLower x : rest diff --git a/src/Network/Bugsnag.hs b/src/Network/Bugsnag.hs --- a/src/Network/Bugsnag.hs +++ b/src/Network/Bugsnag.hs @@ -12,11 +12,13 @@ -- module Network.Bugsnag ( module X - ) where + ) +where import Network.Bugsnag.App as X import Network.Bugsnag.BeforeNotify as X import Network.Bugsnag.Breadcrumb as X +import Network.Bugsnag.BugsnagRequestHeaders as X import Network.Bugsnag.Device as X import Network.Bugsnag.Event as X import Network.Bugsnag.Exception as X diff --git a/src/Network/Bugsnag/App.hs b/src/Network/Bugsnag/App.hs --- a/src/Network/Bugsnag/App.hs +++ b/src/Network/Bugsnag/App.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} module Network.Bugsnag.App ( BugsnagApp(..) , bugsnagApp - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.Text (Text) @@ -22,7 +24,7 @@ , baDurationInForeground :: Maybe Natural , baInForeground :: Maybe Bool } - deriving Generic + deriving stock Generic instance ToJSON BugsnagApp where toJSON = genericToJSON $ bsAesonOptions "ba" diff --git a/src/Network/Bugsnag/BeforeNotify.hs b/src/Network/Bugsnag/BeforeNotify.hs --- a/src/Network/Bugsnag/BeforeNotify.hs +++ b/src/Network/Bugsnag/BeforeNotify.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.Bugsnag.BeforeNotify ( BeforeNotify @@ -32,11 +30,15 @@ , setWarningSeverity , setErrorSeverity , setInfoSeverity - ) where + ) +where +import Prelude + import Control.Exception (Exception, fromException) import Data.Maybe (fromMaybe) import Data.Text (Text) +import Network.Bugsnag.BugsnagRequestHeaders import Network.Bugsnag.CodeIndex import Network.Bugsnag.Device import Network.Bugsnag.Event @@ -45,7 +47,7 @@ import Network.Bugsnag.Session import Network.Bugsnag.Severity import Network.Bugsnag.StackFrame -import Network.HTTP.Types.Header (Header, HeaderName) +import Network.HTTP.Types.Header (HeaderName) import Network.Wai (Request) type BeforeNotify = BugsnagEvent -> BugsnagEvent @@ -180,18 +182,14 @@ -- | -- -- >>> let headers = [("Authorization", "secret"), ("X-Foo", "Bar")] --- >>> let req = bugsnagRequest { brHeaders = Just headers } +-- >>> let req = bugsnagRequest { brHeaders = Just $ bugsnagRequestHeaders headers } -- >>> brHeaders $ redactHeaders ["Authorization"] req --- Just [("Authorization",""),("X-Foo","Bar")] +-- Just (BugsnagRequestHeaders {unBugsnagRequestHeaders = [("Authorization",""),("X-Foo","Bar")]}) -- redactHeaders :: [HeaderName] -> BugsnagRequest -> BugsnagRequest redactHeaders headers request = request - { brHeaders = map redactHeader <$> brHeaders request + { brHeaders = redactBugsnagRequestHeaders headers <$> brHeaders request } - where - redactHeader :: Header -> Header - redactHeader (k, _) | k `elem` headers = (k, "") - redactHeader h = h -- | Set the Event's Request -- diff --git a/src/Network/Bugsnag/Breadcrumb.hs b/src/Network/Bugsnag/Breadcrumb.hs --- a/src/Network/Bugsnag/Breadcrumb.hs +++ b/src/Network/Bugsnag/Breadcrumb.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Network.Bugsnag.Breadcrumb ( BugsnagBreadcrumbType(..) , BugsnagBreadcrumb(..) , bugsnagBreadcrumb - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.Text (Text) @@ -21,7 +22,7 @@ | StateBreadcrumb | ErrorBreadcrumb | ManualBreadcrumb - deriving Generic + deriving stock Generic instance ToJSON BugsnagBreadcrumbType where toJSON = genericToJSON $ bsAesonOptions "Breadcrumb" @@ -33,17 +34,14 @@ , bbType :: BugsnagBreadcrumbType , bbMetaData :: Maybe Value } - deriving Generic + deriving stock Generic instance ToJSON BugsnagBreadcrumb where toJSON = genericToJSON $ bsAesonOptions "bb" toEncoding = genericToEncoding $ bsAesonOptions "bb" bugsnagBreadcrumb - :: UTCTime - -> Text - -> BugsnagBreadcrumbType - -> BugsnagBreadcrumb + :: UTCTime -> Text -> BugsnagBreadcrumbType -> BugsnagBreadcrumb bugsnagBreadcrumb timestamp name typ = BugsnagBreadcrumb { bbTimestamp = timestamp , bbName = name diff --git a/src/Network/Bugsnag/BugsnagRequestHeaders.hs b/src/Network/Bugsnag/BugsnagRequestHeaders.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/BugsnagRequestHeaders.hs @@ -0,0 +1,49 @@ +module Network.Bugsnag.BugsnagRequestHeaders + ( BugsnagRequestHeaders + , bugsnagRequestHeaders + , redactBugsnagRequestHeaders + ) +where + +import Prelude + +import Data.Aeson +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Encoding as TE +import Network.HTTP.Types + +-- | Wrapper around Wai's 'RequestHeaders', for custom 'ToJSON' instance +newtype BugsnagRequestHeaders = BugsnagRequestHeaders + { unBugsnagRequestHeaders :: RequestHeaders + } + deriving stock (Show, Eq, Ord) + +instance ToJSON BugsnagRequestHeaders where + toJSON = object . map headerToKeyValue . unBugsnagRequestHeaders + toEncoding = pairs . foldMap headerToKeyValue . unBugsnagRequestHeaders + +headerToKeyValue :: KeyValue kv => (CI ByteString, ByteString) -> kv +headerToKeyValue (name, value) = + TE.decodeUtf8 (CI.original name) .= String (TE.decodeUtf8 value) + +-- | Create 'BugsnagRequestHeaders' +bugsnagRequestHeaders :: RequestHeaders -> BugsnagRequestHeaders +bugsnagRequestHeaders = BugsnagRequestHeaders + +-- | For headers with the given names, replace their value with "". +-- +-- This is intended to remove sensitive data from headers. +redactBugsnagRequestHeaders + :: [HeaderName] -> BugsnagRequestHeaders -> BugsnagRequestHeaders +redactBugsnagRequestHeaders redactList = mapBugsnagRequestHeaders redactHeader + where + redactHeader :: Header -> Header + redactHeader (k, _) | k `elem` redactList = (k, "") + redactHeader h = h + +mapBugsnagRequestHeaders + :: (Header -> Header) -> BugsnagRequestHeaders -> BugsnagRequestHeaders +mapBugsnagRequestHeaders fn (BugsnagRequestHeaders headers) = + BugsnagRequestHeaders $ map fn headers diff --git a/src/Network/Bugsnag/CodeIndex.hs b/src/Network/Bugsnag/CodeIndex.hs --- a/src/Network/Bugsnag/CodeIndex.hs +++ b/src/Network/Bugsnag/CodeIndex.hs @@ -1,14 +1,17 @@ {-# LANGUAGE DeriveLift #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} + module Network.Bugsnag.CodeIndex ( CodeIndex , buildCodeIndex , findSourceRange - ) where + ) +where +import Prelude + import Data.List (genericLength) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -22,9 +25,22 @@ import System.FilePath.Glob (glob) newtype CodeIndex = CodeIndex - { unCodeIndex :: Map FilePath FileIndex } - deriving (Lift, Show) + { unCodeIndex :: Map FilePath FileIndex + } + deriving stock (Lift, Show) +-- | Index code for attaching lines of source to 'StackFrame's +-- +-- See the 'bsCodeIndex' field of 'BugsnagSettings' for details. +-- +-- **WARNING**: This feature comes with a number of caveats. +-- +-- 1. It's not frequently used and may not work. +-- 2. It (probably) means you will be holding all indexed source code in memory +-- during the life of your process. +-- 3. In larger projects, it will embed substantial amounts of source code in a +-- single file, which can significantly degrade compilation time. +-- buildCodeIndex :: String -> Q Exp buildCodeIndex p = do index <- qRunIO $ buildCodeIndex' p @@ -42,7 +58,7 @@ { fiSourceLines :: Map Natural Text , fiLastLine :: Natural } - deriving (Lift, Show) + deriving stock (Lift, Show) buildFileIndex :: FilePath -> IO FileIndex buildFileIndex path = do diff --git a/src/Network/Bugsnag/Device.hs b/src/Network/Bugsnag/Device.hs --- a/src/Network/Bugsnag/Device.hs +++ b/src/Network/Bugsnag/Device.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} module Network.Bugsnag.Device ( Bytes(..) , BugsnagDevice(..) , bugsnagDevice , bugsnagDeviceFromWaiRequest - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.ByteString (ByteString) @@ -20,7 +20,8 @@ import Text.Read (readMaybe) import Web.UAParser -newtype Bytes = Bytes Natural deriving ToJSON +newtype Bytes = Bytes Natural + deriving newtype ToJSON data BugsnagDevice = BugsnagDevice { bdHostname :: Maybe Text @@ -38,7 +39,7 @@ , bdJailBroken :: Maybe Bool , bdOrientation :: Maybe Text } - deriving Generic + deriving stock Generic instance ToJSON BugsnagDevice where toJSON = genericToJSON $ bsAesonOptions "bd" diff --git a/src/Network/Bugsnag/Event.hs b/src/Network/Bugsnag/Event.hs --- a/src/Network/Bugsnag/Event.hs +++ b/src/Network/Bugsnag/Event.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Network.Bugsnag.Event ( BugsnagEvent(..) , bugsnagEvent - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Types import Data.Text (Text) @@ -38,22 +39,20 @@ instance ToJSON BugsnagEvent where -- | Explicit instance needed to send @'beException'@ as @exceptions@ - toJSON BugsnagEvent {..} = object - $ "exceptions" .= [beException] - : concat - [ "breadcrumbs" .=? beBreadcrumbs - , "request" .=? beRequest - , "threads" .=? beThreads - , "context" .=? beContext - , "groupingHash" .=? beGroupingHash - , "unhandled" .=? beUnhandled - , "severity" .=? beSeverity - , "severityReason" .=? beSeverityReason - , "user" .=? beUser - , "app" .=? beApp - , "device" .=? beDevice - , "metaData" .=? beMetaData - ] + toJSON BugsnagEvent {..} = object $ "exceptions" .= [beException] : concat + [ "breadcrumbs" .=? beBreadcrumbs + , "request" .=? beRequest + , "threads" .=? beThreads + , "context" .=? beContext + , "groupingHash" .=? beGroupingHash + , "unhandled" .=? beUnhandled + , "severity" .=? beSeverity + , "severityReason" .=? beSeverityReason + , "user" .=? beUser + , "app" .=? beApp + , "device" .=? beDevice + , "metaData" .=? beMetaData + ] where -- For implementing "omit Nothing fields" (.=?) :: ToJSON v => Text -> Maybe v -> [Pair] diff --git a/src/Network/Bugsnag/Exception.hs b/src/Network/Bugsnag/Exception.hs --- a/src/Network/Bugsnag/Exception.hs +++ b/src/Network/Bugsnag/Exception.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} + module Network.Bugsnag.Exception ( BugsnagException(..) , bugsnagException , bugsnagExceptionFromSomeException - ) where + ) +where +import Prelude + import Control.Exception import Data.Aeson import Data.Proxy (Proxy(..)) @@ -35,10 +34,10 @@ , beStacktrace :: [BugsnagStackFrame] , beOriginalException :: Maybe SomeException } - deriving (Generic, Show) + deriving stock (Generic, Show) instance ToJSON BugsnagException where - toJSON BugsnagException{..} = object + toJSON BugsnagException {..} = object [ "errorClass" .= beErrorClass , "message" .= beMessage , "stacktrace" .= beStacktrace @@ -64,7 +63,7 @@ -- -- @'BugsnagException'@s are left as-is, and @'ErrorCall'@ exceptions are parsed -- for @'HasCallStack'@ information to use as @stacktrace@. Otherwise, we --- attempt to determine @errorClass@ and we use the @'show'@n exception as +-- attempt to determine @errorClass@ and we use @'displayException'@ as -- @message@. -- -- >>> import Control.Arrow @@ -74,7 +73,7 @@ -- bugsnagExceptionFromSomeException :: SomeException -> BugsnagException bugsnagExceptionFromSomeException ex = foldr go seed exCasters - where + where go :: Caster -> BugsnagException -> BugsnagException go (Caster caster) res = maybe res caster $ fromException ex @@ -83,21 +82,17 @@ } exCasters :: [Caster] -exCasters = - [ Caster id - , Caster $ bugsnagExceptionWithParser parseErrorCall - ] +exCasters = [Caster id, Caster $ bugsnagExceptionWithParser parseErrorCall] bugsnagExceptionWithParser :: Exception e => (e -> Either String MessageWithStackFrames) -> e -> BugsnagException -bugsnagExceptionWithParser p ex = - case p ex of - Left _ -> bugsnagExceptionFromException ex - Right (MessageWithStackFrames message stacktrace) -> - bugsnagException (exErrorClass ex) message stacktrace +bugsnagExceptionWithParser p ex = case p ex of + Left _ -> bugsnagExceptionFromException ex + Right (MessageWithStackFrames message stacktrace) -> + bugsnagException (exErrorClass ex) message stacktrace -- | Construct a @'BugsnagException'@ from an @'Exception'@ -- @@ -107,7 +102,7 @@ -- bugsnagExceptionFromException :: Exception e => e -> BugsnagException bugsnagExceptionFromException ex = - (bugsnagException (exErrorClass ex) (T.pack $ show ex) []) + (bugsnagException (exErrorClass ex) (T.pack $ displayException ex) []) { beOriginalException = Just $ toException ex } @@ -119,5 +114,5 @@ -- >>> exErrorClass (undefined :: SomeException) -- "SomeException" -- -exErrorClass :: forall e. Exception e => e -> Text +exErrorClass :: forall e . Exception e => e -> Text exErrorClass _ = T.pack $ show $ typeRep $ Proxy @e diff --git a/src/Network/Bugsnag/Exception/Parse.hs b/src/Network/Bugsnag/Exception/Parse.hs --- a/src/Network/Bugsnag/Exception/Parse.hs +++ b/src/Network/Bugsnag/Exception/Parse.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -- | -- -- Parse error messages for @'HasCallStack'@ information. @@ -7,7 +6,10 @@ ( MessageWithStackFrames(..) , parseErrorCall , parseStringException - ) where + ) +where + +import Prelude import Control.Exception (ErrorCall, Exception, SomeException) import Control.Monad (void) diff --git a/src/Network/Bugsnag/Notifier.hs b/src/Network/Bugsnag/Notifier.hs --- a/src/Network/Bugsnag/Notifier.hs +++ b/src/Network/Bugsnag/Notifier.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -- | -- -- Static values about this notifier itself. @@ -7,8 +5,11 @@ module Network.Bugsnag.Notifier ( BugsnagNotifier , bugsnagNotifier - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.Text (Text) @@ -22,7 +23,7 @@ , bnVersion :: Version , bnUrl :: Text } - deriving Generic + deriving stock Generic instance ToJSON BugsnagNotifier where toJSON = genericToJSON $ bsAesonOptions "bn" diff --git a/src/Network/Bugsnag/Notify.hs b/src/Network/Bugsnag/Notify.hs --- a/src/Network/Bugsnag/Notify.hs +++ b/src/Network/Bugsnag/Notify.hs @@ -1,8 +1,11 @@ module Network.Bugsnag.Notify ( notifyBugsnag , notifyBugsnagWith - ) where + ) +where +import Prelude + import Control.Exception (SomeException) import Control.Monad (when) import Data.Maybe (isJust) @@ -67,4 +70,3 @@ , baReleaseStage = Just $ bsReleaseStage settings } } - diff --git a/src/Network/Bugsnag/ReleaseStage.hs b/src/Network/Bugsnag/ReleaseStage.hs --- a/src/Network/Bugsnag/ReleaseStage.hs +++ b/src/Network/Bugsnag/ReleaseStage.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} module Network.Bugsnag.ReleaseStage ( BugsnagReleaseStage(..) - ) where + ) +where +import Prelude + import Data.Aeson import Data.Text (Text) @@ -12,7 +13,7 @@ | StagingReleaseStage | ProductionReleaseStage | CustomReleaseStage Text - deriving (Eq, Show) + deriving stock (Eq, Show) instance FromJSON BugsnagReleaseStage where parseJSON = withText "ReleaseStage" $ \case diff --git a/src/Network/Bugsnag/Report.hs b/src/Network/Bugsnag/Report.hs --- a/src/Network/Bugsnag/Report.hs +++ b/src/Network/Bugsnag/Report.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} module Network.Bugsnag.Report ( BugsnagReport(..) , bugsnagReport - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import GHC.Generics @@ -14,14 +16,12 @@ { brNotifier :: BugsnagNotifier , brEvents :: [BugsnagEvent] } - deriving Generic + deriving stock Generic instance ToJSON BugsnagReport where toJSON = genericToJSON $ bsAesonOptions "br" toEncoding = genericToEncoding $ bsAesonOptions "br" bugsnagReport :: [BugsnagEvent] -> BugsnagReport -bugsnagReport events = BugsnagReport - { brNotifier = bugsnagNotifier - , brEvents = events - } +bugsnagReport events = + BugsnagReport { brNotifier = bugsnagNotifier, brEvents = events } diff --git a/src/Network/Bugsnag/Reporter.hs b/src/Network/Bugsnag/Reporter.hs --- a/src/Network/Bugsnag/Reporter.hs +++ b/src/Network/Bugsnag/Reporter.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -- | -- -- Report an error to Bugsnag @@ -10,8 +9,11 @@ -- module Network.Bugsnag.Reporter ( reportError - ) where + ) +where +import Prelude + import Control.Monad (void) import Data.Text.Encoding (encodeUtf8) import Network.Bugsnag.Report @@ -25,7 +27,7 @@ void $ httpNoBody request manager where key = encodeUtf8 $ unBugsnagApiKey apiKey - setupRequest - = setRequestBodyJSON report - . setRequestHeader "Bugsnag-Api-Key" [key] - . setRequestHeader "Bugsnag-Payload-Version" ["4"] + setupRequest = + setRequestBodyJSON report + . setRequestHeader "Bugsnag-Api-Key" [key] + . setRequestHeader "Bugsnag-Payload-Version" ["4"] diff --git a/src/Network/Bugsnag/Request.hs b/src/Network/Bugsnag/Request.hs --- a/src/Network/Bugsnag/Request.hs +++ b/src/Network/Bugsnag/Request.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} + module Network.Bugsnag.Request ( BugsnagRequest(..) , bugsnagRequest @@ -8,6 +7,8 @@ ) where +import Prelude + import Control.Applicative ((<|>)) import Data.Aeson import Data.Aeson.Ext @@ -16,6 +17,7 @@ import Data.IP import Data.Maybe (fromMaybe) import GHC.Generics +import Network.Bugsnag.BugsnagRequestHeaders import Network.HTTP.Types import Network.Socket import Network.Wai @@ -23,12 +25,12 @@ -- | The web request being handled when the error was encountered data BugsnagRequest = BugsnagRequest { brClientIp :: Maybe ByteString - , brHeaders :: Maybe RequestHeaders + , brHeaders :: Maybe BugsnagRequestHeaders , brHttpMethod :: Maybe Method , brUrl :: Maybe ByteString , brReferer :: Maybe ByteString } - deriving Generic + deriving stock Generic instance ToJSON BugsnagRequest where toJSON = genericToJSON $ bsAesonOptions "br" @@ -49,7 +51,7 @@ bugsnagRequestFromWaiRequest request = bugsnagRequest { brClientIp = requestRealIp request <|> Just (sockAddrToIp $ remoteHost request) - , brHeaders = Just $ requestHeaders request + , brHeaders = Just $ bugsnagRequestHeaders $ requestHeaders request , brHttpMethod = Just $ requestMethod request , brUrl = Just $ requestUrl request , brReferer = requestHeaderReferer request @@ -87,8 +89,13 @@ <> rawPathInfo request <> rawQueryString request where + clientProtocol :: ByteString clientProtocol = if isSecure request then "https" else "http" + + requestHost :: Request -> ByteString requestHost = fromMaybe "" . requestHeaderHost + + requestProtocol :: ByteString requestProtocol = fromMaybe clientProtocol $ lookup "X-Forwarded-Proto" $ requestHeaders request diff --git a/src/Network/Bugsnag/Session.hs b/src/Network/Bugsnag/Session.hs --- a/src/Network/Bugsnag/Session.hs +++ b/src/Network/Bugsnag/Session.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + -- | -- -- @@ -6,8 +8,11 @@ module Network.Bugsnag.Session ( BugsnagSession(..) , bugsnagSession - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.Text (Text) @@ -19,7 +24,7 @@ , bsContext :: Maybe Text , bsMetaData :: Maybe Value } - deriving Generic + deriving stock Generic instance ToJSON BugsnagSession where toJSON = genericToJSON $ bsAesonOptions "bs" diff --git a/src/Network/Bugsnag/Settings.hs b/src/Network/Bugsnag/Settings.hs --- a/src/Network/Bugsnag/Settings.hs +++ b/src/Network/Bugsnag/Settings.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- -- @@ -9,8 +8,11 @@ , newBugsnagSettings , bugsnagSettings , bugsnagShouldNotify - ) where + ) +where +import Prelude + import Data.Aeson (FromJSON) import Data.String import Data.Text (Text) @@ -26,7 +28,7 @@ newtype BugsnagApiKey = BugsnagApiKey { unBugsnagApiKey :: Text } - deriving (FromJSON, IsString) + deriving newtype (FromJSON, IsString) instance Show BugsnagApiKey where show = T.unpack . unBugsnagApiKey diff --git a/src/Network/Bugsnag/Severity.hs b/src/Network/Bugsnag/Severity.hs --- a/src/Network/Bugsnag/Severity.hs +++ b/src/Network/Bugsnag/Severity.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Network.Bugsnag.Severity ( BugsnagSeverity(..) , BugsnagSeverityReason(..) , BugsnagSeverityReasonAttributes(..) , bugsnagSeverityReasonAttributes , BugsnagSeverityReasonType(..) - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.Text (Text) @@ -17,7 +18,7 @@ = ErrorSeverity | WarningSeverity | InfoSeverity - deriving Generic + deriving stock Generic instance ToJSON BugsnagSeverity where toJSON = genericToJSON $ bsAesonOptions "Severity" @@ -39,7 +40,7 @@ | HandledErrorReasonType | HandledPanicReasonType | UserContextSetSeverityReasonType - deriving Generic + deriving stock Generic instance ToJSON BugsnagSeverityReasonType where toJSON = genericToJSON $ bsAesonOptions "ReasonType" @@ -52,7 +53,7 @@ , bsraViolationType :: Maybe Text , bsraErrorClass :: Maybe Text } - deriving Generic + deriving stock Generic instance ToJSON BugsnagSeverityReasonAttributes where toJSON = genericToJSON $ bsAesonOptions "bsra" @@ -62,7 +63,7 @@ { bsrType :: BugsnagSeverityReasonType , bsrAttributes :: BugsnagSeverityReasonAttributes } - deriving Generic + deriving stock Generic instance ToJSON BugsnagSeverityReason where toJSON = genericToJSON $ bsAesonOptions "bsr" diff --git a/src/Network/Bugsnag/StackFrame.hs b/src/Network/Bugsnag/StackFrame.hs --- a/src/Network/Bugsnag/StackFrame.hs +++ b/src/Network/Bugsnag/StackFrame.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} + module Network.Bugsnag.StackFrame ( BugsnagCode(..) , attachBugsnagCode , BugsnagStackFrame(..) , bugsnagStackFrame , currentStackFrame - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.Text (Text) @@ -24,7 +26,7 @@ -- Pairs of @(line-number, line-of-code)@, up to 3 on either side. -- newtype BugsnagCode = BugsnagCode [(Natural, Text)] - deriving (Show, ToJSON) + deriving newtype (Show, ToJSON) -- | Attempt to attach a @'BugsnagCode'@ to a @'BugsnagStackFrame'@ -- @@ -50,7 +52,7 @@ , bsfInProject :: Maybe Bool , bsfCode :: Maybe BugsnagCode } - deriving (Generic, Show) + deriving stock (Generic, Show) instance ToJSON BugsnagStackFrame where toJSON = genericToJSON $ bsAesonOptions "bsf" diff --git a/src/Network/Bugsnag/Thread.hs b/src/Network/Bugsnag/Thread.hs --- a/src/Network/Bugsnag/Thread.hs +++ b/src/Network/Bugsnag/Thread.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} module Network.Bugsnag.Thread ( BugsnagThread(..) , bugsnagThread - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.Text (Text) @@ -15,15 +17,12 @@ , btName :: Maybe Text , btStacktrace :: Maybe [BugsnagStackFrame] } - deriving Generic + deriving stock Generic instance ToJSON BugsnagThread where toJSON = genericToJSON $ bsAesonOptions "bt" toEncoding = genericToEncoding $ bsAesonOptions "bt" bugsnagThread :: BugsnagThread -bugsnagThread = BugsnagThread - { btId = Nothing - , btName = Nothing - , btStacktrace = Nothing - } +bugsnagThread = + BugsnagThread { btId = Nothing, btName = Nothing, btStacktrace = Nothing } diff --git a/src/Network/Bugsnag/User.hs b/src/Network/Bugsnag/User.hs --- a/src/Network/Bugsnag/User.hs +++ b/src/Network/Bugsnag/User.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveGeneric #-} module Network.Bugsnag.User ( BugsnagUser(..) , bugsnagUser - ) where + ) +where +import Prelude + import Data.Aeson import Data.Aeson.Ext import Data.Text (Text) @@ -14,7 +16,7 @@ , buEmailAddress :: Maybe Text , buUsername :: Maybe Text } - deriving Generic + deriving stock Generic instance ToJSON BugsnagUser where toJSON = genericToJSON $ bsAesonOptions "bu" diff --git a/test/Network/Bugsnag/CodeIndexSpec.hs b/test/Network/Bugsnag/CodeIndexSpec.hs --- a/test/Network/Bugsnag/CodeIndexSpec.hs +++ b/test/Network/Bugsnag/CodeIndexSpec.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-} + module Network.Bugsnag.CodeIndexSpec ( spec - ) where + ) +where -import Test.Hspec +import Prelude import Network.Bugsnag.CodeIndex +import Test.Hspec spec :: Spec spec = do diff --git a/test/Network/Bugsnag/ReportSpec.hs b/test/Network/Bugsnag/ReportSpec.hs --- a/test/Network/Bugsnag/ReportSpec.hs +++ b/test/Network/Bugsnag/ReportSpec.hs @@ -1,29 +1,30 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} + module Network.Bugsnag.ReportSpec ( spec - ) where + ) +where -import Test.Hspec +import Prelude import Data.Aeson import Data.Aeson.QQ (aesonQQ) import Data.Text (Text) import Data.Time (getCurrentTime) import Network.Bugsnag +import Test.Hspec spec :: Spec spec = do describe "JSON payload" $ do it "is right for a minimally-specified report" $ do - let report = - bugsnagReport - [ bugsnagEvent $ bugsnagException - "errorClass" - "message" - [ bugsnagStackFrame "src/Foo/Bar.hs" 10 "myFunction" - ] - ] + let + report = bugsnagReport + [ bugsnagEvent $ bugsnagException + "errorClass" + "message" + [bugsnagStackFrame "src/Foo/Bar.hs" 10 "myFunction"] + ] -- N.B. we don't worry about the notifier object since it would need -- updating on version bumps and is a simple, static value. @@ -46,16 +47,16 @@ it "is right for a mostly-specified report" $ do now <- getCurrentTime - let report = - BugsnagReport - { brNotifier = bugsnagNotifier - , brEvents = - [ BugsnagEvent - { beException = BugsnagException - { beErrorClass = "errorClass" - , beMessage = Just "message" - , beStacktrace = - [ BugsnagStackFrame + let + report = BugsnagReport + { brNotifier = bugsnagNotifier + , brEvents = + [ BugsnagEvent + { beException = BugsnagException + { beErrorClass = "errorClass" + , beMessage = Just "message" + , beStacktrace = + [ BugsnagStackFrame { bsfFile = "src/Foo/Bar.hs" , bsfLineNumber = 10 , bsfColumnNumber = Just 12 @@ -63,53 +64,63 @@ , bsfInProject = Just True , bsfCode = Nothing } - ] - , beOriginalException = Nothing - } - , beBreadcrumbs = Just - [ bugsnagBreadcrumb now "here" NavigationBreadcrumb - , bugsnagBreadcrumb now "there" NavigationBreadcrumb - ] - , beRequest = Just bugsnagRequest - { brClientIp = Just "127.0.0.1" - , brHeaders = Just [] - , brHttpMethod = Just "POST" - , brUrl = Just "https://example.com" - } - , beThreads = Just - [ bugsnagThread - { btId = Just "1" - , btName = Just "thread-1" - } - ] - , beContext = Just "app" - , beGroupingHash = Nothing - , beUnhandled = Just False - , beSeverity = Just WarningSeverity - , beSeverityReason = Just BugsnagSeverityReason - { bsrType = UnhandledExceptionReasonType - , bsrAttributes = bugsnagSeverityReasonAttributes - { bsraErrorType = Just "reason" - , bsraLevel = Just "1" - , bsraSignalType = Just "SIGKILL" - } - } - , beUser = Just bugsnagUser - { buId = Just "1" - , buUsername = Just "pbrisbin" - } - , beApp = Just bugsnagApp - { baId = Just "1" - , baVersion = Just "1.0.0" - } - , beDevice = Nothing - , beMetaData = Just $ object - [ "foo" .= ("bar" :: Text) - , "baz" .= ("bat" :: Text) - ] - } - ] - } + ] + , beOriginalException = Nothing + } + , beBreadcrumbs = Just + [ bugsnagBreadcrumb + now + "here" + NavigationBreadcrumb + , bugsnagBreadcrumb + now + "there" + NavigationBreadcrumb + ] + , beRequest = Just bugsnagRequest + { brClientIp = Just "127.0.0.1" + , brHeaders = Just (bugsnagRequestHeaders []) + , brHttpMethod = Just "POST" + , brUrl = Just "https://example.com" + } + , beThreads = + Just + [ bugsnagThread + { btId = Just "1" + , btName = Just "thread-1" + } + ] + , beContext = Just "app" + , beGroupingHash = Nothing + , beUnhandled = Just False + , beSeverity = Just WarningSeverity + , beSeverityReason = Just BugsnagSeverityReason + { bsrType = UnhandledExceptionReasonType + , bsrAttributes = + bugsnagSeverityReasonAttributes + { bsraErrorType = Just "reason" + , bsraLevel = Just "1" + , bsraSignalType = Just "SIGKILL" + } + } + , beUser = Just bugsnagUser + { buId = Just "1" + , buUsername = Just "pbrisbin" + } + , beApp = Just bugsnagApp + { baId = Just "1" + , baVersion = Just "1.0.0" + } + , beDevice = Nothing + , beMetaData = + Just + $ object + [ "foo" .= ("bar" :: Text) + , "baz" .= ("bat" :: Text) + ] + } + ] + } toJSON report `shouldBe` [aesonQQ| { @@ -152,7 +163,7 @@ "clientIp": "127.0.0.1", "httpMethod": "POST", "url": "https://example.com", - "headers": [] + "headers": {} }, "unhandled": false, "metaData": { diff --git a/test/Network/BugsnagSpec.hs b/test/Network/BugsnagSpec.hs --- a/test/Network/BugsnagSpec.hs +++ b/test/Network/BugsnagSpec.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} + module Network.BugsnagSpec ( spec - ) where + ) +where -import Test.Hspec +import Prelude import Control.Exception import Network.Bugsnag +import Test.Hspec import UnliftIO.Exception (throwString) brokenFunctionIO :: IO a diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,2 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} {-# OPTIONS_GHC -F -pgmF hspec-discover #-}