packages feed

patrol (empty) → 0.0.1

raw patch · 20 files changed

+631/−0 lines, 20 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, case-insensitive, containers, http-client, http-types, network-uri, text, time, uuid

Files

+ CHANGELOG.markdown view
@@ -0,0 +1,4 @@+# Change log++Patrol uses [Semantic Versioning](https://semver.org/spec/v2.0.0.html).+The change log is available through [the releases](https://github.com/tfausak/patrol/releases) on GitHub.
+ LICENSE.markdown view
@@ -0,0 +1,13 @@+Copyright 2021 Taylor Fausak++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ README.markdown view
@@ -0,0 +1,3 @@+# Patrol++Patrol is a Sentry SDK for Haskell.
+ patrol.cabal view
@@ -0,0 +1,68 @@+cabal-version: >= 1.10++name: patrol+version: 0.0.1+synopsis: Sentry SDK+description: Patrol is a Sentry SDK.++build-type: Simple+category: Exceptions+extra-source-files:+  CHANGELOG.markdown+  README.markdown+license-file: LICENSE.markdown+license: ISC+maintainer: Taylor Fausak++source-repository head+  location: https://github.com/tfausak/patrol+  type: git++library+  autogen-modules: Paths_patrol+  build-depends:+    base >= 4.13.0 && < 4.16+    , aeson >= 1.4.6 && < 1.6+    , bytestring >= 0.10.10 && < 0.12+    , case-insensitive >= 1.2.1 && < 1.3+    , containers >= 0.6.2 && < 0.7+    , http-client >= 0.6.4 && < 0.7+    , http-types >= 0.12.3 && < 0.13+    , network-uri >= 2.6.2 && < 2.7+    , text >= 1.2.4 && < 1.3+    , time >= 1.9.3 && < 1.10+    , uuid >= 1.3.13 && < 1.4+  default-extensions: NamedFieldPuns+  default-language: Haskell2010+  exposed-modules:+    Patrol+    Patrol.Client+    Patrol.Utility.Json+    Patrol.Utility.Maybe+    Patrol.Type.Dsn+    Patrol.Type.Event+    Patrol.Type.EventId+    Patrol.Type.Exception+    Patrol.Type.Frame+    Patrol.Type.Level+    Patrol.Type.Platform+    Patrol.Type.Request+    Patrol.Type.Response+    Patrol.Type.StackTrace+    Patrol.Type.Timestamp+    Patrol.Type.User+  ghc-options:+    -Weverything+    -Wno-all-missed-specialisations+    -Wno-implicit-prelude+    -Wno-missing-deriving-strategies+    -Wno-missing-exported-signatures+    -Wno-safe+    -Wno-unsafe+  hs-source-dirs: src/lib+  other-modules: Paths_patrol++  if impl(ghc >= 8.10)+    ghc-options:+      -Wno-missing-safe-haskell-mode+      -Wno-prepositive-qualified-module
+ src/lib/Patrol.hs view
@@ -0,0 +1,2 @@+-- | <https://develop.sentry.dev/sdk/>+module Patrol () where
+ src/lib/Patrol/Client.hs view
@@ -0,0 +1,63 @@+module Patrol.Client+  ( store+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString as ByteString+import qualified Data.CaseInsensitive as CI+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Time as Time+import qualified Data.Version as Version+import qualified Network.HTTP.Client as Client+import qualified Network.HTTP.Types as Http+import qualified Paths_patrol as Package+import qualified Patrol.Type.Dsn as Dsn+import qualified Patrol.Type.Event as Event+import qualified Patrol.Type.EventId as EventId+import qualified Patrol.Type.Response as Response++-- | <https://develop.sentry.dev/sdk/store/>+store :: Client.Manager -> Dsn.Dsn -> Event.Event -> IO EventId.EventId+store manager dsn event = do+  now <- Time.getCurrentTime+  request <- Client.parseUrlThrow $ makeUrl dsn+  -- TODO: Compress request body.+  response <- Client.httpLbs request+    { Client.requestBody = Client.RequestBodyLBS $ Aeson.encode event+    , Client.requestHeaders =+      [ (Http.hContentType, utf8 "application/json")+      , (Http.hUserAgent, utf8 userAgent)+      , (ci $ utf8 "X-Sentry-Auth", Text.encodeUtf8 . Text.intercalate (Text.singleton ',') $ Maybe.catMaybes+        [ Just $ Text.pack "Sentry sentry_version=7"+        , Just . Text.pack $ "sentry_client=" <> userAgent+        , Just . Text.pack $ "sentry_timestamp=" <> Time.formatTime Time.defaultTimeLocale "%s" now+        , Just $ Text.pack "sentry_key=" <> Dsn.publicKey dsn+        , (\ x -> Text.pack "sentry_secret=" <> x) <$> Dsn.secretKey dsn+        ])+      ]+    , Client.method = Http.methodPost+    } manager+  -- TODO: Handle 429 response codes.+  either fail (pure . Response.id_) . Aeson.eitherDecode $ Client.responseBody response++makeUrl :: Dsn.Dsn -> String+makeUrl dsn =+  Text.unpack (Dsn.protocol dsn)+  <> "://"+  <> Text.unpack (Dsn.host dsn)+  <> maybe "" (\ x -> ":" <> Text.unpack x) (Dsn.port dsn)+  <> Text.unpack (Dsn.path dsn)+  <> "api/"+  <> Text.unpack (Dsn.projectId dsn)+  <> "/store/"++utf8 :: String -> ByteString.ByteString+utf8 = Text.encodeUtf8 . Text.pack++ci :: CI.FoldCase a => a -> CI.CI a+ci = CI.mk++userAgent :: String+userAgent = "patrol/" <> Version.showVersion Package.version
+ src/lib/Patrol/Type/Dsn.hs view
@@ -0,0 +1,75 @@+module Patrol.Type.Dsn+  ( Dsn(..)+  , fromUri+  , fromString+  , toUri+  , toString+  ) where++import qualified Data.Text as Text+import qualified Network.URI as Uri+import qualified Patrol.Utility.Maybe as Maybe++-- | <https://develop.sentry.dev/sdk/overview/#parsing-the-dsn>+data Dsn = Dsn+  { protocol :: Text.Text+  , publicKey :: Text.Text+  , secretKey :: Maybe Text.Text+  , host :: Text.Text+  , port :: Maybe Text.Text+  , path :: Text.Text+  , projectId :: Text.Text+  } deriving (Eq, Show)++fromUri :: Uri.URI -> Either String Dsn+fromUri uri = do+  protocol <- Maybe.note "invalid protocol"+    . Text.stripSuffix (Text.singleton ':')+    . Text.pack+    $ Uri.uriScheme uri+  authority <- Maybe.note "missing authority" $ Uri.uriAuthority uri+  userInfo <- Maybe.note "invalid user info"+    . Text.stripSuffix (Text.singleton '@')+    . Text.pack+    $ Uri.uriUserInfo authority+  let+    (publicKey, secretKey) = Text.drop 1+      <$> Text.breakOn (Text.singleton ':') userInfo+    (host, port) = fmap (Text.drop 1) . Text.breakOn (Text.singleton ':')+      . Text.pack+      $ Uri.uriRegName authority <> Uri.uriPort authority+    (path, projectId) = Text.breakOnEnd (Text.singleton '/')+      . Text.pack+      $ Uri.uriPath uri+  Right Dsn+    { protocol+    , publicKey+    , secretKey = if Text.null secretKey then Nothing else Just secretKey+    , host+    , port = if Text.null port then Nothing else Just port+    , path+    , projectId+    }++fromString :: String -> Either String Dsn+fromString string = do+  uri <- Maybe.note "invalid URI" $ Uri.parseURI string+  fromUri uri++toUri :: Dsn -> Uri.URI+toUri dsn = Uri.URI+  { Uri.uriScheme = Text.unpack (protocol dsn) <> ":"+  , Uri.uriAuthority = Just Uri.URIAuth+    { Uri.uriUserInfo = Text.unpack (publicKey dsn)+      <> maybe "" (\ x -> ":" <> Text.unpack x) (secretKey dsn) <> "@"+    , Uri.uriRegName = Text.unpack (host dsn)+      <> maybe "" (\ x -> ":" <> Text.unpack x) (port dsn)+    , Uri.uriPort = ""+    }+  , Uri.uriPath = Text.unpack (path dsn) <> Text.unpack (projectId dsn)+  , Uri.uriQuery = ""+  , Uri.uriFragment = ""+  }++toString :: Dsn -> String+toString dsn = Uri.uriToString id (toUri dsn) ""
+ src/lib/Patrol/Type/Event.hs view
@@ -0,0 +1,86 @@+module Patrol.Type.Event+  ( Event(..)+  , new+  ) where++import qualified Control.Monad.IO.Class as IO+import qualified Data.Aeson as Aeson+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text+import qualified Data.Time as Time+import qualified Data.UUID.V4 as Uuid+import qualified Patrol.Type.EventId as EventId+import qualified Patrol.Type.Exception as Exception+import qualified Patrol.Type.Level as Level+import qualified Patrol.Type.Platform as Platform+import qualified Patrol.Type.Request as Request+import qualified Patrol.Type.Timestamp as Timestamp+import qualified Patrol.Type.User as User+import qualified Patrol.Utility.Json as Json++-- | <https://develop.sentry.dev/sdk/event-payloads/>+data Event = Event+  { dist :: Maybe Text.Text+  , environment :: Maybe Text.Text+  , eventId :: EventId.EventId+  , exception :: Maybe [Exception.Exception]+  , extra :: Maybe Aeson.Object+  , fingerprint :: Maybe [Text.Text]+  , level :: Maybe Level.Level+  , logger :: Maybe Text.Text+  , modules :: Maybe (Map.Map Text.Text Text.Text)+  , platform :: Platform.Platform+  , release :: Maybe Text.Text+  , request :: Maybe Request.Request+  , serverName :: Maybe Text.Text+  , tags :: Maybe (Map.Map Text.Text Text.Text)+  , timestamp :: Timestamp.Timestamp+  , transaction :: Maybe Text.Text+  , user :: Maybe User.User+  } deriving (Eq, Show)++instance Aeson.ToJSON Event where+  toJSON event = Aeson.object $ Maybe.catMaybes+    [ Json.pair "dist" <$> dist event+    , Json.pair "environment" <$> environment event+    , Just . Json.pair "event_id" $ eventId event+    , Json.pair "extra" <$> extra event+    , Json.pair "exception" . Aeson.object . pure . Json.pair "values" <$> exception event+    , Json.pair "fingerprint" <$> fingerprint event+    , Json.pair "level" <$> level event+    , Json.pair "logger" <$> logger event+    , Json.pair "modules" <$> modules event+    , Just . Json.pair "platform" $ platform event+    , Json.pair "release" <$> release event+    , Json.pair "request" <$> request event+    , Json.pair "server_name" <$> serverName event+    , Json.pair "tags" <$> tags event+    , Just . Json.pair "timestamp" $ timestamp event+    , Json.pair "transaction" <$> transaction event+    , Json.pair "user" <$> user event+    ]++new :: IO.MonadIO io => io Event+new = IO.liftIO $ do+  eventId <- EventId.fromUuid <$> Uuid.nextRandom+  timestamp <- Timestamp.fromUtcTime <$> Time.getCurrentTime+  pure Event+    { dist = Nothing+    , environment = Nothing+    , eventId+    , exception = Nothing+    , extra = Nothing+    , fingerprint = Nothing+    , level = Nothing+    , logger = Nothing+    , modules = Nothing+    , platform = Platform.Haskell+    , release = Nothing+    , request = Nothing+    , serverName = Nothing+    , tags = Nothing+    , timestamp+    , transaction = Nothing+    , user = Nothing+    }
+ src/lib/Patrol/Type/EventId.hs view
@@ -0,0 +1,30 @@+module Patrol.Type.EventId+  ( EventId+  , fromUuid+  , toUuid+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Text as Text+import qualified Data.UUID as Uuid++-- | <https://develop.sentry.dev/sdk/event-payloads/#required-attributes>+newtype EventId+  = EventId Uuid.UUID+  deriving (Eq, Show)++instance Aeson.FromJSON EventId where+  parseJSON = Aeson.withText "EventId" $ \ text -> case Text.chunksOf 4 text of+    [a, b, c, d, e, f, g, h] -> maybe (fail "invalid EventId") (pure . fromUuid)+      . Uuid.fromText+      $ Text.intercalate (Text.singleton '-') [a <> b, c, d, e, f <> g <> h]+    _ -> fail "invalid EventId"++instance Aeson.ToJSON EventId where+  toJSON = Aeson.toJSON . Text.filter (/= '-') . Uuid.toText . toUuid++fromUuid :: Uuid.UUID -> EventId+fromUuid = EventId++toUuid :: EventId -> Uuid.UUID+toUuid (EventId x) = x
+ src/lib/Patrol/Type/Exception.hs view
@@ -0,0 +1,38 @@+module Patrol.Type.Exception+  ( Exception(..)+  , fromSomeException+  ) where++import qualified Control.Exception as Exception+import qualified Data.Aeson as Aeson+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text+import qualified Data.Typeable as Typeable+import qualified Patrol.Type.StackTrace as StackTrace+import qualified Patrol.Utility.Json as Json++-- | <https://develop.sentry.dev/sdk/event-payloads/exception/>+data Exception = Exception+  { module_ :: Maybe Text.Text+  , stackTrace :: Maybe StackTrace.StackTrace+  , type_ :: Text.Text+  , value :: Text.Text+  } deriving (Eq, Show)++instance Aeson.ToJSON Exception where+  toJSON exception = Aeson.object $ Maybe.catMaybes+    [ Json.pair "module" <$> module_ exception+    , Json.pair "stacktrace" <$> stackTrace exception+    , Just . Json.pair "type" $ type_ exception+    , Just . Json.pair "value" $ value exception+    ]++fromSomeException :: Exception.SomeException -> Exception+fromSomeException (Exception.SomeException x) =+  let tyCon = Typeable.typeRepTyCon $ Typeable.typeOf x+  in Exception+  { module_ = Just . Text.pack $ Typeable.tyConPackage tyCon <> ":" <> Typeable.tyConModule tyCon+  , stackTrace = Nothing+  , type_ = Text.pack $ Typeable.tyConName tyCon+  , value = Text.pack $ Exception.displayException x+  }
+ src/lib/Patrol/Type/Frame.hs view
@@ -0,0 +1,40 @@+module Patrol.Type.Frame+  ( Frame(..)+  , fromSrcLoc+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text+import qualified GHC.Stack as Stack+import qualified Patrol.Utility.Json as Json++-- | <https://develop.sentry.dev/sdk/event-payloads/stacktrace/#frame-attributes>+data Frame = Frame+  { colno :: Maybe Int+  , filename :: Maybe Text.Text+  , function :: Text.Text+  , lineno :: Maybe Int+  , module_ :: Maybe Text.Text+  , package :: Maybe Text.Text+  } deriving (Eq, Show)++instance Aeson.ToJSON Frame where+  toJSON frame = Aeson.object $ Maybe.catMaybes+    [ Json.pair "colno" <$> colno frame+    , Json.pair "filename" <$> filename frame+    , Just . Json.pair "function" $ function frame+    , Json.pair "lineno" <$> lineno frame+    , Json.pair "module" <$> module_ frame+    , Json.pair "package" <$> package frame+    ]++fromSrcLoc :: String -> Stack.SrcLoc -> Frame+fromSrcLoc function srcLoc = Frame+  { colno = Just $ Stack.srcLocStartCol srcLoc+  , filename = Just . Text.pack $ Stack.srcLocFile srcLoc+  , function = Text.pack function+  , lineno = Just $ Stack.srcLocStartLine srcLoc+  , module_ = Just . Text.pack $ Stack.srcLocModule srcLoc+  , package = Just . Text.pack $ Stack.srcLocPackage srcLoc+  }
+ src/lib/Patrol/Type/Level.hs view
@@ -0,0 +1,22 @@+module Patrol.Type.Level+  ( Level(..)+  ) where++import qualified Data.Aeson as Aeson++-- | <https://develop.sentry.dev/sdk/event-payloads/#optional-attributes>+data Level+  = Fatal+  | Error+  | Warning+  | Info+  | Debug+  deriving (Eq, Show)++instance Aeson.ToJSON Level where+  toJSON level = Aeson.toJSON $ case level of+    Fatal -> "fatal"+    Error -> "error"+    Warning -> "warning"+    Info -> "info"+    Debug -> "debug"
+ src/lib/Patrol/Type/Platform.hs view
@@ -0,0 +1,50 @@+module Patrol.Type.Platform+  ( Platform(..)+  ) where++import qualified Data.Aeson as Aeson++-- | <https://develop.sentry.dev/sdk/event-payloads/#required-attributes>+data Platform+  = As3+  | C+  | Cfml+  | Cocoa+  | Csharp+  | Elixir+  | Go+  | Groovy+  | Haskell+  | Java+  | Javascript+  | Native+  | Node+  | Objc+  | Other+  | Perl+  | Php+  | Python+  | Ruby+  deriving (Eq, Show)++instance Aeson.ToJSON Platform where+  toJSON platform = Aeson.toJSON $ case platform of+    As3 -> "as3"+    C -> "c"+    Cfml -> "cfml"+    Cocoa -> "cocoa"+    Csharp -> "csharp"+    Elixir -> "elixir"+    Go -> "go"+    Groovy -> "groovy"+    Haskell -> "haskell"+    Java -> "java"+    Javascript -> "javascript"+    Native -> "native"+    Node -> "node"+    Objc -> "objc"+    Other -> "other"+    Perl -> "perl"+    Php -> "php"+    Python -> "python"+    Ruby -> "ruby"
+ src/lib/Patrol/Type/Request.hs view
@@ -0,0 +1,30 @@+module Patrol.Type.Request+  ( Request(..)+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text+import qualified Patrol.Utility.Json as Json++data Request = Request+  { cookies :: Maybe (Map.Map Text.Text Text.Text)+  , data_ :: Maybe Aeson.Value+  , env :: Maybe (Map.Map Text.Text Text.Text)+  , headers :: Maybe (Map.Map Text.Text Text.Text)+  , method :: Maybe Text.Text+  , queryString :: Maybe (Map.Map Text.Text Text.Text)+  , url :: Maybe Text.Text+  } deriving (Eq, Show)++instance Aeson.ToJSON Request where+  toJSON request = Aeson.object $ Maybe.catMaybes+    [ Json.pair "cookies" <$> cookies request+    , Json.pair "env" <$> env request+    , Json.pair "headers" <$> headers request+    , Json.pair "data" <$> data_ request+    , Json.pair "method" <$> method request+    , Json.pair "query_string" <$> queryString request+    , Json.pair "url" <$> url request+    ]
+ src/lib/Patrol/Type/Response.hs view
@@ -0,0 +1,17 @@+module Patrol.Type.Response+  ( Response(..)+  ) where++import qualified Data.Aeson as Aeson+import qualified Patrol.Type.EventId as EventId+import qualified Patrol.Utility.Json as Json++-- | <https://develop.sentry.dev/sdk/overview/#reading-the-response>+newtype Response = Response+  { id_ :: EventId.EventId+  } deriving (Eq, Show)++instance Aeson.FromJSON Response where+  parseJSON = Aeson.withObject "Response" $ \ object -> do+    id_ <- Json.required object "id"+    pure Response { id_ }
+ src/lib/Patrol/Type/StackTrace.hs view
@@ -0,0 +1,25 @@+module Patrol.Type.StackTrace+  ( StackTrace(..)+  , fromCallStack+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.List.NonEmpty as NonEmpty+import qualified GHC.Stack as Stack+import qualified Patrol.Type.Frame as Frame+import qualified Patrol.Utility.Json as Json++-- | <https://develop.sentry.dev/sdk/event-payloads/stacktrace/>+newtype StackTrace = StackTrace+  { frames :: NonEmpty.NonEmpty Frame.Frame+  } deriving (Eq, Show)++instance Aeson.ToJSON StackTrace where+  toJSON stackTrace = Aeson.object+    [ Json.pair "frames" $ frames stackTrace+    ]++fromCallStack :: Stack.CallStack -> Maybe StackTrace+fromCallStack callStack = do+  frames <- NonEmpty.nonEmpty . fmap (uncurry Frame.fromSrcLoc) $ Stack.getCallStack callStack+  pure StackTrace { frames }
+ src/lib/Patrol/Type/Timestamp.hs view
@@ -0,0 +1,22 @@+module Patrol.Type.Timestamp+  ( Timestamp+  , fromUtcTime+  , toUtcTime+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Time as Time++-- | <https://develop.sentry.dev/sdk/event-payloads/#required-attributes>+newtype Timestamp+  = Timestamp Time.UTCTime+  deriving (Eq, Show)++instance Aeson.ToJSON Timestamp where+  toJSON = Aeson.toJSON . Time.formatTime Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" . toUtcTime++fromUtcTime :: Time.UTCTime -> Timestamp+fromUtcTime = Timestamp++toUtcTime :: Timestamp -> Time.UTCTime+toUtcTime (Timestamp x) = x
+ src/lib/Patrol/Type/User.hs view
@@ -0,0 +1,23 @@+module Patrol.Type.User+  ( User(..)+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Maybe as Maybe+import qualified Data.Text as Text+import qualified Patrol.Utility.Json as Json++data User = User+  { email :: Maybe Text.Text+  , id_ :: Maybe Text.Text+  , ipAddress :: Maybe Text.Text+  , username :: Maybe Text.Text+  } deriving (Eq, Show)++instance Aeson.ToJSON User where+  toJSON request = Aeson.object $ Maybe.catMaybes+    [ Json.pair "email" <$> email request+    , Json.pair "id" <$> id_ request+    , Json.pair "ipAddress" <$> ipAddress request+    , Json.pair "username" <$> username request+    ]
+ src/lib/Patrol/Utility/Json.hs view
@@ -0,0 +1,14 @@+module Patrol.Utility.Json+  ( pair+  , required+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import qualified Data.Text as Text++pair :: (Aeson.ToJSON value, Aeson.KeyValue pair) => String -> value -> pair+pair key value = Text.pack key Aeson..= value++required :: Aeson.FromJSON value => Aeson.Object -> String -> Aeson.Parser value+required object key = object Aeson..: Text.pack key
+ src/lib/Patrol/Utility/Maybe.hs view
@@ -0,0 +1,6 @@+module Patrol.Utility.Maybe+  ( note+  ) where++note :: e -> Maybe a -> Either e a+note e = maybe (Left e) Right