diff --git a/bugsnag-haskell.cabal b/bugsnag-haskell.cabal --- a/bugsnag-haskell.cabal +++ b/bugsnag-haskell.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 36962ecc46dfa7d5ab30da6797310d06145ecdd5d2d487ab6f1ec237b259e721 +-- hash: 01ab548c1cccbe4991f8fcdae7003425379acff61d3a52d709841c2d174fd35c name: bugsnag-haskell -version: 0.0.1.3 +version: 0.0.2.0 synopsis: Bugsnag error reporter for Haskell description: Please see README.md category: Web @@ -27,10 +27,12 @@ src ghc-options: -Wall build-depends: - aeson >=1.3.0.0 + Glob >=0.9.0 + , aeson >=1.3.0.0 , base >=4.8.0 && <5 , bytestring , case-insensitive + , containers , http-client , http-client-tls , http-conduit @@ -50,6 +52,7 @@ Network.Bugsnag.App Network.Bugsnag.BeforeNotify Network.Bugsnag.Breadcrumb + Network.Bugsnag.CodeIndex Network.Bugsnag.Device Network.Bugsnag.Event Network.Bugsnag.Exception @@ -160,7 +163,9 @@ , hspec , text , time + , unliftio other-modules: + Network.Bugsnag.CodeIndexSpec Network.Bugsnag.ReportSpec Network.BugsnagSpec Paths_bugsnag_haskell 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 @@ -6,12 +6,16 @@ -- * Modifying the Exception , updateException + , updateStackFrames , filterStackFrames + , setStackFramesCode , setStackFramesInProject , setGroupingHash , setGroupingHashBy -- * Modifying the Event + , updateEventFromException + , updateEventFromOriginalException , updateEventFromSession , updateEventFromWaiRequest @@ -29,7 +33,10 @@ , setInfoSeverity ) where +import Control.Exception (Exception, fromException) +import Data.Maybe (fromMaybe) import Data.Text (Text) +import Network.Bugsnag.CodeIndex import Network.Bugsnag.Device import Network.Bugsnag.Event import Network.Bugsnag.Exception @@ -63,9 +70,6 @@ -- | Modify just the Exception part of an Event -- --- Technically this will modify all exceptions in the Event, but if you're using --- this library normally, there will be only one. --- -- This may be used to set more specific information for exception types in -- scope in your application: -- @@ -81,20 +85,26 @@ -- > _ -> ex -- updateException :: (BugsnagException -> BugsnagException) -> BeforeNotify -updateException f event = event { beExceptions = f <$> beExceptions event } +updateException f event = event { beException = f $ beException event } +-- | Apply a function to each @'BugsnagStackFrame'@ in the Exception +updateStackFrames :: (BugsnagStackFrame -> BugsnagStackFrame) -> BeforeNotify +updateStackFrames f = + updateException $ \ex -> ex { beStacktrace = map f $ beStacktrace ex } + -- | Filter out StackFrames matching a predicate filterStackFrames :: (BugsnagStackFrame -> Bool) -> BeforeNotify filterStackFrames p = updateException $ \ex -> ex { beStacktrace = filter p $ beStacktrace ex } +-- | Set @'bsfCode'@ using the given index +setStackFramesCode :: CodeIndex -> BeforeNotify +setStackFramesCode = updateStackFrames . attachBugsnagCode + -- | Set @'bsIsInProject'@ using the given predicate, applied to the Filename setStackFramesInProject :: (FilePath -> Bool) -> BeforeNotify -setStackFramesInProject p = updateException - $ \ex -> ex { beStacktrace = map updateStackFrames $ beStacktrace ex } - where - updateStackFrames :: BugsnagStackFrame -> BugsnagStackFrame - updateStackFrames sf = sf { bsfInProject = Just $ p $ bsfFile sf } +setStackFramesInProject p = + updateStackFrames $ \sf -> sf { bsfInProject = Just $ p $ bsfFile sf } -- | Set @'beGroupingHash'@ setGroupingHash :: Text -> BeforeNotify @@ -103,6 +113,45 @@ -- | Set @'beGroupingHash'@ based on the Event setGroupingHashBy :: (BugsnagEvent -> Maybe Text) -> BeforeNotify setGroupingHashBy f event = event { beGroupingHash = f event } + +-- | Update the @'BugsnagEvent'@ based on its @'BugsnagException'@ +-- +-- Use this instead of @'updateException'@ if you want to do other things to the +-- Event, such as set its @'beGroupingHash'@ based on the Exception. +-- +updateEventFromException :: (BugsnagException -> BeforeNotify) -> BeforeNotify +updateEventFromException f event = f (beException event) event + +-- | Update the @'BugsnagEvent'@ based on the original exception +-- +-- This allows updating the Event after casting to an exception type that this +-- library doesn't know about (e.g. @SqlError@). Because the result of your +-- function is itself a @'BeforeNotify'@, you can (and should) use other +-- helpers: +-- +-- @ +-- myBeforeNotify = +-- 'defaultBeforeNotify' +-- . 'updateEventFromOriginalException' asSqlError +-- . 'updateEventFromOriginalException' asHttpError +-- . -- ... +-- +-- asSqlError :: SqlError -> BeforeNotify +-- asSqlError SqlError{..} = +-- 'setGroupingHash' sqlErrorCode . 'updateException' $ \ex -> ex +-- { beErrorClass = sqlErrorCode +-- , beMessage = sqlErrorMessage +-- } +-- @ +-- +-- If there is no original exception, or the cast fails, the event is unchanged. +-- +updateEventFromOriginalException + :: Exception e => (e -> BeforeNotify) -> BeforeNotify +updateEventFromOriginalException f event = fromMaybe event $ do + someException <- beOriginalException $ beException event + yourException <- fromException someException + pure $ f yourException event -- | Set the events @'BugsnagEvent'@ and @'BugsnagDevice'@ updateEventFromWaiRequest :: Request -> BeforeNotify diff --git a/src/Network/Bugsnag/CodeIndex.hs b/src/Network/Bugsnag/CodeIndex.hs new file mode 100644 --- /dev/null +++ b/src/Network/Bugsnag/CodeIndex.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +module Network.Bugsnag.CodeIndex + ( CodeIndex + , buildCodeIndex + , findSourceRange + ) where + +import Data.List (genericLength) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Traversable (for) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax +import Numeric.Natural (Natural) +import System.FilePath.Glob (glob) + +newtype CodeIndex = CodeIndex + { unCodeIndex :: Map FilePath FileIndex } + deriving (Lift, Show) + +buildCodeIndex :: String -> Q Exp +buildCodeIndex p = do + index <- qRunIO $ buildCodeIndex' p + [|index|] + +buildCodeIndex' :: String -> IO CodeIndex +buildCodeIndex' p = do + paths <- glob p + CodeIndex . Map.fromList <$> traverse indexPath paths + where + indexPath :: FilePath -> IO (FilePath, FileIndex) + indexPath fp = (fp, ) <$> buildFileIndex fp + +data FileIndex = FileIndex + { fiSourceLines :: Map Natural Text + , fiLastLine :: Natural + } + deriving (Lift, Show) + +buildFileIndex :: FilePath -> IO FileIndex +buildFileIndex path = do + lns <- T.lines <$> T.readFile path + + pure FileIndex + { fiSourceLines = Map.fromList $ zip [0 ..] lns + , fiLastLine = genericLength lns - 1 + } + +findSourceRange + :: FilePath -> (Natural, Natural) -> CodeIndex -> Maybe [(Natural, Text)] +findSourceRange path (begin, end) index = do + FileIndex {..} <- Map.lookup path $ unCodeIndex index + + for [begin .. min end fiLastLine] + $ \n -> (n, ) <$> Map.lookup n fiSourceLines 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,15 +1,13 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Network.Bugsnag.Event ( BugsnagEvent(..) , bugsnagEvent ) where import Data.Aeson -import Data.Aeson.Ext -import Data.List.NonEmpty (NonEmpty) +import Data.Aeson.Types import Data.Text (Text) -import GHC.Generics import Network.Bugsnag.App import Network.Bugsnag.Breadcrumb import Network.Bugsnag.Device @@ -20,7 +18,7 @@ import Network.Bugsnag.User data BugsnagEvent = BugsnagEvent - { beExceptions :: NonEmpty BugsnagException + { beException :: BugsnagException , beBreadcrumbs :: Maybe [BugsnagBreadcrumb] , beRequest :: Maybe BugsnagRequest , beThreads :: Maybe [BugsnagThread] @@ -37,15 +35,33 @@ -- and I'm not sure yet how to resolve the naming clash with BugsnagSession. , beMetaData :: Maybe Value } - deriving Generic instance ToJSON BugsnagEvent where - toJSON = genericToJSON $ bsAesonOptions "be" - toEncoding = genericToEncoding $ bsAesonOptions "be" + -- | 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 + ] + where + -- For implementing "omit Nothing fields" + (.=?) :: ToJSON v => Text -> Maybe v -> [Pair] + (.=?) k = maybe [] (pure . (k .=)) -bugsnagEvent :: NonEmpty BugsnagException -> BugsnagEvent -bugsnagEvent exceptions = BugsnagEvent - { beExceptions = exceptions +bugsnagEvent :: BugsnagException -> BugsnagEvent +bugsnagEvent exception = BugsnagEvent + { beException = exception , beBreadcrumbs = Nothing , beRequest = Nothing , beThreads = Nothing 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 @@ -74,7 +74,7 @@ -- bugsnagExceptionFromSomeException :: SomeException -> BugsnagException bugsnagExceptionFromSomeException ex = - foldr go (bugsnagExceptionFromException ex) exCasters + foldr go (bugsnagExceptionWithParser parseStringException ex) exCasters where go :: Caster -> BugsnagException -> BugsnagException go (Caster caster) res = maybe res caster $ fromException ex @@ -82,7 +82,7 @@ exCasters :: [Caster] exCasters = [ Caster id - , Caster bugsnagExceptionFromErrorCall + , Caster $ bugsnagExceptionWithParser parseErrorCall , Caster $ bugsnagExceptionFromException @IOException , Caster $ bugsnagExceptionFromException @ArithException , Caster $ bugsnagExceptionFromException @ArrayException @@ -103,13 +103,13 @@ , Caster $ bugsnagExceptionFromException @TypeError ] --- | Construct a @'BugsnagException'@ from an @'ErrorCall'@ --- --- This type of exception may have @'HasCallStack'@ information. --- -bugsnagExceptionFromErrorCall :: ErrorCall -> BugsnagException -bugsnagExceptionFromErrorCall ex = - case parseErrorCall ex of +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 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 @@ -6,14 +6,16 @@ module Network.Bugsnag.Exception.Parse ( MessageWithStackFrames(..) , parseErrorCall + , parseStringException ) where -import Control.Exception (ErrorCall) +import Control.Exception (ErrorCall, Exception, SomeException) import Control.Monad (void) import Data.Bifunctor (first) import Data.Text (Text) import qualified Data.Text as T import Network.Bugsnag.StackFrame +import Numeric.Natural import Text.Parsec import Text.Parsec.String @@ -24,35 +26,89 @@ -- | Parse an @'ErrorCall'@ for @'HasCallStack'@ information parseErrorCall :: ErrorCall -> Either String MessageWithStackFrames -parseErrorCall = first show . parse (errorCallParser <* eof) "" . show +parseErrorCall = parse' errorCallParser +-- | Parse a @'StringException'@ for @'HasCallStack'@ information +-- +-- We accept this as @'SomeException'@ so that this library doesn't depend on +-- any one concrete library that has @'throwString'@ (there are two right now, +-- sigh.) +-- +parseStringException :: SomeException -> Either String MessageWithStackFrames +parseStringException = parse' stringExceptionParser + errorCallParser :: Parser MessageWithStackFrames errorCallParser = MessageWithStackFrames - <$> (T.pack <$> manyTill anyChar eol) - <*> (csHeader *> manyTill stackFrameParser eof) + <$> messageParser + <*> manyTill stackFrameParser eof + where + messageParser :: Parser Text + messageParser = do + msg <- T.pack <$> manyTill anyChar eol + msg <$ (string "CallStack (from HasCallStack):" *> eol) -csHeader :: Parser () -csHeader = string "CallStack (from HasCallStack):" *> eol + stackFrameParser :: Parser BugsnagStackFrame + stackFrameParser = do + func <- stackFrameFunctionTill $ string ", called at " + (path, ln, cl) <- stackFrameLocationTill $ eol <|> eof -stackFrameParser :: Parser BugsnagStackFrame -stackFrameParser = do - func <- spaces *> (T.pack <$> manyTill anyChar (char ',')) - path <- string " called at " *> manyTill anyChar (char ':') - ln <- read <$> manyTill digit (char ':') - cl <- read <$> manyTill digit (char ' ') + pure BugsnagStackFrame + { bsfFile = path + , bsfLineNumber = ln + , bsfColumnNumber = Just cl + , bsfMethod = func + , bsfInProject = Just True + , bsfCode = Nothing + } - void $ string "in " -- package:module +stringExceptionParser :: Parser MessageWithStackFrames +stringExceptionParser = MessageWithStackFrames + <$> messageParser + <*> manyTill stackFrameParser eof + where + messageParser :: Parser Text + messageParser = do + manyTill anyChar (try $ string "throwString called with:") *> eol *> eol + msg <- T.pack <$> manyTill anyChar eol + msg <$ (string "Called from:" *> eol) + + stackFrameParser :: Parser BugsnagStackFrame + stackFrameParser = do + func <- stackFrameFunctionTill $ string " (" + (path, ln, cl) <- stackFrameLocationTill $ char ')' *> eol <|> eof + + pure BugsnagStackFrame + { bsfFile = path + , bsfLineNumber = ln + , bsfColumnNumber = Just cl + , bsfMethod = func + , bsfInProject = Just True + , bsfCode = Nothing + } + +stackFrameFunctionTill :: Parser a -> Parser Text +stackFrameFunctionTill p = spaces *> (T.pack <$> manyTill anyChar p) + +stackFrameLocationTill :: Parser a -> Parser (FilePath, Natural, Natural) +stackFrameLocationTill p = do + result <- (,,) + <$> manyTill anyChar (char ':') + <*> (read <$> manyTill digit (char ':')) + <*> (read <$> manyTill digit (char ' ')) + + -- Ignore the "in package:module" part. TODO: we could use this to set + -- bsfInProject if we had some more knowledge about project packages. + void $ string "in " void $ manyTill anyChar $ char ':' - void $ manyTill anyChar $ eol <|> eof + void $ manyTill anyChar p + pure result - pure BugsnagStackFrame - { bsfFile = path - , bsfLineNumber = ln - , bsfColumnNumber = Just cl - , bsfMethod = func - , bsfInProject = Just True - , bsfCode = Nothing - } +parse' + :: Exception e + => Parser MessageWithStackFrames + -> e + -> Either String MessageWithStackFrames +parse' p = first show . parse (p <* eof) "" . show eol :: Parser () eol = void endOfLine 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 @@ -31,11 +31,11 @@ f . bsBeforeNotify settings . setGroupingHashBy (bsGroupingHash settings) + . maybe id setStackFramesCode (bsCodeIndex settings) . setStackFramesInProject (bsIsInProject settings) . filterStackFrames (bsFilterStackFrames settings) . createApp settings . bugsnagEvent - . pure $ bugsnagExceptionFromSomeException ex manager = bsHttpManager settings 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 @@ -12,11 +12,11 @@ ) where import Data.Aeson (FromJSON) -import qualified Data.List.NonEmpty as NE import Data.String import Data.Text (Text) import qualified Data.Text as T import Network.Bugsnag.BeforeNotify +import Network.Bugsnag.CodeIndex import Network.Bugsnag.Event import Network.Bugsnag.Exception import Network.Bugsnag.ReleaseStage @@ -87,6 +87,13 @@ -- It's more efficient, and ensures proper resource cleanup, to share a -- single manager across an application. Must be TLS-enabled. -- + , bsCodeIndex :: Maybe CodeIndex + -- ^ A @'CodeIndex'@ built at compile-time from project sources + -- + -- If set, this will be used to update StackFrames to include lines of + -- source code context as read out of this value. N.B. using this means + -- loading and keeping the source code for the entire project in memory. + -- } {-# DEPRECATED bsGroupingHash "use setGroupingHashBy with bsBeforeNotify" #-} @@ -106,13 +113,14 @@ , bsIsInProject = const True , bsFilterStackFrames = const True , bsHttpManager = manager + , bsCodeIndex = Nothing } -- | Should this @'BugsnagEvent'@ trigger notification? -- -- >>> :set -XOverloadedStrings -- >>> settings <- newBugsnagSettings "" --- >>> let event = bugsnagEvent $ pure $ bugsnagException "" "" [] +-- >>> let event = bugsnagEvent $ bugsnagException "" "" [] -- >>> bugsnagShouldNotify settings event -- True -- @@ -125,7 +133,7 @@ -- -- >>> let ignore = (== "IgnoreMe") . beErrorClass -- >>> let ignoreSettings = settings { bsIgnoreException = ignore } --- >>> let ignoreEvent = bugsnagEvent $ pure $ bugsnagException "IgnoreMe" "" [] +-- >>> let ignoreEvent = bugsnagEvent $ bugsnagException "IgnoreMe" "" [] -- >>> bugsnagShouldNotify ignoreSettings event -- True -- @@ -135,16 +143,8 @@ bugsnagShouldNotify :: BugsnagSettings -> BugsnagEvent -> Bool bugsnagShouldNotify settings event | bsReleaseStage settings `notElem` bsNotifyReleaseStages settings = False - | bsIgnoreException settings exception = False + | bsIgnoreException settings $ beException event = False | otherwise = True - where - exception - | NE.length (beExceptions event) == 1 = NE.head $ beExceptions event - | otherwise = error $ unlines - [ "Library misused. Event must have exactly one Exception when" - , " going through our notifyBugsnag functions. To send more than" - , " one Exception, drop down to reportError." - ] -- | Construct settings with a new, TLS-enabled @'Manager'@ -- 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 @@ -4,6 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} module Network.Bugsnag.StackFrame ( BugsnagCode(..) + , attachBugsnagCode , BugsnagStackFrame(..) , bugsnagStackFrame , currentStackFrame @@ -11,20 +12,40 @@ import Data.Aeson import Data.Aeson.Ext +import Data.Maybe (fromMaybe) import Data.Text (Text) import GHC.Generics import Instances.TH.Lift () import Language.Haskell.TH.Syntax +import Network.Bugsnag.CodeIndex import Numeric.Natural (Natural) -- | Lines of code surrounding the error -- --- Pairs of @(line-number, line-of-code)@, up to 3 on either side. There's no --- real way to support this in Haskell, so we always send @Nothing@. +-- Pairs of @(line-number, line-of-code)@, up to 3 on either side. -- newtype BugsnagCode = BugsnagCode [(Natural, Text)] deriving (Show, ToJSON) +-- | Attempt to attach a @'BugsnagCode'@ to a @'BugsnagStackFrame'@ +-- +-- Looks up the content in the Index by File/LineNumber and, if found, sets it +-- on the record. N.B. this will only operate on in-project StackFrames. +-- +attachBugsnagCode :: CodeIndex -> BugsnagStackFrame -> BugsnagStackFrame +attachBugsnagCode index sf = sf + { bsfCode = if fromMaybe True $ bsfInProject sf + then findBugsnagCode (bsfFile sf) (bsfLineNumber sf) index + else Nothing + } + +findBugsnagCode :: FilePath -> Natural -> CodeIndex -> Maybe BugsnagCode +findBugsnagCode path n = fmap BugsnagCode . findSourceRange path (begin, n + 3) + where + begin + | n < 3 = 0 + | otherwise = n - 3 + data BugsnagStackFrame = BugsnagStackFrame { bsfFile :: FilePath , bsfLineNumber :: Natural @@ -61,6 +82,8 @@ currentStackFrame :: Q Exp currentStackFrame = [|locStackFrame $(qLocation >>= liftLoc)|] +-- brittany-disable-next-binding + locStackFrame :: Loc -> Text -> BugsnagStackFrame locStackFrame (Loc path _ _ (ls, cs) _) func = BugsnagStackFrame @@ -74,6 +97,8 @@ -- assumed to be in end-user code. , bsfCode = Nothing } + +-- brittany-disable-next-binding -- Taken from monad-logger liftLoc :: Loc -> Q Exp diff --git a/test/Network/Bugsnag/CodeIndexSpec.hs b/test/Network/Bugsnag/CodeIndexSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Bugsnag/CodeIndexSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.Bugsnag.CodeIndexSpec + ( spec + ) where + +import Test.Hspec + +import Network.Bugsnag.CodeIndex + +spec :: Spec +spec = do + describe "CodeIndex" $ do + let index = $(buildCodeIndex "test/fixtures/index-project/**/*.hs") + + it "can find ranges within the file" $ do + let path = "test/fixtures/index-project/Foo.hs" + range = (0, 3) + sourceLines = + [ (0, "module Foo where") + , (1, "") + , (2, "data What = What") + , (3, " deriving Show") + ] + + findSourceRange path range index `shouldBe` Just sourceLines + + it "handles ranges that extend beyond bounds" $ do + let path = "test/fixtures/index-project/Foo.hs" + range = (6, 10) + sourceLines = + [(6, "what 0 = Just What"), (7, "what _ = Nothing")] + + findSourceRange path range index `shouldBe` Just sourceLines + + it "handles ranges that are totally beyond bounds" $ do + let path = "test/fixtures/index-project/Foo.hs" + range = (10, 12) + + findSourceRange path range index `shouldBe` Just [] + + it "handles missing files" $ do + findSourceRange "nope.hs" (0, 3) index `shouldBe` Nothing 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 @@ -18,12 +18,11 @@ it "is right for a minimally-specified report" $ do let report = bugsnagReport - [ bugsnagEvent $ pure - $ bugsnagException - "errorClass" - "message" - [ bugsnagStackFrame "src/Foo/Bar.hs" 10 "myFunction" - ] + [ 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 @@ -52,7 +51,7 @@ { brNotifier = bugsnagNotifier , brEvents = [ BugsnagEvent - { beExceptions = pure BugsnagException + { beException = BugsnagException { beErrorClass = "errorClass" , beMessage = Just "message" , beStacktrace = diff --git a/test/Network/BugsnagSpec.hs b/test/Network/BugsnagSpec.hs --- a/test/Network/BugsnagSpec.hs +++ b/test/Network/BugsnagSpec.hs @@ -10,6 +10,7 @@ import Control.Exception import Network.Bugsnag +import UnliftIO.Exception (throwString) brokenFunctionIO :: IO a brokenFunctionIO = throw $ bugsnagException @@ -22,6 +23,13 @@ sillyHead (x:_) = x sillyHead _ = error "empty list" +brokenFunction' :: HasCallStack => IO a +brokenFunction' = sillyHead' [] + +sillyHead' :: HasCallStack => [a] -> IO a +sillyHead' (x:_) = pure x +sillyHead' _ = throwString "empty list" + spec :: Spec spec = do describe "BugsnagException" $ do @@ -34,7 +42,7 @@ let frame = head $ beStacktrace ex bsfFile frame `shouldBe` "test/Network/BugsnagSpec.hs" - bsfLineNumber frame `shouldBe` 16 + bsfLineNumber frame `shouldBe` 17 bsfColumnNumber frame `shouldBe` Just 43 bsfMethod frame `shouldBe` "brokenFunctionIO" bsfInProject frame `shouldBe` Just True @@ -50,9 +58,26 @@ let frame = head $ beStacktrace ex bsfFile frame `shouldBe` "test/Network/BugsnagSpec.hs" - bsfLineNumber frame `shouldBe` 23 + bsfLineNumber frame `shouldBe` 24 bsfColumnNumber frame `shouldBe` Just 15 bsfMethod frame `shouldBe` "error" map bsfMethod (beStacktrace ex) `shouldBe` ["error", "sillyHead", "brokenFunction"] + + it "also parses StringException" $ do + e <- brokenFunction' `catch` pure + + let ex = bugsnagExceptionFromSomeException e + beErrorClass ex `shouldBe` "SomeException" + beMessage ex `shouldBe` Just "empty list" + beStacktrace ex `shouldSatisfy` ((== 3) . length) + + let frame = head $ beStacktrace ex + bsfFile frame `shouldBe` "test/Network/BugsnagSpec.hs" + bsfLineNumber frame `shouldBe` 31 + bsfColumnNumber frame `shouldBe` Just 16 + bsfMethod frame `shouldBe` "throwString" + + map bsfMethod (beStacktrace ex) + `shouldBe` ["throwString", "sillyHead'", "brokenFunction'"]