diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..e31b827 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,14 @@ +indentation: 2 +function-arrows: trailing +comma-style: leading # default +import-export-style: leading +indent-wheres: false # default +record-brace-space: true +newlines-between-decls: 1 # default +haddock-style: multi-line # default +haddock-style-module: # default +let-style: newline +in-style: left-align +unicode: never # default +respectful: true # default +single-constraint-parens: never diff --git a/package.yaml b/package.yaml index d624669..e9a0547 100644 --- a/package.yaml +++ b/package.yaml @@ -26,7 +26,6 @@ dependencies: - aeson >=1.2 && < 2.2 - vector >=0.12 && < 0.14 - network >=2.6 && < 3.2 - - basic-prelude >=0.7 && < 0.8 - monad-control >=1.0.2 && < 1.0.4 - resourcet >=1.1 && < 1.3 - http-conduit >=2.2 && < 2.4 diff --git a/rollbar.cabal b/rollbar.cabal index 7174a0e..3e22f50 100644 --- a/rollbar.cabal +++ b/rollbar.cabal @@ -29,7 +29,6 @@ library build-depends: aeson >=1.2 && <2.2 , base >=4.6 && <5 - , basic-prelude ==0.7.* , http-conduit >=2.2 && <2.4 , lifted-base ==0.2.3.* , monad-control >=1.0.2 && <1.0.4 diff --git a/src/Rollbar.hs b/src/Rollbar.hs index 14f99a7..5cdc212 100644 --- a/src/Rollbar.hs +++ b/src/Rollbar.hs @@ -1,231 +1,235 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | Main entry point to the application. -module Rollbar ( - ApiToken (..), - UUID (..), - Environment (..), - Person (..), - Settings (..), - Options (..), - emptyOptions, - simpleLogMessage, - reportErrorS, - reportLoggerErrorS, - reportErrorSCustomFingerprint, - reportErrorSWithOptions, - buildFrameJSON, - buildJSON, -) where - -import BasicPrelude +module Rollbar + ( ApiToken (..) + , UUID (..) + , Environment (..) + , Person (..) + , Settings (..) + , Options (..) + , emptyOptions + , simpleLogMessage + , reportErrorS + , reportLoggerErrorS + , reportErrorSCustomFingerprint + , reportErrorSWithOptions + , buildFrameJSON + , buildJSON + ) where + +import qualified Control.Exception as Ex import Control.Exception.Lifted (catch) +import qualified Control.Monad as Monad +import qualified Control.Monad.IO.Class as MIO import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Aeson hiding (Options) -import Data.Aeson.TH hiding (Options) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson import Data.Aeson.Types (parseMaybe) -import Data.Text (pack, toLower) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T import qualified Data.Vector as V import GHC.Stack (CallStack, SrcLoc (..), getCallStack) import Network.BSD (HostName) -import Network.HTTP.Conduit ( - Request (method, requestBody), - RequestBody (RequestBodyLBS), - Response (..), - httpLbs, - newManager, - parseUrlThrow, - tlsManagerSettings, - ) +import Network.HTTP.Conduit + ( Request (method, requestBody) + , RequestBody (RequestBodyLBS) + , Response (..) + , httpLbs + , newManager + , parseUrlThrow + , tlsManagerSettings + ) -default (Text) +newtype ApiToken = ApiToken {unApiToken :: T.Text} deriving (Show) -newtype ApiToken = ApiToken {unApiToken :: Text} deriving (Show) - -newtype UUID = UUID {unUUID :: Text} deriving (Show) +newtype UUID = UUID {unUUID :: T.Text} deriving (Show) -- (development, production, etc) -newtype Environment = Environment {unEnvironment :: Text} deriving (Show) +newtype Environment = Environment {unEnvironment :: T.Text} deriving (Show) data Person = Person - { id :: Text - , username :: Maybe Text - , email :: Maybe Text - } - deriving (Show) -deriveToJSON defaultOptions ''Person + { personId :: T.Text + , personUsername :: Maybe T.Text + , personEmail :: Maybe T.Text + } + deriving (Show) + +instance Aeson.ToJSON Person where + toJSON person = + Aeson.object + [ "id" .= personId person + , "username" .= personUsername person + , "email" .= personEmail person + ] data Settings = Settings - { environment :: Environment - , token :: ApiToken - , hostName :: HostName - , reportErrors :: Bool - } - deriving (Show) + { environment :: Environment + , token :: ApiToken + , hostName :: HostName + , reportErrors :: Bool + } + deriving (Show) data Options = Options - { person :: Maybe Person - , revisionSha :: Maybe Text - } - deriving (Show) + { optionsPerson :: Maybe Person + , optionsRevisionSha :: Maybe T.Text + } + deriving (Show) emptyOptions :: Options emptyOptions = Options Nothing Nothing -simpleLogMessage :: (MonadIO m) => Text -> Text -> m () +simpleLogMessage :: MIO.MonadIO m => T.Text -> T.Text -> m () simpleLogMessage section message = - putStrLn $ "[Error#" <> section <> "] " <> " " <> message + MIO.liftIO $ putStrLn $ T.unpack $ "[Error#" <> section <> "] " <> " " <> message -- | report errors to rollbar.com and log them to stdout reportErrorS :: - (MonadIO m, MonadBaseControl IO m) => - Settings -> - Options -> - -- | log section - Text -> - Maybe CallStack -> - -- | log message - Text -> - m () + (MIO.MonadIO m, MonadBaseControl IO m) => + Settings -> + Options -> + -- | log section + T.Text -> + Maybe CallStack -> + -- | log message + T.Text -> + m () reportErrorS settings opts section = - reportLoggerErrorS settings opts section simpleLogMessage + reportLoggerErrorS settings opts section simpleLogMessage -- | used by Rollbar.MonadLogger to pass a custom logger reportLoggerErrorS :: - (MonadIO m, MonadBaseControl IO m) => - Settings -> - Options -> - -- | log section - Text -> - -- | logger that takes the section and the message - (Text -> Text -> m ()) -> - Maybe CallStack -> - -- | log message - Text -> - m () + (MIO.MonadIO m, MonadBaseControl IO m) => + Settings -> + Options -> + -- | log section + T.Text -> + -- | logger that takes the section and the message + (T.Text -> T.Text -> m ()) -> + Maybe CallStack -> + -- | log message + T.Text -> + m () reportLoggerErrorS settings opts section loggerS callstack msg = - void $ reportErrorSWithOptions settings opts section (Just loggerS) msg Nothing callstack + Monad.void $ reportErrorSWithOptions settings opts section (Just loggerS) msg Nothing callstack -- | Pass in custom fingerprint for grouping on rollbar reportErrorSCustomFingerprint :: - (MonadIO m, MonadBaseControl IO m) => - Settings -> - Options -> - -- | log section - Text -> - -- | logger that takes the section and the message - Maybe (Text -> Text -> m ()) -> - Maybe CallStack -> - -- | log message - Text -> - Text -> -- fingerprint - m () + (MIO.MonadIO m, MonadBaseControl IO m) => + Settings -> + Options -> + -- | log section + T.Text -> + -- | logger that takes the section and the message + Maybe (T.Text -> T.Text -> m ()) -> + Maybe CallStack -> + -- | log message + T.Text -> + T.Text -> -- fingerprint + m () reportErrorSCustomFingerprint settings opts section loggerS callstack msg fingerprint = - void $ reportErrorSWithOptions settings opts section loggerS msg (Just fingerprint) callstack + Monad.void $ reportErrorSWithOptions settings opts section loggerS msg (Just fingerprint) callstack -- | Pass in custom fingerprint for grouping on rollbar or a custom logger reportErrorSWithOptions :: - (MonadIO m, MonadBaseControl IO m) => - Settings -> - Options -> - -- | log section - Text -> - -- | logger that takes the section and the message - Maybe (Text -> Text -> m ()) -> - -- | log message - Text -> - Maybe Text -> -- fingerprint - Maybe CallStack -> - m (Maybe UUID) + (MIO.MonadIO m, MonadBaseControl IO m) => + Settings -> + Options -> + -- | log section + T.Text -> + -- | logger that takes the section and the message + Maybe (T.Text -> T.Text -> m ()) -> + -- | log message + T.Text -> + Maybe T.Text -> -- fingerprint + Maybe CallStack -> + m (Maybe UUID) reportErrorSWithOptions settings opts section loggerS msg fingerprint callstack = - if reportErrors settings - then go - else pure Nothing - where - go = - do - logger msg - liftIO $ do - initReq <- parseUrlThrow "https://api.rollbar.com/api/1/item/" - manager <- newManager tlsManagerSettings - let req = initReq{method = "POST", requestBody = RequestBodyLBS $ encode rollbarJson} - response <- httpLbs req manager - let body = responseBody response - uuid = - fmap UUID - $ parseMaybe - ( \obj -> do - result <- obj .: "result" - result .: "uuid" - ) - =<< decode body - pure uuid - `catch` (\(e :: SomeException) -> Nothing <$ logger (pack $ show e)) - - logger = fromMaybe defaultLogger loggerS section - defaultLogger message = pure $ simpleLogMessage section message - rollbarJson = buildJSON settings opts section msg fingerprint callstack - -buildFrameJSON :: (String, SrcLoc) -> Value + if reportErrors settings + then go + else pure Nothing + where + go = + do + logger msg + MIO.liftIO $ do + initReq <- parseUrlThrow "https://api.rollbar.com/api/1/item/" + manager <- newManager tlsManagerSettings + let + req = initReq {method = "POST", requestBody = RequestBodyLBS $ Aeson.encode rollbarJson} + response <- httpLbs req manager + let + body = responseBody response + uuid = + fmap UUID $ + parseMaybe + ( \obj -> do + result <- obj .: "result" + result .: "uuid" + ) + =<< Aeson.decode body + pure uuid + `catch` (\(e :: Ex.SomeException) -> Nothing <$ logger (T.pack $ show e)) + + logger = Maybe.fromMaybe defaultLogger loggerS section + defaultLogger message = pure $ simpleLogMessage section message + rollbarJson = buildJSON settings opts section msg fingerprint callstack + +buildFrameJSON :: (String, SrcLoc) -> Aeson.Value buildFrameJSON (name, srcLoc) = - object - [ "filename" .= String (pack $ srcLocFile srcLoc) - , "method" .= String (pack name) - , "lineno" .= toJSON (srcLocStartLine srcLoc) - , "colno" .= toJSON (srcLocStartCol srcLoc) - , "class_name" .= String (pack $ srcLocModule srcLoc) - ] + Aeson.object + [ "filename" .= Aeson.String (T.pack $ srcLocFile srcLoc) + , "method" .= Aeson.String (T.pack name) + , "lineno" .= Aeson.toJSON (srcLocStartLine srcLoc) + , "colno" .= Aeson.toJSON (srcLocStartCol srcLoc) + , "class_name" .= Aeson.String (T.pack $ srcLocModule srcLoc) + ] buildJSON :: - Settings -> - Options -> - -- | log section - Text -> - -- | log message - Text -> - -- | fingerprint - Maybe Text -> - Maybe CallStack -> - Value + Settings -> + Options -> + -- | log section + T.Text -> + -- | log message + T.Text -> + -- | fingerprint + Maybe T.Text -> + Maybe CallStack -> + Aeson.Value buildJSON settings opts section msg fingerprint callstack = - object - [ "access_token" .= unApiToken (token settings) - , "data" - .= object - ( [ "environment" .= toLower (unEnvironment $ environment settings) - , "level" .= ("error" :: Text) - , "server" .= object ["host" .= hostName settings, "sha" .= revisionSha opts] - , "person" .= toJSON (person opts) - , "body" - .= object - [ "trace" - .= object - [ "frames" .= Array (V.fromList $ maybe [] (map buildFrameJSON . getCallStack) callstack) - , "exception" .= object ["class" .= section, "message" .= msg] - ] - ] + Aeson.object + [ "access_token" .= unApiToken (token settings) + , "data" + .= Aeson.object + ( [ "environment" .= T.toLower (unEnvironment $ environment settings) + , "level" .= ("error" :: T.Text) + , "server" .= Aeson.object ["host" .= hostName settings, "sha" .= optionsRevisionSha opts] + , "person" .= Aeson.toJSON (optionsPerson opts) + , "body" + .= Aeson.object + [ "trace" + .= Aeson.object + [ "frames" .= Aeson.Array (V.fromList $ maybe [] (map buildFrameJSON . getCallStack) callstack) + , "exception" .= Aeson.object ["class" .= section, "message" .= msg] + ] ] - ++ fp - ) - , "title" .= title - , "notifier" - .= object - [ "name" .= "rollbar-haskell" - , "version" .= "1.1.3" - ] - ] - where - title = section <> ": " <> msg - fp = - case fingerprint of - Just fp' -> - ["fingerprint" .= fp'] - Nothing -> - [] + ] + ++ fp + ) + , "title" .= title + , "notifier" + .= Aeson.object + [ "name" .= ("rollbar-haskell" :: T.Text) + , "version" .= ("1.1.3" :: T.Text) + ] + ] + where + title = section <> ": " <> msg + fp = + case fingerprint of + Just fp' -> + ["fingerprint" .= fp'] + Nothing -> + [] diff --git a/src/Rollbar/MonadLogger.hs b/src/Rollbar/MonadLogger.hs index 27fe357..46f6a20 100644 --- a/src/Rollbar/MonadLogger.hs +++ b/src/Rollbar/MonadLogger.hs @@ -1,27 +1,19 @@ -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} - module Rollbar.MonadLogger (reportErrorS) where -import BasicPrelude - -import Rollbar hiding (reportErrorS) - -import GHC.Stack (CallStack) - -default (Text) +import qualified Data.Text as T +import GHC.Exception (CallStack) +import qualified Rollbar -- | report errors to rollbar.com and log them with monad-logger reportErrorS :: - Settings -> - Options -> - -- | log section - Text -> - -- | monad-logger logging function. takes a section and a message - (Text -> Text -> IO ()) -> - Maybe CallStack -> - -- | message - Text -> - IO () -reportErrorS = reportLoggerErrorS + Rollbar.Settings -> + Rollbar.Options -> + -- | log section + T.Text -> + -- | monad-logger logging function. takes a section and a message + (T.Text -> T.Text -> IO ()) -> + Maybe CallStack -> + -- | message + T.Text -> + IO () +reportErrorS = Rollbar.reportLoggerErrorS