diff --git a/patrol.cabal b/patrol.cabal --- a/patrol.cabal +++ b/patrol.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: patrol -version: 1.0.0.11 +version: 1.0.1.0 synopsis: Sentry SDK description: Patrol is a Sentry SDK. build-type: Simple @@ -22,7 +22,7 @@ manual: True common library - build-depends: base ^>=4.19.0.0 || ^>=4.20.0.0 || ^>=4.21.0.0 + build-depends: base ^>=4.19 || ^>=4.20 || ^>=4.21 default-language: Haskell2010 ghc-options: -Weverything @@ -51,14 +51,15 @@ import: library autogen-modules: Paths_patrol build-depends: - aeson ^>=2.1.2.1 || ^>=2.2.2.0, - bytestring ^>=0.11.4.0 || ^>=0.12.0.2, - case-insensitive ^>=1.2.1.0, + aeson ^>=2.1.2.1 || ^>=2.2.2, + bytestring ^>=0.11.4 || ^>=0.12.0.2, + case-insensitive ^>=1.2.1, containers ^>=0.6.7 || ^>=0.7, exceptions ^>=0.10.7, http-client ^>=0.7.17, + http-client-tls ^>=0.3.6.4, http-types ^>=0.12.4, - network-uri ^>=2.6.4.2 || ^>=2.7.0.0, + network-uri ^>=2.6.4.2 || ^>=2.7, text ^>=2.0.2 || ^>=2.1, time ^>=1.12.2 || ^>=1.14, uuid ^>=1.3.15, @@ -85,6 +86,7 @@ Patrol.Type.DebugMeta Patrol.Type.DeviceContext Patrol.Type.Dsn + Patrol.Type.Envelope Patrol.Type.ErrorType Patrol.Type.Event Patrol.Type.EventId @@ -95,6 +97,8 @@ Patrol.Type.Frame Patrol.Type.Geo Patrol.Type.GpuContext + Patrol.Type.Headers + Patrol.Type.Item Patrol.Type.Level Patrol.Type.LogEntry Patrol.Type.MachException @@ -130,7 +134,6 @@ bytestring, case-insensitive, containers, - exceptions, hspec ^>=2.11.8, http-client, http-types, @@ -161,6 +164,7 @@ Patrol.Type.DebugMetaSpec Patrol.Type.DeviceContextSpec Patrol.Type.DsnSpec + Patrol.Type.EnvelopeSpec Patrol.Type.ErrorTypeSpec Patrol.Type.EventIdSpec Patrol.Type.EventProcessingErrorSpec @@ -171,6 +175,8 @@ Patrol.Type.FrameSpec Patrol.Type.GeoSpec Patrol.Type.GpuContextSpec + Patrol.Type.HeadersSpec + Patrol.Type.ItemSpec Patrol.Type.LevelSpec Patrol.Type.LogEntrySpec Patrol.Type.MachExceptionSpec diff --git a/source/library/Patrol.hs b/source/library/Patrol.hs --- a/source/library/Patrol.hs +++ b/source/library/Patrol.hs @@ -1,5 +1,7 @@ module Patrol - ( Patrol.Exception.Problem.Problem, + ( Patrol.Client.captureException, + Patrol.Client.captureExceptionWith, + Patrol.Exception.Problem.Problem, Patrol.Type.AppContext.AppContext, Patrol.Type.AppleDebugImage.AppleDebugImage, Patrol.Type.Breadcrumb.Breadcrumb, @@ -14,7 +16,10 @@ Patrol.Type.DebugMeta.DebugMeta, Patrol.Type.DeviceContext.DeviceContext, Patrol.Type.Dsn.Dsn, + Patrol.Type.Envelope.Envelope, Patrol.Type.ErrorType.ErrorType, + Patrol.Type.Headers.Headers, + Patrol.Type.Item.Item, Patrol.Type.Event.Event, Patrol.Type.EventId.EventId, Patrol.Type.EventProcessingError.EventProcessingError, @@ -50,6 +55,7 @@ ) where +import qualified Patrol.Client import qualified Patrol.Exception.Problem import qualified Patrol.Type.AppContext import qualified Patrol.Type.AppleDebugImage @@ -65,6 +71,7 @@ import qualified Patrol.Type.DebugMeta import qualified Patrol.Type.DeviceContext import qualified Patrol.Type.Dsn +import qualified Patrol.Type.Envelope import qualified Patrol.Type.ErrorType import qualified Patrol.Type.Event import qualified Patrol.Type.EventId @@ -75,6 +82,8 @@ import qualified Patrol.Type.Frame import qualified Patrol.Type.Geo import qualified Patrol.Type.GpuContext +import qualified Patrol.Type.Headers +import qualified Patrol.Type.Item import qualified Patrol.Type.Level import qualified Patrol.Type.LogEntry import qualified Patrol.Type.MachException diff --git a/source/library/Patrol/Client.hs b/source/library/Patrol/Client.hs --- a/source/library/Patrol/Client.hs +++ b/source/library/Patrol/Client.hs @@ -3,12 +3,52 @@ import qualified Control.Monad.Catch as Catch import qualified Control.Monad.IO.Class as IO import qualified Data.Aeson as Aeson +import qualified Data.Text as Text +import qualified GHC.Stack as Stack import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Client.TLS as Tls import qualified Patrol.Exception.Problem as Problem import qualified Patrol.Type.Dsn as Dsn +import qualified Patrol.Type.Envelope as Envelope import qualified Patrol.Type.Event as Event import qualified Patrol.Type.Response as Response +import qualified System.Environment as Environment +-- | Capture an exception by sending it to Sentry. The DSN is read from the +-- @SENTRY_DSN@ environment variable. To customize the behavior, use +-- 'captureExceptionWith'. +captureException :: + (Catch.Exception e, IO.MonadIO io, Catch.MonadThrow io) => + e -> + io Response.Response +captureException e = do + dsn <- do + maybeString <- IO.liftIO $ Environment.lookupEnv "SENTRY_DSN" + Dsn.fromText $ maybe Text.empty Text.pack maybeString + captureExceptionWith (const Nothing) pure dsn e + +captureExceptionWith :: + (Catch.Exception e, IO.MonadIO io, Catch.MonadThrow io) => + -- | How to get a 'Stack.CallStack' from a 'Catch.SomeException'. Use + -- @'const' 'Nothing'@ if you don't want to get a call stack. + (Catch.SomeException -> Maybe Stack.CallStack) -> + -- | How to modify the 'Envelope.Envelope' before it is sent. Use @'pure'@ if + -- you don't want to modify the envelope. + (Envelope.Envelope -> io Envelope.Envelope) -> + Dsn.Dsn -> + e -> + io Response.Response +captureExceptionWith getCallStack modifyEnvelope dsn e = do + initialEnvelope <- Envelope.fromException getCallStack dsn e + envelope <- modifyEnvelope initialEnvelope + request <- Envelope.intoRequest dsn envelope + manager <- Tls.newTlsManager + response <- IO.liftIO $ Client.httpLbs request manager + either (Catch.throwM . Problem.Problem . mappend "invalid response body: ") pure + . Aeson.eitherDecode + $ Client.responseBody response + +-- TODO: Deprecate. store :: (IO.MonadIO io, Catch.MonadThrow io) => Client.Manager -> diff --git a/source/library/Patrol/Constant.hs b/source/library/Patrol/Constant.hs --- a/source/library/Patrol/Constant.hs +++ b/source/library/Patrol/Constant.hs @@ -10,6 +10,9 @@ applicationJson :: ByteString.ByteString applicationJson = Text.encodeUtf8 $ Text.pack "application/json" +applicationXSentryEnvelope :: ByteString.ByteString +applicationXSentryEnvelope = Text.encodeUtf8 $ Text.pack "application/x-sentry-envelope" + sentryVersion :: Text.Text sentryVersion = Text.singleton '7' diff --git a/source/library/Patrol/Type/ClientSdkInfo.hs b/source/library/Patrol/Type/ClientSdkInfo.hs --- a/source/library/Patrol/Type/ClientSdkInfo.hs +++ b/source/library/Patrol/Type/ClientSdkInfo.hs @@ -4,6 +4,7 @@ import qualified Data.Text as Text import qualified Patrol.Extra.Aeson as Aeson import qualified Patrol.Type.ClientSdkPackage as ClientSdkPackage +import qualified Patrol.Version as Version -- | data ClientSdkInfo = ClientSdkInfo @@ -30,4 +31,11 @@ name = Text.empty, packages = [], version = Text.empty + } + +patrol :: ClientSdkInfo +patrol = + empty + { name = Text.pack "patrol", + version = Version.text } diff --git a/source/library/Patrol/Type/Dsn.hs b/source/library/Patrol/Type/Dsn.hs --- a/source/library/Patrol/Type/Dsn.hs +++ b/source/library/Patrol/Type/Dsn.hs @@ -23,6 +23,11 @@ } deriving (Eq, Show) +fromText :: (Catch.MonadThrow m) => Text.Text -> m Dsn +fromText text = case Uri.parseURI (Text.unpack text) of + Nothing -> Catch.throwM $ Problem.Problem "invalid URI" + Just uri -> fromUri uri + fromUri :: (Catch.MonadThrow m) => Uri.URI -> m Dsn fromUri uri = do theProtocol <- maybe (Catch.throwM $ Problem.Problem "invalid scheme") pure . Text.stripSuffix (Text.singleton ':') . Text.pack $ Uri.uriScheme uri diff --git a/source/library/Patrol/Type/Envelope.hs b/source/library/Patrol/Type/Envelope.hs new file mode 100644 --- /dev/null +++ b/source/library/Patrol/Type/Envelope.hs @@ -0,0 +1,92 @@ +module Patrol.Type.Envelope where + +import qualified Control.Monad.Catch as Catch +import qualified Control.Monad.IO.Class as IO +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Maybe as Maybe +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding +import qualified GHC.Stack as Stack +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Types as Http +import qualified Patrol.Constant as Constant +import qualified Patrol.Extra.List as List +import qualified Patrol.Type.ClientSdkInfo as ClientSdkInfo +import qualified Patrol.Type.Dsn as Dsn +import qualified Patrol.Type.Event as Event +import qualified Patrol.Type.Headers as Headers +import qualified Patrol.Type.Item as Item + +-- | +data Envelope = Envelope + { headers :: Headers.Headers, + items :: [Item.Item] + } + deriving (Eq, Show) + +fromException :: + (Catch.Exception e, IO.MonadIO io) => + (Catch.SomeException -> Maybe Stack.CallStack) -> + Dsn.Dsn -> + e -> + io Envelope +fromException getCallStack dsn = + fmap (fromEvent dsn) + . Event.fromException getCallStack + +fromEvent :: Dsn.Dsn -> Event.Event -> Envelope +fromEvent dsn event = + Envelope + { headers = + Headers.fromObject + . KeyMap.fromList + $ Maybe.catMaybes + [ Just (Key.fromString "dsn", Aeson.toJSON $ Dsn.intoUri dsn), + Just (Key.fromString "sdk", Aeson.toJSON ClientSdkInfo.patrol), + (,) (Key.fromString "sent_at") . Aeson.toJSON <$> Event.timestamp event + ], + items = [Item.fromEvent event] + } + +intoRequest :: (Catch.MonadThrow m) => Dsn.Dsn -> Envelope -> m Client.Request +intoRequest dsn envelope = do + request <- + Client.parseUrlThrow $ + mconcat + [ Text.unpack $ Dsn.protocol dsn, + "://", + Text.unpack $ Dsn.host dsn, + maybe "" ((':' :) . show) $ Dsn.port dsn, + Text.unpack $ Dsn.path dsn, + "api/", + Text.unpack $ Dsn.projectId dsn, + "/envelope/" + ] + let body = + LazyByteString.toStrict + . Builder.toLazyByteString + $ serialize envelope + pure + request + { Client.method = Http.methodPost, + Client.requestHeaders = + List.insertAll + [ (Http.hContentLength, Encoding.encodeUtf8 . Text.pack . show $ ByteString.length body), + (Http.hContentType, Constant.applicationXSentryEnvelope), + (Http.hUserAgent, Encoding.encodeUtf8 Constant.userAgent), + (Constant.xSentryAuth, Dsn.intoAuthorization dsn) + ] + $ Client.requestHeaders request, + Client.requestBody = Client.RequestBodyBS body + } + +serialize :: Envelope -> Builder.Builder +serialize envelope = + Headers.serialize (headers envelope) + <> Builder.char7 '\n' + <> foldMap ((<> Builder.char7 '\n') . Item.serialize) (items envelope) diff --git a/source/library/Patrol/Type/Event.hs b/source/library/Patrol/Type/Event.hs --- a/source/library/Patrol/Type/Event.hs +++ b/source/library/Patrol/Type/Event.hs @@ -8,6 +8,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Time as Time +import qualified GHC.Stack as Stack import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Types as Http import qualified Patrol.Constant as Constant @@ -129,21 +130,44 @@ version = Text.empty } -new :: (IO.MonadIO io) => io Event -new = do +initial :: Event +initial = + empty + { environment = Text.pack "production", + level = Just Level.Error, + platform = Just Platform.Haskell, + type_ = Just EventType.Default, + version = Constant.sentryVersion + } + +setEventId :: (IO.MonadIO io) => Event -> io Event +setEventId event = do theEventId <- EventId.random + pure event {eventId = theEventId} + +setTimestamp :: (IO.MonadIO io) => Event -> io Event +setTimestamp event = do theTimestamp <- IO.liftIO Time.getCurrentTime + pure event {timestamp = Just theTimestamp} + +new :: (IO.MonadIO io) => io Event +new = do + withEventId <- setEventId initial + setTimestamp withEventId + +fromException :: + (Catch.Exception e, IO.MonadIO io) => + (Catch.SomeException -> Maybe Stack.CallStack) -> + e -> + io Event +fromException getCallStack e = do + event <- new pure - empty - { environment = Text.pack "production", - eventId = theEventId, - level = Just Level.Error, - platform = Just Platform.Haskell, - timestamp = Just theTimestamp, - type_ = Just EventType.Default, - version = Constant.sentryVersion + event + { exception = Just $ Exceptions.fromException getCallStack e } +-- TODO: Deprecate. intoRequest :: (Catch.MonadThrow m) => Dsn.Dsn -> Event -> m Client.Request intoRequest dsn event = do theRequest <- diff --git a/source/library/Patrol/Type/Exception.hs b/source/library/Patrol/Type/Exception.hs --- a/source/library/Patrol/Type/Exception.hs +++ b/source/library/Patrol/Type/Exception.hs @@ -4,6 +4,7 @@ import qualified Data.Aeson as Aeson import qualified Data.Text as Text import qualified Data.Typeable as Typeable +import qualified GHC.Stack as Stack import qualified Patrol.Extra.Aeson as Aeson import qualified Patrol.Type.Mechanism as Mechanism import qualified Patrol.Type.Stacktrace as Stacktrace @@ -41,9 +42,14 @@ value = Text.empty } -fromSomeException :: Catch.SomeException -> Exception -fromSomeException (Catch.SomeException e) = +fromException :: + (Catch.Exception e) => + (Catch.SomeException -> Maybe Stack.CallStack) -> + e -> + Exception +fromException getCallStack e = empty - { type_ = Text.pack . show $ Typeable.typeOf e, + { stacktrace = fmap Stacktrace.fromCallStack . getCallStack $ Catch.toException e, + type_ = Text.pack . show $ Typeable.typeOf e, value = Text.pack $ Catch.displayException e } diff --git a/source/library/Patrol/Type/Exceptions.hs b/source/library/Patrol/Type/Exceptions.hs --- a/source/library/Patrol/Type/Exceptions.hs +++ b/source/library/Patrol/Type/Exceptions.hs @@ -1,6 +1,8 @@ module Patrol.Type.Exceptions where +import qualified Control.Monad.Catch as Catch import qualified Data.Aeson as Aeson +import qualified GHC.Stack as Stack import qualified Patrol.Extra.Aeson as Aeson import qualified Patrol.Type.Exception as Exception @@ -20,4 +22,14 @@ empty = Exceptions { values = [] + } + +fromException :: + (Catch.Exception e) => + (Catch.SomeException -> Maybe Stack.CallStack) -> + e -> + Exceptions +fromException getCallStack e = + Exceptions + { values = [Exception.fromException getCallStack e] } diff --git a/source/library/Patrol/Type/Headers.hs b/source/library/Patrol/Type/Headers.hs new file mode 100644 --- /dev/null +++ b/source/library/Patrol/Type/Headers.hs @@ -0,0 +1,27 @@ +module Patrol.Type.Headers where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Builder as Builder + +-- | +newtype Headers + = Headers Aeson.Object + deriving (Eq, Show) + +instance Aeson.FromJSON Headers where + parseJSON = fmap fromObject . Aeson.parseJSON + +instance Aeson.ToJSON Headers where + toJSON = Aeson.Object . intoObject + +fromObject :: Aeson.Object -> Headers +fromObject = Headers + +intoObject :: Headers -> Aeson.Object +intoObject (Headers object) = object + +empty :: Headers +empty = fromObject mempty + +serialize :: Headers -> Builder.Builder +serialize = Aeson.fromEncoding . Aeson.toEncoding diff --git a/source/library/Patrol/Type/Item.hs b/source/library/Patrol/Type/Item.hs new file mode 100644 --- /dev/null +++ b/source/library/Patrol/Type/Item.hs @@ -0,0 +1,37 @@ +module Patrol.Type.Item where + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Patrol.Type.Event as Event +import qualified Patrol.Type.Headers as Headers + +-- | +data Item = Item + { headers :: Headers.Headers, + payload :: ByteString.ByteString + } + deriving (Eq, Show) + +fromEvent :: Event.Event -> Item +fromEvent event = + let thePayload = LazyByteString.toStrict $ Aeson.encode event + in Item + { headers = + Headers.fromObject $ + KeyMap.fromList + [ (Key.fromString "type", Aeson.toJSON "event"), + (Key.fromString "length", Aeson.toJSON $ ByteString.length thePayload), + (Key.fromString "event_id", Aeson.toJSON $ Event.eventId event) + ], + payload = thePayload + } + +serialize :: Item -> Builder.Builder +serialize item = + Headers.serialize (headers item) + <> Builder.char7 '\n' + <> Builder.byteString (payload item) diff --git a/source/test-suite/Patrol/ConstantSpec.hs b/source/test-suite/Patrol/ConstantSpec.hs --- a/source/test-suite/Patrol/ConstantSpec.hs +++ b/source/test-suite/Patrol/ConstantSpec.hs @@ -12,6 +12,10 @@ Hspec.it "is correct" $ do Constant.applicationJson `Hspec.shouldBe` Text.encodeUtf8 (Text.pack "application/json") + Hspec.describe "applicationXSentryEnvelope" $ do + Hspec.it "is correct" $ do + Constant.applicationXSentryEnvelope `Hspec.shouldBe` Text.encodeUtf8 (Text.pack "application/x-sentry-envelope") + Hspec.describe "sentryVersion" $ do Hspec.it "is correct" $ do Constant.sentryVersion `Hspec.shouldBe` Text.singleton '7' diff --git a/source/test-suite/Patrol/Type/ClientSdkInfoSpec.hs b/source/test-suite/Patrol/Type/ClientSdkInfoSpec.hs --- a/source/test-suite/Patrol/Type/ClientSdkInfoSpec.hs +++ b/source/test-suite/Patrol/Type/ClientSdkInfoSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Patrol.Type.ClientSdkInfoSpec where @@ -5,6 +6,7 @@ import qualified Data.Aeson as Aeson import qualified Data.Aeson.QQ.Simple as Aeson import qualified Data.Text as Text +import qualified Patrol.Constant as Constant import qualified Patrol.Type.ClientSdkInfo as ClientSdkInfo import qualified Patrol.Type.ClientSdkPackage as ClientSdkPackage import qualified Test.Hspec as Hspec @@ -37,3 +39,8 @@ let clientSdkInfo = ClientSdkInfo.empty {ClientSdkInfo.version = Text.pack "example-version"} json = [Aeson.aesonQQ| { "version": "example-version" } |] Aeson.toJSON clientSdkInfo `Hspec.shouldBe` json + + Hspec.describe "patrol" $ do + Hspec.it "agrees with the user agent" $ do + let actual = ClientSdkInfo.name ClientSdkInfo.patrol <> "/" <> ClientSdkInfo.version ClientSdkInfo.patrol + actual `Hspec.shouldBe` Constant.userAgent diff --git a/source/test-suite/Patrol/Type/DsnSpec.hs b/source/test-suite/Patrol/Type/DsnSpec.hs --- a/source/test-suite/Patrol/Type/DsnSpec.hs +++ b/source/test-suite/Patrol/Type/DsnSpec.hs @@ -5,12 +5,43 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Network.URI.Static as Uri +import qualified Patrol.Exception.Problem as Problem import qualified Patrol.Type.Dsn as Dsn import qualified Patrol.Version as Version import qualified Test.Hspec as Hspec spec :: Hspec.Spec spec = Hspec.describe "Patrol.Type.Dsn" $ do + Hspec.describe "fromText" $ do + Hspec.it "fails with an invalid DSN" $ do + Dsn.fromText (Text.pack "a:") `Hspec.shouldThrow` (\(Problem.Problem _) -> True) + + Hspec.it "succeeds with a minimal DSN" $ do + dsn <- Dsn.fromText (Text.pack "a://b@c/d") + dsn + `Hspec.shouldBe` Dsn.Dsn + { Dsn.protocol = Text.singleton 'a', + Dsn.publicKey = Text.singleton 'b', + Dsn.secretKey = Text.empty, + Dsn.host = Text.singleton 'c', + Dsn.port = Nothing, + Dsn.path = Text.singleton '/', + Dsn.projectId = Text.singleton 'd' + } + + Hspec.it "succeeds with a maximal DSN" $ do + dsn <- Dsn.fromText (Text.pack "a://b:c@d:5/f/g") + dsn + `Hspec.shouldBe` Dsn.Dsn + { Dsn.protocol = Text.singleton 'a', + Dsn.publicKey = Text.singleton 'b', + Dsn.secretKey = Text.singleton 'c', + Dsn.host = Text.singleton 'd', + Dsn.port = Just 5, + Dsn.path = Text.pack "/f/", + Dsn.projectId = Text.singleton 'g' + } + Hspec.describe "fromUri" $ do Hspec.it "fails with an invalid DSN" $ do Dsn.fromUri [Uri.uri|a:|] `Hspec.shouldBe` Nothing diff --git a/source/test-suite/Patrol/Type/EnvelopeSpec.hs b/source/test-suite/Patrol/Type/EnvelopeSpec.hs new file mode 100644 --- /dev/null +++ b/source/test-suite/Patrol/Type/EnvelopeSpec.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Patrol.Type.EnvelopeSpec where + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Text.Encoding as Text +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Types as Http +import qualified Patrol.Constant as Constant +import qualified Patrol.Extra.Aeson as Aeson +import qualified Patrol.Type.Dsn as Dsn +import qualified Patrol.Type.Envelope as Envelope +import qualified Patrol.Type.Event as Event +import qualified Patrol.Type.Headers as Headers +import qualified Patrol.Type.Item as Item +import qualified Patrol.Version as Version +import qualified Test.Hspec as Hspec + +spec :: Hspec.Spec +spec = Hspec.describe "Patrol.Type.Envelope" $ do + Hspec.describe "serialize" $ do + Hspec.it "works with no items" $ do + let actual = + Builder.toLazyByteString $ + Envelope.serialize + Envelope.Envelope + { Envelope.headers = Headers.empty, + Envelope.items = [] + } + actual `Hspec.shouldBe` "{}\n" + + Hspec.it "works with one item" $ do + let actual = + Builder.toLazyByteString $ + Envelope.serialize + Envelope.Envelope + { Envelope.headers = Headers.fromObject . KeyMap.singleton "a" $ Aeson.toJSON False, + Envelope.items = + [ Item.Item + { Item.headers = Headers.fromObject . KeyMap.singleton "b" $ Aeson.toJSON True, + Item.payload = "c" + } + ] + } + actual `Hspec.shouldBe` "{\"a\":false}\n{\"b\":true}\nc\n" + + Hspec.it "works with two items" $ do + let actual = + Builder.toLazyByteString $ + Envelope.serialize + Envelope.Envelope + { Envelope.headers = Headers.fromObject . KeyMap.singleton "a" $ Aeson.toJSON (1 :: Int), + Envelope.items = + [ Item.Item + { Item.headers = Headers.fromObject . KeyMap.singleton "b" $ Aeson.toJSON (2 :: Int), + Item.payload = "c" + }, + Item.Item + { Item.headers = Headers.fromObject . KeyMap.singleton "d" $ Aeson.toJSON (3 :: Int), + Item.payload = "e" + } + ] + } + actual `Hspec.shouldBe` "{\"a\":1}\n{\"b\":2}\nc\n{\"d\":3}\ne\n" + + Hspec.describe "fromEvent" $ do + Hspec.it "sets the header" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + event <- Event.fromException (const Nothing) $ userError "" + let envelope = Envelope.fromEvent dsn event {Event.timestamp = Nothing} + let expected = + Headers.fromObject $ + KeyMap.fromList + [ ("dsn", "http://key@sentry.test/1"), + ( "sdk", + Aeson.object + [ Aeson.pair "name" ("patrol" :: String), + Aeson.pair "version" Version.version + ] + ) + ] + Envelope.headers envelope `Hspec.shouldBe` expected + + Hspec.it "sets the items" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + event <- Event.fromException (const Nothing) $ userError "" + let envelope = Envelope.fromEvent dsn event + Envelope.items envelope `Hspec.shouldNotSatisfy` null + + Hspec.describe "intoRequest" $ do + Hspec.it "sets the method" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + Client.method request `Hspec.shouldBe` Http.methodPost + + Hspec.it "sets the host" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + Client.host request `Hspec.shouldBe` "sentry.test" + + Hspec.it "sets the port" $ do + dsn <- Dsn.fromText "http://key@sentry.test:8080/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + Client.port request `Hspec.shouldBe` 8080 + + Hspec.it "sets the path" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + Client.path request `Hspec.shouldBe` "/api/1/envelope/" + + Hspec.it "handles a custom path" $ do + dsn <- Dsn.fromText "http://key@sentry.test/custom/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + Client.path request `Hspec.shouldBe` "/custom/api/1/envelope/" + + Hspec.it "sets the body" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + actual <- case Client.requestBody request of + Client.RequestBodyBS byteString -> pure byteString + _ -> fail "unexpected request body" + let expected = LazyByteString.toStrict . Builder.toLazyByteString $ Envelope.serialize envelope + actual `Hspec.shouldBe` expected + + Hspec.it "sets the content type" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + lookup Http.hContentType (Client.requestHeaders request) `Hspec.shouldBe` Just Constant.applicationXSentryEnvelope + + Hspec.it "sets the user agent" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + lookup Http.hUserAgent (Client.requestHeaders request) `Hspec.shouldBe` Just (Text.encodeUtf8 Constant.userAgent) + + Hspec.it "sets the authorization" $ do + dsn <- Dsn.fromText "http://key@sentry.test/1" + envelope <- Envelope.fromException (const Nothing) dsn $ userError "" + request <- Envelope.intoRequest dsn envelope + lookup Constant.xSentryAuth (Client.requestHeaders request) `Hspec.shouldBe` Just (Dsn.intoAuthorization dsn) diff --git a/source/test-suite/Patrol/Type/EventSpec.hs b/source/test-suite/Patrol/Type/EventSpec.hs --- a/source/test-suite/Patrol/Type/EventSpec.hs +++ b/source/test-suite/Patrol/Type/EventSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Patrol.Type.EventSpec where @@ -12,7 +13,6 @@ import qualified Data.Time as Time import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Types as Http -import qualified Network.URI.Static as Uri import qualified Patrol.Constant as Constant import qualified Patrol.Type.Breadcrumb as Breadcrumb import qualified Patrol.Type.Breadcrumbs as Breadcrumbs @@ -218,37 +218,37 @@ Hspec.describe "intoRequest" $ do Hspec.it "sets the method" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test/project-id" event <- Event.new request <- Event.intoRequest dsn event Client.method request `Hspec.shouldBe` Http.methodPost Hspec.it "sets the host" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test:8080/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test:8080/project-id" event <- Event.new request <- Event.intoRequest dsn event Client.host request `Hspec.shouldBe` Text.encodeUtf8 (Text.pack "sentry.test") Hspec.it "sets the port" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test:8080/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test:8080/project-id" event <- Event.new request <- Event.intoRequest dsn event Client.port request `Hspec.shouldBe` 8080 Hspec.it "sets the path" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test/project-id" event <- Event.new request <- Event.intoRequest dsn event Client.path request `Hspec.shouldBe` Text.encodeUtf8 (Text.pack "/api/project-id/store/") Hspec.it "handles a custom path" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test/custom/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test/custom/project-id" event <- Event.new request <- Event.intoRequest dsn event Client.path request `Hspec.shouldBe` Text.encodeUtf8 (Text.pack "/custom/api/project-id/store/") Hspec.it "sets the body" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test/project-id" event <- Event.new request <- Event.intoRequest dsn event case Client.requestBody request of @@ -256,19 +256,52 @@ _ -> fail "unexpected request body" Hspec.it "sets the content type" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test/project-id" event <- Event.new request <- Event.intoRequest dsn event lookup Http.hContentType (Client.requestHeaders request) `Hspec.shouldSatisfy` Maybe.isJust Hspec.it "sets the user agent" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test/project-id" event <- Event.new request <- Event.intoRequest dsn event lookup Http.hUserAgent (Client.requestHeaders request) `Hspec.shouldSatisfy` Maybe.isJust Hspec.it "sets the authorization" $ do - dsn <- maybe (fail "invalid DSN") pure $ Dsn.fromUri [Uri.uri|http://public-key@sentry.test/project-id|] + dsn <- Dsn.fromText "http://public-key@sentry.test/project-id" event <- Event.new request <- Event.intoRequest dsn event lookup Constant.xSentryAuth (Client.requestHeaders request) `Hspec.shouldSatisfy` Maybe.isJust + + Hspec.describe "fromException" $ do + Hspec.it "sets the environment" $ do + event <- Event.fromException (const Nothing) $ userError "" + Event.environment event `Hspec.shouldBe` Text.pack "production" + + Hspec.it "sets the event ID" $ do + event <- Event.fromException (const Nothing) $ userError "" + Event.eventId event `Hspec.shouldNotBe` EventId.empty + + Hspec.it "sets the exception" $ do + event <- Event.fromException (const Nothing) $ userError "" + Event.exception event `Hspec.shouldSatisfy` Maybe.isJust + + Hspec.it "sets the level" $ do + event <- Event.fromException (const Nothing) $ userError "" + Event.level event `Hspec.shouldBe` Just Level.Error + + Hspec.it "sets the platform" $ do + event <- Event.fromException (const Nothing) $ userError "" + Event.platform event `Hspec.shouldBe` Just Platform.Haskell + + Hspec.it "sets the timestamp" $ do + event <- Event.fromException (const Nothing) $ userError "" + Event.timestamp event `Hspec.shouldSatisfy` Maybe.isJust + + Hspec.it "sets the type" $ do + event <- Event.fromException (const Nothing) $ userError "" + Event.type_ event `Hspec.shouldBe` Just EventType.Default + + Hspec.it "sets the version" $ do + event <- Event.fromException (const Nothing) $ userError "" + Event.version event `Hspec.shouldBe` Constant.sentryVersion diff --git a/source/test-suite/Patrol/Type/ExceptionSpec.hs b/source/test-suite/Patrol/Type/ExceptionSpec.hs --- a/source/test-suite/Patrol/Type/ExceptionSpec.hs +++ b/source/test-suite/Patrol/Type/ExceptionSpec.hs @@ -2,11 +2,11 @@ module Patrol.Type.ExceptionSpec where -import qualified Control.Monad.Catch as Catch import qualified Data.Aeson as Aeson import qualified Data.Aeson.QQ.Simple as Aeson import qualified Data.Map as Map import qualified Data.Text as Text +import qualified GHC.Stack as Stack import qualified Patrol.Type.Exception as Exception import qualified Patrol.Type.Mechanism as Mechanism import qualified Patrol.Type.Stacktrace as Stacktrace @@ -52,11 +52,16 @@ json = [Aeson.aesonQQ| { "value": "example-value" } |] Aeson.toJSON exception `Hspec.shouldBe` json - Hspec.describe "fromSomeException" $ do - let exception = Exception.fromSomeException . Catch.toException $ userError "example-exception-value" + Hspec.describe "fromException" $ do + Hspec.it "sets the stacktrace" $ do + let callStack = Stack.callStack + let exception = Exception.fromException (const $ Just callStack) $ userError "" + Exception.stacktrace exception `Hspec.shouldBe` Just (Stacktrace.fromCallStack callStack) Hspec.it "sets the type" $ do + let exception = Exception.fromException (const Nothing) $ userError "" Exception.type_ exception `Hspec.shouldBe` Text.pack "IOException" Hspec.it "sets the value" $ do + let exception = Exception.fromException (const Nothing) $ userError "example-exception-value" Exception.value exception `Hspec.shouldBe` Text.pack "user error (example-exception-value)" diff --git a/source/test-suite/Patrol/Type/ExceptionsSpec.hs b/source/test-suite/Patrol/Type/ExceptionsSpec.hs --- a/source/test-suite/Patrol/Type/ExceptionsSpec.hs +++ b/source/test-suite/Patrol/Type/ExceptionsSpec.hs @@ -22,3 +22,8 @@ exceptions = Exceptions.empty {Exceptions.values = [exception]} json = [Aeson.aesonQQ| { "values": [ { "type": "example-type" } ] } |] Aeson.toJSON exceptions `Hspec.shouldBe` json + + Hspec.describe "fromException" $ do + Hspec.it "works" $ do + let exceptions = Exceptions.fromException (const Nothing) $ userError "" + Exceptions.values exceptions `Hspec.shouldNotSatisfy` null diff --git a/source/test-suite/Patrol/Type/HeadersSpec.hs b/source/test-suite/Patrol/Type/HeadersSpec.hs new file mode 100644 --- /dev/null +++ b/source/test-suite/Patrol/Type/HeadersSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Patrol.Type.HeadersSpec where + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Builder as Builder +import qualified Patrol.Type.Headers as Headers +import qualified Test.Hspec as Hspec + +spec :: Hspec.Spec +spec = Hspec.describe "Patrol.Type.Headers" $ do + Hspec.describe "serialize" $ do + Hspec.it "works with an empty object" $ do + let actual = Builder.toLazyByteString $ Headers.serialize Headers.empty + actual `Hspec.shouldBe` "{}" + + Hspec.it "works with a singleton object" $ do + let actual = + Builder.toLazyByteString + . Headers.serialize + . Headers.fromObject + $ KeyMap.singleton "k" Aeson.Null + actual `Hspec.shouldBe` "{\"k\":null}" + + Hspec.it "works with a non-empty object" $ do + let actual = + Builder.toLazyByteString + . Headers.serialize + . Headers.fromObject + $ KeyMap.fromList [("a", Aeson.toJSON False), ("b", Aeson.toJSON True)] + actual `Hspec.shouldBe` "{\"a\":false,\"b\":true}" + + Hspec.it "escapes newlines" $ do + let actual = + Builder.toLazyByteString + . Headers.serialize + . Headers.fromObject + $ KeyMap.singleton "k" "\n" + actual `Hspec.shouldBe` "{\"k\":\"\\n\"}" diff --git a/source/test-suite/Patrol/Type/ItemSpec.hs b/source/test-suite/Patrol/Type/ItemSpec.hs new file mode 100644 --- /dev/null +++ b/source/test-suite/Patrol/Type/ItemSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Patrol.Type.ItemSpec where + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as Builder +import qualified Patrol.Type.Event as Event +import qualified Patrol.Type.Headers as Headers +import qualified Patrol.Type.Item as Item +import qualified Test.Hspec as Hspec + +spec :: Hspec.Spec +spec = Hspec.describe "Patrol.Type.Item" $ do + Hspec.describe "serialize" $ do + Hspec.it "works with an empty payload" $ do + let actual = + Builder.toLazyByteString $ + Item.serialize + Item.Item + { Item.headers = Headers.empty, + Item.payload = "" + } + actual `Hspec.shouldBe` "{}\n" + + Hspec.it "works with a non-empty payload" $ do + let actual = + Builder.toLazyByteString $ + Item.serialize + Item.Item + { Item.headers = Headers.empty, + Item.payload = "x" + } + actual `Hspec.shouldBe` "{}\nx" + + Hspec.it "allows newlines in the payload" $ do + -- + -- If no `length` is specified, the payload implicitly goes to the next + -- newline. For payloads containing newline characters, the `length` must + -- be specified. + let actual = + Builder.toLazyByteString $ + Item.serialize + Item.Item + { Item.headers = + Headers.fromObject + . KeyMap.singleton "length" + $ Aeson.toJSON (3 :: Int), + Item.payload = "a\nb" + } + actual `Hspec.shouldBe` "{\"length\":3}\na\nb" + + Hspec.describe "fromEvent" $ do + Hspec.it "sets the headers" $ do + let event = Event.empty + let actual = Item.fromEvent event + let expected = + Headers.fromObject $ + KeyMap.fromList + [ ("type", "event"), + ("length", Aeson.toJSON (47 :: Int)), + ("event_id", Aeson.toJSON $ Event.eventId event) + ] + Item.headers actual `Hspec.shouldBe` expected + + Hspec.it "sets the payload" $ do + let event = Event.empty + let actual = Item.fromEvent event + let expected = "{\"event_id\":\"00000000000000000000000000000000\"}" :: ByteString.ByteString + Item.payload actual `Hspec.shouldBe` expected diff --git a/source/test-suite/PatrolSpec.hs b/source/test-suite/PatrolSpec.hs --- a/source/test-suite/PatrolSpec.hs +++ b/source/test-suite/PatrolSpec.hs @@ -18,6 +18,7 @@ import qualified Patrol.Type.DebugMetaSpec import qualified Patrol.Type.DeviceContextSpec import qualified Patrol.Type.DsnSpec +import qualified Patrol.Type.EnvelopeSpec import qualified Patrol.Type.ErrorTypeSpec import qualified Patrol.Type.EventIdSpec import qualified Patrol.Type.EventProcessingErrorSpec @@ -28,6 +29,8 @@ import qualified Patrol.Type.FrameSpec import qualified Patrol.Type.GeoSpec import qualified Patrol.Type.GpuContextSpec +import qualified Patrol.Type.HeadersSpec +import qualified Patrol.Type.ItemSpec import qualified Patrol.Type.LevelSpec import qualified Patrol.Type.LogEntrySpec import qualified Patrol.Type.MachExceptionSpec @@ -73,6 +76,9 @@ Patrol.Type.DebugMetaSpec.spec Patrol.Type.DeviceContextSpec.spec Patrol.Type.DsnSpec.spec + Patrol.Type.EnvelopeSpec.spec + Patrol.Type.HeadersSpec.spec + Patrol.Type.ItemSpec.spec Patrol.Type.ErrorTypeSpec.spec Patrol.Type.EventIdSpec.spec Patrol.Type.EventProcessingErrorSpec.spec