diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Hardy Jones (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Hardy Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# wai-middleware-rollbar 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/src/Network/Wai/Middleware/Rollbar.hs b/src/Network/Wai/Middleware/Rollbar.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Rollbar.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| + Module : Network.Wai.Middleware.Rollbar + Description : WAI middleware for interfacing with Rollbar + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental + + Provides middleware for communicating with Rollbar. + + Currently has middleware for sending all server errors to Rollbar. + More to come shortly. +-} + +module Network.Wai.Middleware.Rollbar (requests) where + +import Control.Concurrent (forkIO) +import Control.Exception (Handler(Handler), catches, displayException) +import Control.Monad (when) + +import Data.Aeson (ToJSON, defaultOptions, genericToEncoding, toEncoding) +import Data.Functor (void) +import Data.Maybe (fromMaybe) +import Data.Time (getCurrentTime) +import Data.UUID.V4 (nextRandom) + +import GHC.Generics (Generic) + +import Network.HostName (getHostName) +import Network.HTTP.Client (HttpException) +import Network.HTTP.Simple + ( JSONException + , Request + , defaultRequest + , httpNoBody + , setRequestBodyJSON + , setRequestHost + , setRequestIgnoreStatus + , setRequestMethod + , setRequestPath + , setRequestPort + , setRequestSecure + ) +import Network.HTTP.Types.Status + (Status(Status), statusCode, statusIsServerError, statusMessage) +import Network.Wai (Middleware, ResponseReceived) + +import System.Environment (getExecutablePath) +import System.IO (hPutStrLn, stderr) + +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Network.Wai as NW +import qualified Rollbar.Item as RI + +-- | Middleware that watches responses +-- and sends an item to Rollbar if it is a server error (5xx). +-- +-- Sends additional metadata including the request information. +requests :: RI.AccessToken -> RI.Environment -> Middleware +requests accessToken environment app req handler' = app req handler + where + handler :: NW.Response -> IO ResponseReceived + handler res = do + _ <- forkIO $ handle500 accessToken environment req res + handler' res + +handle500 :: RI.AccessToken -> RI.Environment -> NW.Request -> NW.Response -> IO () +handle500 accessToken environment req res = + when (statusIsServerError $ NW.responseStatus res) (send accessToken environment req res) + `catches` + [ Handler handleHttpException + , Handler handleJSONException + ] + +send :: RI.AccessToken -> RI.Environment -> NW.Request -> NW.Response -> IO () +send accessToken environment req res = do + uuid <- Just . RI.UUID4 <$> nextRandom + timestamp <- Just <$> getCurrentTime + host <- Just <$> getHostName + root <- Just . RI.Root . T.pack <$> getExecutablePath + let request = Just RI.Request {..} + let server = Just RI.Server { RI.branch = Nothing, RI.serverCodeVersion = Nothing, .. } + let itemData = (RI.error environment messageBody payload) + { RI.request, RI.server, RI.timestamp, RI.uuid } + let rReq = rollbarRequest RI.Item{..} + void $ httpNoBody rReq + where + Status{..} = NW.responseStatus res + headers = RI.Headers $ NW.requestHeaders req + messageBody = RI.MessageBody <$> myDecodeUtf8 statusMessage + rawBody = "" + get = RI.Get $ NW.queryString req + method = RI.Method $ NW.requestMethod req + queryString = RI.QueryString $ NW.rawQueryString req + url = RI.URL (NW.requestHeaderHost req, NW.pathInfo req) + userIP = RI.IP $ NW.remoteHost req + referer = myDecodeUtf8 =<< NW.requestHeaderReferer req + range = myDecodeUtf8 =<< NW.requestHeaderRange req + userAgent = myDecodeUtf8 =<< NW.requestHeaderUserAgent req + payload = Payload + { statusMessage = myDecodeUtf8' statusMessage + , .. + } + + myDecodeUtf8 = either (const Nothing) Just . TE.decodeUtf8' + myDecodeUtf8' = fromMaybe "" . myDecodeUtf8 + +handleHttpException :: HttpException -> IO () +handleHttpException e = do + hPutStrLn stderr "Ran into an exception while sending a request to Rollbar:" + hPutStrLn stderr $ displayException e + +handleJSONException :: JSONException -> IO () +handleJSONException e = do + hPutStrLn stderr "Ran into an exception while parsing JSON response from Rollbar:" + hPutStrLn stderr $ displayException e + +rollbarRequest :: ToJSON a => RI.Item a -> Network.HTTP.Simple.Request +rollbarRequest payload = + setRequestMethod "POST" + . setRequestSecure True + . setRequestHost "api.rollbar.com" + . setRequestPort 443 + . setRequestPath "api/1/item/" + . setRequestBodyJSON payload + . setRequestIgnoreStatus + $ defaultRequest + +data Payload + = Payload + { statusCode :: Int + , statusMessage :: T.Text + , userAgent :: Maybe T.Text + , range :: Maybe T.Text + , referer :: Maybe T.Text + } + deriving (Generic, Show) + +instance ToJSON Payload where + toEncoding = genericToEncoding defaultOptions diff --git a/src/Rollbar/AccessToken.hs b/src/Rollbar/AccessToken.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/AccessToken.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-| + Module : Rollbar.AccessToken + Description : The access token for a project on Rollbar. + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental +-} + +module Rollbar.AccessToken + ( AccessToken(..) + ) where + +import Data.Aeson (ToJSON) +import Data.String (IsString) + +import qualified Data.Text as T + +-- | Should have the scope "post_server_item". +newtype AccessToken + = AccessToken T.Text + deriving (Eq, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item.hs b/src/Rollbar/Item.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| + Module : Rollbar.Item + Description : Datatype for reporting to Rollbar + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental + + Provides a data type that subsumes most of what Rollbar expects for "item"s. + + See Rollbar's + for more details. +-} + +module Rollbar.Item + ( -- * Data helpers + -- | These functions are probably what you want to use most of the time. + -- + -- They create a 'Data' with lots of data prefilled. + -- You can then override what you need with record updates. + debug + , info + , warning + , error + , critical + -- * Item + , Item(..) + -- * Item data + , module Rollbar.AccessToken + , AccessToken(..) + + , module Rollbar.Item.Data + , Data(..) + , Context(..) + , Fingerprint(..) + , Framework(..) + , Title(..) + , UUID4(..) + + -- * Required data + , module Rollbar.Item.Body + , Body(..) + , MessageBody(..) + + , module Rollbar.Item.Environment + , Environment(..) + + , module Rollbar.Item.Level + , Level(..) + + -- * Optional data + , module Rollbar.Item.CodeVersion + , CodeVersion(..) + + , module Rollbar.Item.Hardcoded + , Hardcoded(..) + + , module Rollbar.Item.Person + , Person(..) + , Email(..) + , Id(..) + , Username(..) + + , module Rollbar.Item.Request + , Get(..) + , Headers(..) + , IP(..) + , Method(..) + , QueryString(..) + , RawBody(..) + , URL(..) + + , module Rollbar.Item.Server + , Server(..) + , Branch(..) + , Root(..) + ) where + +import Data.Aeson (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) +import Data.Maybe (fromMaybe) +import Data.Version (showVersion) + +import GHC.Generics (Generic) + +import Prelude hiding (error) + +import Rollbar.AccessToken +import Rollbar.Item.Body +import Rollbar.Item.CodeVersion +import Rollbar.Item.Data +import Rollbar.Item.Environment +import Rollbar.Item.Hardcoded +import Rollbar.Item.Level +import Rollbar.Item.Person +import Rollbar.Item.Request +import Rollbar.Item.Server + +import Rollbar.Item.Internal.Notifier +import Rollbar.Item.Internal.Platform + +import System.Info (os) + +import qualified Data.Text as T +import qualified Paths_wai_middleware_rollbar + +-- | Creates 'Data' with the level set to 'Debug'. +debug :: Environment -> Maybe MessageBody -> payload -> Data payload +debug environment messageBody payload = + Data + { body = Message (fromMaybe "" messageBody) payload + , codeVersion = + SemVer . T.pack $ showVersion Paths_wai_middleware_rollbar.version + , context = Nothing + , custom = Nothing + , environment = environment + , fingerprint = Nothing + , framework = Nothing + , language = Hardcoded + , level = Debug + , notifier = Notifier Hardcoded Paths_wai_middleware_rollbar.version + , person = Nothing + , platform = Platform $ T.pack os + , request = Nothing + , server = Nothing + , timestamp = Nothing + , title = Nothing + , uuid = Nothing + } + +-- | Creates 'Data' with the level set to 'Info'. +info :: Environment -> Maybe MessageBody -> payload -> Data payload +info environment messageBody payload = + (debug environment messageBody payload) { level = Info } + +-- | Creates 'Data' with the level set to 'Warning'. +warning :: Environment -> Maybe MessageBody -> payload -> Data payload +warning environment messageBody payload = + (debug environment messageBody payload) { level = Warning } + +-- | Creates 'Data' with the level set to 'Error'. +error :: Environment -> Maybe MessageBody -> payload -> Data payload +error environment messageBody payload = + (debug environment messageBody payload) { level = Error } + +-- | Creates 'Data' with the level set to 'Critical'. +critical :: Environment -> Maybe MessageBody -> payload -> Data payload +critical environment messageBody payload = + (debug environment messageBody payload) { level = Critical } + +-- | The thing we actually give to Rollbar. +data Item a + = Item + { accessToken :: AccessToken + -- ^ Should have a scope "post_server_item". + , itemData :: Data a + } + deriving (Eq, Generic, Show) + +itemKVs :: (KeyValue kv, ToJSON v) => Item v -> [kv] +itemKVs Item{..} = + [ "access_token" .= accessToken + , "data" .= itemData + ] + +instance ToJSON a => ToJSON (Item a) where + toJSON = object . itemKVs + toEncoding = pairs . mconcat . itemKVs diff --git a/src/Rollbar/Item/Body.hs b/src/Rollbar/Item/Body.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Body.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| + Module : Rollbar.Item.Body + Description : The meat of the Rollbar item + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental + + Use this for providing the majority of your specific data to Rollbar. +-} + +module Rollbar.Item.Body + ( Body(..) + , MessageBody(..) + ) where + +import Data.Aeson (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) +import Data.String (IsString) + +import GHC.Generics (Generic) + +import qualified Data.Text as T + +-- | This is the actual data that you want to give to Rollbar. +-- Most of the rest of Rollbar is metadata. +data Body arbitrary + -- | No stack trace, just a message and some arbitrary data. + = Message + { messageBody :: MessageBody + -- ^ The primary message text. + , messageData :: arbitrary + -- ^ Any arbitrary data you want to send with this message. + } + deriving (Eq, Generic, Show) + +bodyKVs :: (KeyValue kv, ToJSON v) => Body v -> [kv] +bodyKVs Message{..} = + [ "body" .= messageBody + , "data" .= messageData + ] + +instance ToJSON arbitrary => ToJSON (Body arbitrary) where + toJSON = object . bodyKVs + toEncoding = pairs . mconcat . bodyKVs + +-- | The primary message text to send to Rollbar. +newtype MessageBody + = MessageBody T.Text + deriving (Eq, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/CodeVersion.hs b/src/Rollbar/Item/CodeVersion.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/CodeVersion.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveGeneric #-} + +{-| + Module : Rollbar.Item.CodeVersion + Description : Metadata for describing versions of software + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental +-} + +module Rollbar.Item.CodeVersion + ( CodeVersion(..) + ) where + +import Data.Aeson (ToJSON, toEncoding, toJSON) + +import GHC.Generics (Generic) + +import qualified Data.Text as T + +-- | Rollbar supports different ways to say what version the code is. +data CodeVersion + -- | Good ole SemVer. + -- It's 'T.Text' because who knows if you actually got it right... + = SemVer T.Text + -- | Plain integers. + | Number Int + -- | Should be a Git SHA. + | SHA T.Text + deriving (Eq, Generic, Show) + +prettyCodeVersion :: CodeVersion -> T.Text +prettyCodeVersion (SemVer s) = s +prettyCodeVersion (Number n) = T.pack . show $ n +prettyCodeVersion (SHA h) = h + +instance ToJSON CodeVersion where + toJSON = toJSON . prettyCodeVersion + toEncoding = toEncoding . prettyCodeVersion diff --git a/src/Rollbar/Item/Data.hs b/src/Rollbar/Item/Data.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Data.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + Module : Rollbar.Item.Data + Description : Metadata about the item being reported + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental + + The majority of this module is metadata that is reported for each item. +-} + +module Rollbar.Item.Data + ( Data(..) + , Context(..) + , Fingerprint(..) + , Framework(..) + , Title(..) + , UUID4(..) + ) where + +import Data.Aeson + ( ToJSON + , Value + , defaultOptions + , genericToEncoding + , genericToJSON + , toEncoding + , toJSON + ) +import Data.Aeson.Types (fieldLabelModifier, omitNothingFields) +import Data.String (IsString) +import Data.Time (UTCTime) +import Data.UUID (UUID, toText) + +import GHC.Generics (Generic) + +import Rollbar.Item.Body (Body) +import Rollbar.Item.CodeVersion (CodeVersion) +import Rollbar.Item.Environment (Environment) +import Rollbar.Item.Hardcoded (Hardcoded) +import Rollbar.Item.Level (Level) +import Rollbar.Item.Person (Person) +import Rollbar.Item.Request (Request) +import Rollbar.Item.Server (Server) + +import Rollbar.Item.Internal.Notifier (Notifier) +import Rollbar.Item.Internal.Platform (Platform) + +import qualified Data.HashMap.Lazy as HM +import qualified Data.Text as T + +-- | The main payload of an item. +-- Most of this is metadata. +-- +-- N.B. While it's entirely possible for you to create one of these yourself, +-- it's usually easier to use helpers like 'info' and 'error'. +data Data body + = Data + { body :: Body body + , codeVersion :: CodeVersion + -- ^ Metadata about this package. You probably shouldn't create this yourself. + , context :: Maybe Context + , custom :: Maybe (HM.HashMap T.Text Value) + , environment :: Environment + , fingerprint :: Maybe Fingerprint + , framework :: Maybe Framework + , language :: Hardcoded "haskell" + , level :: Level + , notifier :: Notifier + -- ^ Metadata about this package. You probably shouldn't create this yourself. + , person :: Maybe Person + , platform :: Platform + -- ^ Metadata about this package. You probably shouldn't create this yourself. + , request :: Maybe Request + , server :: Maybe Server + , timestamp :: Maybe UTCTime + , title :: Maybe Title + , uuid :: Maybe UUID4 + } + deriving (Eq, Generic, Show) + +instance ToJSON body => ToJSON (Data body) where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = codeVersionModifier + , omitNothingFields = True + } + toEncoding = genericToEncoding defaultOptions + { fieldLabelModifier = codeVersionModifier + , omitNothingFields = True + } + +codeVersionModifier :: (Eq s, IsString s) => s -> s +codeVersionModifier = \case + "codeVersion" -> "code_version" + str -> str + +-- | The framework that is using this package. +-- E.g. "scotty", "servant", "yesod" +newtype Framework + = Framework T.Text + deriving (Eq, IsString, Show, ToJSON) + +-- | The place in the code where this item came from. +newtype Context + = Context T.Text + deriving (Eq, IsString, Show, ToJSON) + +-- | How to group the item. +newtype Fingerprint + = Fingerprint T.Text + deriving (Eq, IsString, Show, ToJSON) + +-- | The title of the item. +newtype Title + = Title T.Text + deriving (Eq, IsString, Show, ToJSON) + +-- | A unique identifier for each item. +newtype UUID4 + = UUID4 UUID + deriving (Eq, Generic, Show) + +instance ToJSON UUID4 where + toJSON (UUID4 u) = toJSON (toText u) + toEncoding (UUID4 u) = toEncoding (toText u) diff --git a/src/Rollbar/Item/Environment.hs b/src/Rollbar/Item/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Environment.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-| + Module : Rollbar.Item.Environment + Description : The environment from which this package is running. + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental +-} + +module Rollbar.Item.Environment + ( Environment(..) + ) where + +import Data.Aeson (ToJSON) +import Data.String (IsString) + +import qualified Data.Text as T + +-- | Should be something meaningful to your program. +-- E.g. "development", "production", "staging" +newtype Environment + = Environment T.Text + deriving (Eq, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Hardcoded.hs b/src/Rollbar/Item/Hardcoded.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Hardcoded.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} + +{-| + Module : Rollbar.Item.Hardcoded + Description : Provides a way to hard code a value in JSOn + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental + + Probably this could live outside the package... +-} + +module Rollbar.Item.Hardcoded + ( Hardcoded(..) + ) where + +import Data.Aeson (ToJSON, toEncoding, toJSON) + +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) + +-- | This is basically 'Data.Proxy' with the variable restricted to 'Symbol'. +-- It's mostly useful so a value can be insert into a JSON blob easily. +data Hardcoded (symbol :: Symbol) + = Hardcoded + deriving (Eq, Generic, Show) + +instance KnownSymbol symbol => ToJSON (Hardcoded symbol) where + toJSON = toJSON . symbolVal + toEncoding = toEncoding . symbolVal diff --git a/src/Rollbar/Item/Internal/Notifier.hs b/src/Rollbar/Item/Internal/Notifier.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Internal/Notifier.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + Module : Rollbar.Item.Internal.Notifier + Description : Metadata about this actual package + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental + + Mostly, you shouldn't have to worry about this. +-} + +module Rollbar.Item.Internal.Notifier + ( Notifier(..) + ) where + +import Data.Aeson (ToJSON, defaultOptions, genericToEncoding, toEncoding) +import Data.Version (Version) + +import GHC.Generics (Generic) + +import Rollbar.Item.Hardcoded (Hardcoded) + +-- | Metadata describing this package. +data Notifier + = Notifier + { name :: Hardcoded "wai-middleware-rollbar" + -- ^ The name of this package + , version :: Version + -- ^ The version of this package + } + deriving (Eq, Generic, Show) + +instance ToJSON Notifier where + toEncoding = genericToEncoding defaultOptions diff --git a/src/Rollbar/Item/Internal/Platform.hs b/src/Rollbar/Item/Internal/Platform.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Internal/Platform.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-| + Module : Rollbar.Item.Internal.Platform + Description : Metadata describing the platform this package is running on. + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental + + Mostly, you shouldn't have to worry about this. +-} + +module Rollbar.Item.Internal.Platform + ( Platform(..) + ) where + +import Data.Aeson (ToJSON) +import Data.String (IsString) + +import qualified Data.Text as T + +-- | Should be something meaningful to rollbar, like "linux". +newtype Platform + = Platform T.Text + deriving (Eq, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Level.hs b/src/Rollbar/Item/Level.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Level.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveGeneric #-} + +{-| + Module : Rollbar.Item.Level + Description : The severity of the item. + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental +-} + +module Rollbar.Item.Level + ( Level(..) + ) where + +import Data.Aeson + ( ToJSON + , defaultOptions + , genericToEncoding + , genericToJSON + , toEncoding + , toJSON + ) +import Data.Aeson.Types (constructorTagModifier) +import Data.Char (toLower) + +import GHC.Generics (Generic) + +-- | Corresponds to the levels Rollbar allows in order of severity. +data Level + = Debug + | Info + | Warning + | Error + | Critical + deriving (Bounded, Enum, Eq, Generic, Ord, Show) + +instance ToJSON Level where + toJSON = genericToJSON defaultOptions + { constructorTagModifier = fmap toLower + } + toEncoding = genericToEncoding defaultOptions + { constructorTagModifier = fmap toLower + } diff --git a/src/Rollbar/Item/Person.hs b/src/Rollbar/Item/Person.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Person.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + Module : Rollbar.Item.Person + Description : The user this item affects. + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental +-} + +module Rollbar.Item.Person + ( Person(..) + , Id(..) + , Username(..) + , Email(..) + ) where + +import Data.Aeson + ( ToJSON + , defaultOptions + , genericToEncoding + , genericToJSON + , toEncoding + , toJSON + ) +import Data.Aeson.Types (omitNothingFields) +import Data.String (IsString) + +import GHC.Generics (Generic) + +import qualified Data.Text as T + +-- | The affected user. +-- +-- The 'Email' and 'Username' associated with the latest 'Id' +-- will overwrite any previous. +data Person + = Person + { id :: Id + , username :: Maybe Username + , email :: Maybe Email + } + deriving (Eq, Generic, Show) + +instance ToJSON Person where + toJSON = genericToJSON defaultOptions { omitNothingFields = True } + toEncoding = genericToEncoding defaultOptions { omitNothingFields = True } + +-- | The user's identifier. This uniquely identifies a 'Person' to Rollbar. +newtype Id + = Id T.Text + deriving (Eq, IsString, Show, ToJSON) + +-- | The user's name. +newtype Username + = Username T.Text + deriving (Eq, IsString, Show, ToJSON) + +-- | The user's email. +newtype Email + = Email T.Text + deriving (Eq, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Request.hs b/src/Rollbar/Item/Request.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Request.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| + Module : Rollbar.Item.Request + Description : Data about the request sent to the server. + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental +-} + +module Rollbar.Item.Request + ( Request(..) + , Get(..) + , Headers(..) + , IP(..) + , Method(..) + , QueryString(..) + , RawBody(..) + , URL(..) + ) where + +import Data.Aeson + (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) +import Data.CaseInsensitive (original) +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) + +import GHC.Generics (Generic) + +import Network.HTTP.Types (Header, Query, RequestHeaders) +import Network.Socket (SockAddr) + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +-- | Data sent to the server +data Request + = Request + { rawBody :: RawBody + , get :: Get + -- ^ Query parameters + , headers :: Headers + , method :: Method + , queryString :: QueryString + -- ^ The entire query string + , url :: URL + , userIP :: IP + -- ^ The client's IP address + } + deriving (Eq, Generic, Show) + +-- | The raw request body as a 'BS.ByteString'. +newtype RawBody + = RawBody BS.ByteString + deriving (Eq, Generic, IsString, Show) + +instance ToJSON RawBody where + toJSON (RawBody body) = toJSON (myDecodeUtf8 body) + toEncoding (RawBody body) = toEncoding (myDecodeUtf8 body) + +-- | The query string parameters as a more useful data structure. +newtype Get + = Get Query + deriving (Eq, Generic, Show) + +instance ToJSON Get where + toJSON (Get q) = object . catMaybes . queryKVs $ q + toEncoding (Get q) = pairs . mconcat . catMaybes . queryKVs $ q + +queryKVs :: forall kv. (KeyValue kv) => Query -> [Maybe kv] +queryKVs = fmap go + where + go :: (BS.ByteString, Maybe BS.ByteString) -> Maybe kv + go (key', val') = do + key <- myDecodeUtf8 key' + let val = val' >>= myDecodeUtf8 + pure (key .= val) + +-- | The request headers +newtype Headers + = Headers RequestHeaders + deriving (Eq, Generic, Show) + +instance ToJSON Headers where + toJSON (Headers hs) = object . catMaybes . requestHeadersKVs $ hs + toEncoding (Headers hs) = pairs . mconcat . catMaybes . requestHeadersKVs $ hs + +requestHeadersKVs :: forall kv. KeyValue kv => RequestHeaders -> [Maybe kv] +requestHeadersKVs = fmap go + where + go :: Header -> Maybe kv + go (key', val') = do + key <- myDecodeUtf8 $ original key' + val <- myDecodeUtf8 val' + pure (T.pack (show key) .= val) + +-- | The HTTP Verb +newtype Method + = Method BS.ByteString + deriving (Eq, Generic, Show) + +instance ToJSON Method where + toJSON (Method q) = toJSON (myDecodeUtf8 q) + toEncoding (Method q) = toEncoding (myDecodeUtf8 q) + +-- | The raw querystring. +newtype QueryString + = QueryString BS.ByteString + deriving (Eq, Generic, Show) + +instance ToJSON QueryString where + toJSON (QueryString q) = toJSON (myDecodeUtf8' q) + toEncoding (QueryString q) = toEncoding (myDecodeUtf8' q) + +-- | The IP address of the client. +newtype IP + = IP SockAddr + deriving (Eq, Generic, Show) + +instance ToJSON IP where + toJSON (IP ip) = toJSON (show ip) + toEncoding (IP ip) = toEncoding (show ip) + +requestKVs :: KeyValue kv => Request -> [kv] +requestKVs Request{..} = + [ "body" .= rawBody + , "GET" .= get + , "headers" .= headers + , "method" .= method + , "query_string" .= queryString + , "url" .= url + , "user_ip" .= userIP + ] + +instance ToJSON Request where + toJSON = object . requestKVs + toEncoding = pairs . mconcat . requestKVs + +-- | The URL as a slightly more useful structure. +newtype URL + = URL (Maybe BS.ByteString, [T.Text]) + deriving (Eq, Generic, Show) + +prettyURL :: URL -> T.Text +prettyURL (URL (host, parts)) = + T.intercalate "/" (fromMaybe "" (host >>= myDecodeUtf8) : parts) + +instance ToJSON URL where + toJSON = toJSON . prettyURL + toEncoding = toEncoding . prettyURL + +myDecodeUtf8 :: BS.ByteString -> Maybe T.Text +myDecodeUtf8 = either (const Nothing) Just . TE.decodeUtf8' + +myDecodeUtf8' :: BS.ByteString -> T.Text +myDecodeUtf8' = fromMaybe "" . myDecodeUtf8 diff --git a/src/Rollbar/Item/Server.hs b/src/Rollbar/Item/Server.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Item/Server.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| + Module : Rollbar.Item.Server + Description : Metadata about the server this package is running on. + Copyright : (c) Hardy Jones, 2017 + License : BSD3 + Maintainer : jones3.hardy@gmail.com + Stability : experimental +-} + +module Rollbar.Item.Server + ( Server(..) + , Root(..) + , Branch(..) + ) where + +import Data.Aeson (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) +import Data.Maybe (catMaybes) +import Data.String (IsString) + +import GHC.Generics (Generic) + +import Network.HostName (HostName) + +import Rollbar.Item.CodeVersion (CodeVersion) + +import qualified Data.Text as T + +-- | Information about the server using this package. +data Server + = Server + { host :: Maybe HostName + -- ^ The hostname of the server. + , root :: Maybe Root + -- ^ The root directory the server is running in. + , branch :: Maybe Branch + -- ^ The checked out branch the server is running on. + , serverCodeVersion :: Maybe CodeVersion + -- ^ The version of the server. + } + deriving (Eq, Generic, Show) + +serverKVs :: KeyValue kv => Server -> [Maybe kv] +serverKVs Server{..} = + [ ("host" .=) <$> host + , ("root" .=) <$> root + , ("branch" .=) <$> branch + , ("code_version" .=) <$> serverCodeVersion + ] + +instance ToJSON Server where + toJSON = object . catMaybes . serverKVs + toEncoding = pairs . mconcat . catMaybes . serverKVs + +-- | The root directory. +newtype Root + = Root T.Text + deriving (Eq, IsString, Show, ToJSON) + +-- | The git branch the server is running on. +newtype Branch + = Branch T.Text + deriving (Eq, IsString, Show, ToJSON) diff --git a/wai-middleware-rollbar.cabal b/wai-middleware-rollbar.cabal new file mode 100644 --- /dev/null +++ b/wai-middleware-rollbar.cabal @@ -0,0 +1,53 @@ +name: wai-middleware-rollbar +version: 0.1.0.0 +synopsis: Middleware that communicates to Rollbar. +description: Middleware that communicates to Rollbar. +homepage: https://github.com/joneshf/wai-middleware-rollbar#readme +license: BSD3 +license-file: LICENSE +author: Hardy Jones +maintainer: jones3.hardy@gmail.com +copyright: 2017 Hardy Jones +category: Web, Wai +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Network.Wai.Middleware.Rollbar + , Rollbar.Item + , Rollbar.AccessToken + , Rollbar.Item.Body + , Rollbar.Item.Data + , Rollbar.Item.CodeVersion + , Rollbar.Item.Environment + , Rollbar.Item.Hardcoded + , Rollbar.Item.Level + , Rollbar.Item.Person + , Rollbar.Item.Request + , Rollbar.Item.Server + + , Rollbar.Item.Internal.Notifier + , Rollbar.Item.Internal.Platform + other-modules: Paths_wai_middleware_rollbar + build-depends: base >= 4.7 && < 5 + , aeson >= 1.0 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , case-insensitive >= 1.2 && < 1.3 + , hostname >= 1.0 && < 1.1 + , http-client >= 0.5 && < 0.6 + , http-conduit >= 2.2 && < 2.3 + , http-types >= 0.9 && < 0.10 + , network >= 2.6 && < 2.7 + , text >= 1.2 && < 1.3 + , time >= 1.6 && < 1.7 + , unordered-containers >= 0.2 && < 0.3 + , uuid >= 1.3 && < 1.4 + , wai >= 3.2 && < 3.3 + default-language: Haskell2010 + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/joneshf/wai-middleware-rollbar