diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+Copyright (c) 2013 Alexander Bondarenko
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/raven-haskell.cabal b/raven-haskell.cabal
new file mode 100644
--- /dev/null
+++ b/raven-haskell.cabal
@@ -0,0 +1,40 @@
+name: raven-haskell
+version: 0.1.0.0
+synopsis: Haskell client for Sentry logging service.
+-- description:
+homepage: https://bitbucket.org/dpwiz/raven-haskell
+license: MIT
+license-file: LICENSE
+author: Alexander Bondarenko
+maintainer: aenor.realm@gmail.com
+-- copyright:
+category: Logging
+build-type: Simple
+cabal-version: >=1.8
+
+library
+ hs-source-dirs: src
+ ghc-options: -O2 -Wall
+ exposed-modules:
+ System.Log.Raven
+ System.Log.Raven.Interfaces
+ System.Log.Raven.Types
+ System.Log.Raven.Transport.Debug
+ System.Log.Raven.Transport.HttpConduit
+ -- other-modules:
+ build-depends:
+ base ==4.*,
+ random, uuid,
+ time, old-locale,
+ aeson, bytestring, text, unordered-containers,
+ http-conduit, network
+
+test-suite test
+ type: exitcode-stdio-1.0
+ main-is: Test.hs
+ hs-source-dirs: test
+ build-depends:
+ base,
+ hspec,
+ raven-haskell,
+ bytestring, unordered-containers, aeson
diff --git a/src/System/Log/Raven.hs b/src/System/Log/Raven.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Log/Raven.hs
@@ -0,0 +1,148 @@
+-- | Raven is a client for Sentry event server ().
+--
+-- Start by initializing the raven 'Service':
+--
+-- > l <- initRaven
+-- > "https://pub:priv@sentry.hostname.tld:8443/sentry/example_project"
+-- > id
+-- > sendRecord
+-- > stderrFallback
+--
+-- Send events using 'register' function:
+--
+-- > register l "my.logger.name" Debug "Hi there!" id
+--
+-- Tags and stuff can be added using register update functions.
+--
+-- > import Data.HashMap.Strict as HM
+-- > let tags r = r { srTags = HM.insert "spam" "sausage"
+-- > . HM.insert "eggs" "bacon"
+-- > . srTags r }
+-- > lt <- initRaven dsn tags sendRecord stderrFallback
+-- >
+-- > let culprit r = r { srCulprit = "my.module.function.name" }
+-- > register lt "test.culprit" Error "It's a trap!" culprit
+-- > let extra r = r { srExtra = HM.insert "fnord" "42" $ srExtra r }
+-- > register lt "test.extra" Info "Test with tags and extra, please ignore."
+--
+-- The core package provides only general interface for sending events which
+-- could be wrapped to adapt it to your needs.
+--
+-- > let debug msg = forkIO $ register l "my.logger.name" Debug msg (culprit . extra)
+-- > debug "Async stuff too."
+--
+-- There are some little helpers to compose your own updaters.
+-- You can use them both in 'initRaven' and 'register'.
+--
+-- > l <- initRaven dsn ( tags [ ("spam", "sausage"
+-- > , ("eggs", "bacon") ]
+-- > . extra [ ("more", "stuff") ]
+-- > )
+-- > sendRecord stderrFallback
+-- >
+-- > register l "test.helpers" Info "yup, i'm here." $ culprit "java.lang.NotReally"
+
+module System.Log.Raven
+ ( -- * Event service
+ initRaven, disabledRaven
+ , register
+ -- * Fallback handlers
+ , stderrFallback, errorFallback, silentFallback
+ -- * Record updaters
+ , culprit, tags, extra
+ -- * Lower level helpers
+ , record, recordLBS
+ ) where
+
+import Data.Aeson (encode)
+import Data.ByteString.Lazy (ByteString)
+
+import Data.UUID (UUID)
+import System.Random (randomIO)
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Format (formatTime)
+import System.Locale (defaultTimeLocale)
+import System.IO (stderr, hPutStrLn)
+import qualified Control.Exception as E
+import qualified Data.HashMap.Strict as HM
+
+import System.Log.Raven.Types
+
+-- | Initialize event service.
+initRaven :: String -- ^ Sentry DSN
+ -> (SentryRecord -> SentryRecord) -- ^ Default fields updater. Use 'id' if not needed.
+ -> (SentrySettings -> SentryRecord -> IO ()) -- ^ Event transport from Raven.Transport.*
+ -> (SentryRecord -> IO ()) -- ^ Fallback handler.
+ -> IO SentryService -- ^ Event service to use in 'register'.
+initRaven dsn d t fb = return
+ SentryService { serviceSettings = fromDSN dsn
+ , serviceDefaults = d
+ , serviceTransport = t
+ , serviceFallback = fb
+ }
+
+-- | Disabled service that ignores incoming events.
+disabledRaven :: IO SentryService
+disabledRaven = initRaven "" id undefined undefined
+
+-- | Ask service to store an event.
+register :: SentryService -- ^ Configured raven service.
+ -> String -- ^ Logger name.
+ -> SentryLevel -- ^ Sentry event level.
+ -> String -- ^ Message.
+ -> (SentryRecord -> SentryRecord) -- ^ Record updates.
+ -> IO ()
+register s loggerName level message upd = do
+ rec <- record loggerName level message (upd . serviceDefaults s)
+
+ let transport = serviceTransport s
+
+ case serviceSettings s of
+ SentryDisabled -> return ()
+ settings -> E.catch (transport settings rec)
+ (\(E.SomeException _) -> serviceFallback s $ rec)
+
+-- | Show basic message on stderr.
+stderrFallback :: SentryRecord -> IO ()
+stderrFallback rec =
+ hPutStrLn stderr $ concat
+ [ srTimestamp rec, " "
+ , show $ srLevel rec, " "
+ , srLogger rec, ": "
+ , srMessage rec
+ ]
+
+-- | Crash and burn with record data.
+errorFallback :: SentryRecord -> IO ()
+errorFallback rec = error $ "Error sending record: " ++ show rec
+
+-- | Ignore recording errors.
+silentFallback :: SentryRecord -> IO ()
+silentFallback _ = return ()
+
+-- | Record an event using logging service.
+record :: String -- ^ Logger name.
+ -> SentryLevel -- ^ Level
+ -> String -- ^ Message
+ -> (SentryRecord -> SentryRecord) -- ^ Additional options
+ -> IO SentryRecord
+record logger lvl msg upd = do
+ eid <- (filter (/= '-') . show) `fmap` (randomIO :: IO UUID)
+ ts <- formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" `fmap` getCurrentTime
+ return $! upd (newRecord eid msg ts lvl logger)
+
+-- | JSON-encode record data.
+recordLBS :: SentryRecord -> ByteString
+recordLBS = encode
+
+-- | Set culprit field.
+culprit :: String -> SentryRecord -> SentryRecord
+culprit c r = r { srCulprit = Just c }
+
+-- | Add record tags.
+tags :: [(String, String)] -> SentryRecord -> SentryRecord
+tags ts r = r { srTags = HM.fromList ts `HM.union` srTags r }
+
+-- | Add record extra information.
+extra :: [(String, String)] -> SentryRecord -> SentryRecord
+extra ts r = r { srExtra = HM.fromList ts `HM.union` srExtra r }
diff --git a/src/System/Log/Raven/Interfaces.hs b/src/System/Log/Raven/Interfaces.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Log/Raven/Interfaces.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Structured data interfaces from Sentry core:
+--
+
+module System.Log.Raven.Interfaces
+ ( -- * Core sentry interfaces
+ -- ** Message
+ message
+ -- ** Exception
+ , exception
+ -- ** Http
+ , http, HttpArgs(..)
+ -- ** User
+ , user
+ -- ** Query
+ , query
+ -- * Generic interface helpers
+ , interface
+ , fields, (.=:), fromMaybe, fromAssoc
+ ) where
+
+import Data.Aeson (ToJSON(toJSON), Value, object, (.=))
+import qualified Data.HashMap.Strict as HM
+
+import System.Log.Raven.Types
+
+-- | 'sentry.interfaces.Message':
+-- A standard message consisting of a message arg, and an optional params
+-- arg for formatting.
+message :: String -- ^ Message text (no more than 1000 characters in length).
+ -> [Value] -- ^ Formatting arguments
+ -> SentryRecord -- ^ Record to update
+ -> SentryRecord
+message msg args = interface "sentry.interfaces.Message" info
+ where
+ info = object [ "message" .= take 1000 msg
+ , "params" .= args
+ ]
+
+-- | 'sentry.interfaces.Exception':
+-- A standard exception with a mandatory value argument,
+-- and optional type and``module`` argument describing
+-- the exception class type and module namespace.
+exception :: String -- ^ Value
+ -> Maybe String -- ^ Type
+ -> Maybe String -- ^ Module
+ -> SentryRecord -- ^ Record to update
+ -> SentryRecord
+exception v t m = interface "sentry.interfaces.Exception" info
+ where
+ info = fields [ "value" .=: v
+ , fromMaybe "type" t
+ , fromMaybe "module" m
+ ]
+
+-- | Optional and optionally parsed HTTP query
+data HttpArgs = EmptyArgs
+ | RawArgs String
+ | QueryArgs [(String, String)]
+ deriving (Eq, Show)
+
+-- | 'sentry.interfaces.Http':
+-- The Request information is stored in the Http interface.
+--
+-- Sentry will explicitly look for REMOTE_ADDR in env for things
+-- which require an IP address.
+--
+-- The data variable should only contain the request body
+-- (not the query string). It can either be a dictionary
+-- (for standard HTTP requests) or a raw request body.
+--
+-- > import System.Log.RavenInterfaces as SI
+-- > let upd = SI.http
+-- > "http://absolute.uri/foo"
+-- > "POST"
+-- > (SI.QueryArgs [("foo", "bar")])
+-- > (Just "hello=world")
+-- > (Just "foo=bar")
+-- > [("Content-Type", "text/html")]
+-- > [("REMOTE_ADDR", "127.1.0.1")]
+http :: String -- ^ URL
+ -> String -- ^ Method
+ -> HttpArgs -- ^ Arguments
+ -> Maybe String -- ^ Query string
+ -> Maybe String -- ^ Cookies
+ -> [(String, String)] -- ^ Headers
+ -> [(String, String)] -- ^ Environment
+ -> SentryRecord -- ^ Record to update
+ -> SentryRecord
+http url m args q c hs env = interface "sentry.interfaces.Http" info
+ where
+ info = fields [ "url" .=: url
+ , "method" .=: m
+ , fromHttpArgs args
+ , fromMaybe "query_string" q
+ , fromMaybe "cookies" c
+ , fromAssoc "headers" hs
+ , fromAssoc "env" env
+ ]
+
+ fromHttpArgs EmptyArgs = []
+ fromHttpArgs (RawArgs s) = "data" .=: s
+ fromHttpArgs (QueryArgs kvs) = "data" .=: HM.fromList kvs
+
+-- | 'sentry.interfaces.User':
+-- An interface which describes the authenticated User for a request.
+--
+-- > let upd = SI.user "unique_id" [ ("username", "my_user")
+-- > , ("email", "foo@example.com") ]
+user :: String -- ^ User's unique identifier
+ -> [(String, String)] -- ^ Optional user data
+ -> SentryRecord -- ^ Record to update
+ -> SentryRecord
+user uid kwargs = interface "sentry.interfaces.User" info
+ where
+ info = HM.fromList $ ("id", uid) : kwargs
+
+-- | 'sentry.interfaces.Query':
+-- A SQL query with an optional string describing the SQL driver, engine.
+query :: Maybe String -- ^ SQL Driver
+ -> String -- ^ Query
+ -> SentryRecord -- ^ Record to update
+ -> SentryRecord
+query d q = interface "sentry.interfaces.Query" info
+ where
+ info = fields [ "query" .=: q
+ , fromMaybe "engine" d
+ ]
+
+-- | Generic interface helper.
+interface :: (ToJSON v) => String -> v -> SentryRecord -> SentryRecord
+interface k v rec =
+ rec { srInterfaces = HM.insert k (toJSON v) $ srInterfaces rec }
+
+-- | JSON object with optional fields removed.
+fields :: [[(String, Value)]] -> HM.HashMap String Value
+fields = HM.fromList . concat
+
+-- | A mandatory field.
+(.=:) :: (ToJSON v) => String -> v -> [(String, Value)]
+k .=: v = [(k, toJSON v)]
+
+-- | Optional simple field.
+fromMaybe :: (ToJSON v) => String -> Maybe v -> [(String, Value)]
+fromMaybe k = maybe [] (\v -> [ (k, toJSON v) ])
+
+-- | Optional dict-like field.
+fromAssoc :: String -> [(String, String)] -> [(String, Value)]
+fromAssoc _ [] = []
+fromAssoc k vs = [(k, toJSON . HM.fromList $ vs)]
diff --git a/src/System/Log/Raven/Transport/Debug.hs b/src/System/Log/Raven/Transport/Debug.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Log/Raven/Transport/Debug.hs
@@ -0,0 +1,26 @@
+-- | Dummy «transports» for debugging purposes.
+
+module System.Log.Raven.Transport.Debug
+ ( dumpRecord, briefRecord, catchRecord
+ ) where
+
+import Control.Concurrent.MVar (MVar, putMVar)
+
+import System.Log.Raven.Types
+
+-- | Dump all glory details.
+dumpRecord :: SentrySettings -> SentryRecord -> IO ()
+dumpRecord _ rec = print rec
+
+-- | Log-like output with very few data shown.
+briefRecord :: SentrySettings -> SentryRecord -> IO ()
+briefRecord _ rec = putStrLn $ concat [ srTimestamp rec, " "
+ , show $ srLevel rec, " "
+ , srLogger rec, ": "
+ , srMessage rec
+ ]
+
+-- | Catch event record into an *empty* 'MVar'.
+-- Make sure you take it's contents before next message!
+catchRecord :: MVar SentryRecord -> SentrySettings -> SentryRecord -> IO ()
+catchRecord var _ rec = putMVar var rec
diff --git a/src/System/Log/Raven/Transport/HttpConduit.hs b/src/System/Log/Raven/Transport/HttpConduit.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Log/Raven/Transport/HttpConduit.hs
@@ -0,0 +1,32 @@
+-- | HTTPS-capable transport using http-conduit.
+
+{-# LANGUAGE OverloadedStrings #-}
+module System.Log.Raven.Transport.HttpConduit
+ ( sendRecord
+ ) where
+
+import Network (withSocketsDo)
+import Network.HTTP.Conduit
+import qualified Data.ByteString.Char8 as BS
+
+import System.Log.Raven
+import System.Log.Raven.Types
+
+sendRecord :: SentrySettings -> SentryRecord -> IO ()
+sendRecord conf rec = withSocketsDo $ do
+ let ep = endpointURL conf
+ let auth = concat [ "Sentry sentry_version=2.0"
+ , ", sentry_client=raven-haskell-0.1.0.0"
+ , ", sentry_key=" ++ sentryPublicKey conf
+ , ", sentry_secret=" ++ sentryPrivateKey conf
+ ]
+ case ep of
+ Nothing -> return ()
+ Just url -> do
+ req' <- parseUrl url
+ let req = req' { method = "POST"
+ , requestHeaders = [("X-Sentry-Auth", BS.pack auth)]
+ , requestBody = RequestBodyLBS (recordLBS rec)
+ }
+ res <- withManager $ httpLbs req
+ return ()
diff --git a/src/System/Log/Raven/Types.hs b/src/System/Log/Raven/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Log/Raven/Types.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
+
+-- | Internal representation of event record and related facilities.
+-- Keep this under a pillow when writing custom wrappers.
+
+module System.Log.Raven.Types
+ ( SentrySettings(..), fromDSN, endpointURL
+ , SentryService(..)
+ , SentryLevel(..), SentryRecord(..), newRecord
+ ) where
+
+import Data.Aeson (ToJSON(toJSON), Value, object, (.=))
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
+
+-- * Service settings
+
+-- | Sentry client settings parsed from a DSN.
+data SentrySettings = SentryDisabled
+ | SentrySettings { sentryURI :: !String
+ , sentryPublicKey :: !String
+ , sentryPrivateKey :: !String
+ , sentryProjectId :: !String
+ } deriving (Show, Read, Eq)
+
+-- | Transforms a service DSN into a settings. Format is:
+--
+-- > {PROTOCOL}://{PUBLIC_KEY}:{SECRET_KEY}@{HOST}{PATH}/{PROJECT_ID}
+fromDSN :: String -> SentrySettings
+fromDSN "" = SentryDisabled
+fromDSN dsn@(fst . break (== ':') -> proto)
+ | proto == "http" = makeSettings "http" . splitAt 7 $ dsn
+ | proto == "https" = makeSettings "https" . splitAt 8 $ dsn
+ | otherwise = error $ "fromDSN: unknown protocol (" ++ proto ++ ")"
+ where
+ body = break (== '@')
+
+ keys = break (== ':') . fst . body
+ pub = fst . keys
+ priv = drop 1 . snd . keys
+
+ stuff = stuff' . break (=='/') . reverse . drop 1 . snd . body
+ stuff' (a, b) = (reverse b, reverse a)
+ uri = fst . stuff
+ pid = snd . stuff
+
+ assemble pref s = concat [pref, "://", uri s]
+
+ makeSettings pref (_, s) = verify $! SentrySettings (assemble pref s) (pub s) (priv s) (pid s)
+
+ verify (sentryURI -> "") = error "Empty URI"
+ verify (sentryPublicKey -> "") = error "Empty public key"
+ verify (sentryPrivateKey -> "") = error "Empty private key"
+ verify (sentryProjectId -> "") = error "Empty project id"
+ verify s = s
+
+-- | Assemble http endpoint URL from settings.
+endpointURL :: SentrySettings -> Maybe String
+endpointURL SentryDisabled = Nothing
+endpointURL (SentrySettings uri _ _ pid) = Just $! concat [uri, "api/", pid, "/store/"]
+
+-- * Logging service
+
+-- | Misc settings packaged for easier operations.
+data SentryService = SentryService { serviceSettings :: SentrySettings
+ , serviceDefaults :: (SentryRecord -> SentryRecord)
+ , serviceTransport :: (SentrySettings -> SentryRecord -> IO ())
+ , serviceFallback :: (SentryRecord -> IO ())
+ }
+
+-- * Log entry
+
+-- | Sentry log levels. Custom levels should be configured in Sentry or sending messages will fail.
+data SentryLevel = Fatal
+ | Error
+ | Warning
+ | Info
+ | Debug
+ | Custom String
+ deriving (Show, Read, Eq)
+
+instance ToJSON SentryLevel where
+ toJSON Fatal = "fatal"
+ toJSON Error = "error"
+ toJSON Warning = "warning"
+ toJSON Info = "info"
+ toJSON Debug = "debug"
+ toJSON (Custom s) = toJSON s
+
+type Assoc = HM.HashMap String String
+
+-- | Event packet to be sent. See detailed field descriptions in
+-- .
+data SentryRecord = SentryRecord { srEventId :: !String
+ , srMessage :: !String
+ , srTimestamp :: !String
+ , srLevel :: !SentryLevel
+ , srLogger :: !String
+ , srPlatform :: Maybe String
+ , srCulprit :: Maybe String
+ , srTags :: !Assoc
+ , srServerName :: Maybe String
+ , srModules :: !Assoc
+ , srExtra :: !Assoc
+ , srInterfaces :: HM.HashMap String Value
+ } deriving (Show, Eq)
+
+-- | Initialize a record with all required fields filled in.
+newRecord :: String -> String -> String -> SentryLevel -> String -> SentryRecord
+newRecord eid m t lev logger =
+ SentryRecord
+ eid m t lev logger
+ Nothing Nothing HM.empty Nothing HM.empty HM.empty HM.empty
+
+instance ToJSON SentryRecord where
+ toJSON r = object . concat $
+ [ [ "event_id" .= srEventId r
+ , "message" .= srMessage r
+ , "timestamp" .= srTimestamp r
+ , "level" .= srLevel r
+ , "logger" .= srLogger r
+ ]
+ , maybe [] (\v -> ["platform" .= v]) $ srPlatform r
+ , maybe [] (\v -> ["culprit" .= v]) $ srCulprit r
+ , if HM.null (srTags r) then [] else ["tags" .= srTags r]
+ , maybe [] (\v -> ["server_name" .= v]) $ srServerName r
+ , if HM.null (srModules r) then [] else ["modules" .= srModules r]
+ , if HM.null (srExtra r) then [] else ["extra" .= srExtra r]
+ , if HM.null (srInterfaces r) then [] else [ T.pack iface .= stuff
+ | (iface, stuff) <- HM.toList $ srInterfaces r]
+ ]
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/Test.hs
@@ -0,0 +1,246 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Test.Hspec
+import Control.Exception (evaluate)
+
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.HashMap.Strict as HM
+import Data.Aeson (object, (.=))
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Data.List (sort)
+
+import System.Log.Raven
+import qualified System.Log.Raven.Interfaces as SI
+import System.Log.Raven.Types as LT
+import System.Log.Raven.Transport.Debug (dumpRecord, briefRecord, catchRecord)
+import System.Log.Raven.Transport.HttpConduit (sendRecord)
+
+main :: IO ()
+main = hspec $ do
+ describe "Types" $ do
+ it "parses empty DSN into SentryDisabled" $ do
+ fromDSN "" `shouldBe` SentryDisabled
+
+ it "carps on invalid DSN" $ do
+ evaluate (fromDSN "lol://haha") `shouldThrow` anyException
+ evaluate (fromDSN "http://haha") `shouldThrow` anyException
+
+ it "parses example DSN" $ do
+ fromDSN dsn `shouldBe` ss
+
+ it "generates correct endpoint" $ do
+ endpointURL SentryDisabled `shouldBe` Nothing
+ endpointURL ss `shouldBe` Just "http://example.com/sentry/api/project-id/store/"
+
+ it "generates empty record" $ do
+ newRecord "" "" "" Debug "" `shouldBe` emptyRecord
+
+ it "generates record template" $ do
+ r <- strip `fmap` test
+ r `shouldBe` testRecord
+
+ it "serializes as JSON" $ do
+ r <- strip `fmap` test
+ recordLBS r `shouldBe` testRecordLBS
+
+ describe "Service" $ do
+ it "ignores record when service is disabled" $ do
+ l <- disabledRaven
+ ok <- register l "test.logger" Debug "Fly me to /dev/null" id
+ ok `shouldBe` ()
+
+ it "uses a fallback" $ do
+ v <- newEmptyMVar
+ l <- initRaven "http://bad:boo@localhost:1/raven" id undefined (\_ -> putMVar v True)
+ sent <- register l "test.logger" Debug "Ready or not, here i come!" id
+ sent `shouldBe` ()
+ fbUsed <- takeMVar v
+ fbUsed `shouldBe` True
+
+ describe "Transport: HttpConduit" $ do
+ it "sends a record" $ do
+ l <- initRaven "http://test:test@localhost:19876/raven" id sendRecord errorFallback
+ ok <- register l "test.logger" Debug "Like a record, baby, right round." id
+ ok `shouldBe` ()
+
+ describe "Transport: Debug" $ do
+ it "shows brief message" $ do
+ l <- initRaven "http://not:really@whatever.fake/project" id briefRecord errorFallback
+ ok <- register l "test.logger" Debug "Hi there!" id
+ ok `shouldBe` ()
+
+ it "dumps event record" $ do
+ l <- initRaven "http://not:really@whatever.fake/project" id dumpRecord errorFallback
+ ok <- register l "test.logger" Debug "Hi there!" id
+ ok `shouldBe` ()
+
+ it "catches record into MVar" $ do
+ v <- newEmptyMVar
+ l <- initRaven "http://not:really@whatever.fake/project" id (catchRecord v) errorFallback
+ ok <- register l "test.logger" Debug "Hi there!" id
+ ok `shouldBe` ()
+ rec <- takeMVar v
+ srMessage rec `shouldBe` "Hi there!"
+
+ describe "Updaters" $ do
+ let make = record "test.logger" Debug "test record please ignore"
+
+ it "updates culprit" $ do
+ r <- make $ culprit "Test.main"
+ srCulprit r `shouldBe` Just "Test.main"
+
+ it "updates tags" $ do
+ r <- make $ tags []
+ srTags r `shouldBe` HM.empty
+
+ r <- make $ tags [("test", "shmest")]
+ srTags r `shouldBe` HM.fromList [("test", "shmest")]
+
+ it "updates extra" $ do
+ r <- make $ extra []
+ srExtra r `shouldBe` HM.empty
+
+ r <- make $ extra [("bru", "haha")]
+ srExtra r `shouldBe` HM.fromList [("bru", "haha")]
+
+ it "fills in service defaults" $ do
+ v <- newEmptyMVar
+ l <- initRaven
+ "http://not:really@whatever.fake/project"
+ ( tags [("spam", "eggs"), ("test", "")]
+ . extra [("sausage", "salad")] )
+ (catchRecord v)
+ errorFallback
+ r <- register l "test.logger" Debug "test record please ignore" $ tags [("test", "shmest")]
+ rec <- takeMVar v
+ srTags rec `shouldBe` HM.fromList [("spam", "eggs"), ("test", "shmest")]
+ srExtra rec `shouldBe` HM.fromList [("sausage", "salad")]
+
+ describe "Interfaces" $ do
+ let make = record "test.logger" Debug "test record please ignore"
+ let send r = do
+ ok <- sendRecord (fromDSN "http://test:test@localhost:19876/raven") r
+ ok `shouldBe` ()
+
+ it "registers messages" $ do
+ r <- make $ SI.message "My raw message with interpreted strings like %s" ["this"]
+
+ let ex = object [ "message" .= ("My raw message with interpreted strings like %s" :: String)
+ , "params" .= ["this" :: String]
+ ]
+ HM.lookup "sentry.interfaces.Message" (srInterfaces r) `shouldBe` Just ex
+
+ send r
+
+ it "registers exceptions" $ do
+ r <- make $ SI.exception "Wattttt!" (Just "SyntaxError") (Just "__buitins__")
+
+ let ex = object [ "type" .= ("SyntaxError" :: String)
+ , "value" .= ("Wattttt!" :: String)
+ , "module" .= ("__buitins__" :: String)
+ ]
+
+ HM.lookup "sentry.interfaces.Exception" (srInterfaces r) `shouldBe` Just ex
+
+ send r
+
+ it "registers HTTP queries" $ do
+ r <- make $ SI.http
+ "http://absolute.uri/foo"
+ "POST"
+ (SI.QueryArgs [("foo", "bar")])
+ (Just "hello=world")
+ (Just "foo=bar")
+ [("Content-Type", "text/html")]
+ [("REMOTE_ADDR", "127.1.0.1")]
+
+ let ex = object [ "url" .= ("http://absolute.uri/foo" :: String)
+ , "method" .= ("POST" :: String)
+ , "data" .= object [ "foo" .= ("bar" :: String) ]
+ , "query_string" .= ("hello=world" :: String)
+ , "cookies" .= ("foo=bar" :: String)
+ , "headers" .= object [ "Content-Type" .= ("text/html" :: String) ]
+ , "env" .= object [ "REMOTE_ADDR" .= ("127.1.0.1" :: String)]
+ ]
+ HM.lookup "sentry.interfaces.Http" (srInterfaces r) `shouldBe` Just ex
+
+ send r
+
+ it "registers User data" $ do
+ r <- make $ SI.user "0" [ ("username", "root")
+ , ("email", "root@localhost")
+ , ("is_superuser", "True") -- wart
+ ]
+ let ex = object [ "id" .= ("0" :: String)
+ , "username" .= ("root" :: String)
+ , "email" .= ("root@localhost" :: String)
+ , "is_superuser" .= ("True" :: String)
+ ]
+ HM.lookup "sentry.interfaces.User" (srInterfaces r) `shouldBe` Just ex
+
+ send r
+
+ it "registers SQL queries" $ do
+ r <- make $ SI.query (Just "postgresql-simple") "SELECT 1"
+
+ let ex = object [ "query" .= ("SELECT 1" :: String)
+ , "engine" .= ("postgresql-simple" :: String)
+ ]
+ HM.lookup "sentry.interfaces.Query" (srInterfaces r) `shouldBe` Just ex
+
+ send r
+
+ it "combines interface parts" $ do
+ r <- make $ SI.exception "Please ignore" (Just "TestException") (Just "Test")
+ . SI.http
+ "http://localhost:8000/im/trapped/at/request/factory"
+ "GET"
+ SI.EmptyArgs
+ (Just "help")
+ Nothing
+ []
+ []
+ . SI.user "1001" [ ("username", "test"), ("email", "test@localhost")]
+ . SI.query Nothing "SELECT title, body FROM pages WHERE url=?"
+ sort (HM.keys $ srInterfaces r) `shouldBe` [ "sentry.interfaces.Exception"
+ , "sentry.interfaces.Http"
+ , "sentry.interfaces.Query"
+ , "sentry.interfaces.User"
+ ]
+ send r
+
+dsn = "http://public_key:secret_key@example.com/sentry/project-id"
+
+ss = SentrySettings {
+ sentryURI = "http://example.com/sentry/",
+ sentryPublicKey = "public_key",
+ sentryPrivateKey = "secret_key",
+ sentryProjectId = "project-id"
+ }
+
+strip rec = rec { srEventId = ""
+ , srTimestamp = ""
+ }
+
+test = record "test.logger" Debug "test record please ignore" id
+
+emptyRecord = SentryRecord { srEventId = ""
+ , srMessage = ""
+ , srTimestamp = ""
+ , srLevel = Debug
+ , srLogger = ""
+ , srPlatform = Nothing
+ , srCulprit = Nothing
+ , srTags = HM.empty
+ , srServerName = Nothing
+ , srModules = HM.empty
+ , srExtra = HM.empty
+ , srInterfaces = HM.empty
+ }
+
+testRecord = emptyRecord { srMessage = "test record please ignore"
+ , srLevel = Debug
+ , srLogger = "test.logger"
+ }
+
+testRecordLBS = LBS.pack "{\"timestamp\":\"\",\"message\":\"test record please ignore\",\"event_id\":\"\",\"level\":\"debug\",\"logger\":\"test.logger\"}"