diff --git a/src/Rollbar/AccessToken.hs b/src/Rollbar/AccessToken.hs --- a/src/Rollbar/AccessToken.hs +++ b/src/Rollbar/AccessToken.hs @@ -13,7 +13,7 @@ ( AccessToken(..) ) where -import Data.Aeson (ToJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.String (IsString) import qualified Data.Text as T @@ -21,4 +21,4 @@ -- | Should have the scope "post_server_item". newtype AccessToken = AccessToken T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item.hs b/src/Rollbar/Item.hs --- a/src/Rollbar/Item.hs +++ b/src/Rollbar/Item.hs @@ -85,9 +85,22 @@ , Root(..) ) where -import Data.Aeson (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) -import Data.Maybe (fromMaybe) -import Data.Version (showVersion) +import Data.Aeson + ( FromJSON + , KeyValue + , ToJSON + , Value(Object) + , object + , pairs + , parseJSON + , toEncoding + , toJSON + , (.:) + , (.=) + ) +import Data.Aeson.Types (typeMismatch) +import Data.Maybe (fromMaybe) +import Data.Version (showVersion) import GHC.Generics (Generic) @@ -194,6 +207,10 @@ [ "access_token" .= accessToken , "data" .= itemData ] + +instance FromJSON a => FromJSON (Item a headers) where + parseJSON (Object o) = Item <$> o .: "access_token" <*> o .: "data" + parseJSON v = typeMismatch "Item a headers" v instance (RemoveHeaders headers, ToJSON a) => ToJSON (Item a headers) where toJSON = object . itemKVs diff --git a/src/Rollbar/Item/Body.hs b/src/Rollbar/Item/Body.hs --- a/src/Rollbar/Item/Body.hs +++ b/src/Rollbar/Item/Body.hs @@ -20,8 +20,20 @@ ) where import Data.Aeson - (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) + ( FromJSON + , KeyValue + , ToJSON + , Value(Object) + , object + , pairs + , parseJSON + , toEncoding + , toJSON + , (.:) + , (.=) + ) import Data.Aeson.Encoding (pair) +import Data.Aeson.Types (typeMismatch) import Data.String (IsString) import GHC.Generics (Generic) @@ -46,6 +58,12 @@ , "data" .= messageData ] +instance FromJSON arbitrary => FromJSON (Body arbitrary) where + parseJSON (Object o') = do + o <- o' .: "message" + Message <$> o .: "body" <*> o .: "data" + parseJSON v = typeMismatch "Body arbitrary" v + instance ToJSON arbitrary => ToJSON (Body arbitrary) where toJSON x = object ["message" .= object (bodyKVs x)] toEncoding = pairs . pair "message" . pairs . mconcat . bodyKVs @@ -53,4 +71,4 @@ -- | The primary message text to send to Rollbar. newtype MessageBody = MessageBody T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/CodeVersion.hs b/src/Rollbar/Item/CodeVersion.hs --- a/src/Rollbar/Item/CodeVersion.hs +++ b/src/Rollbar/Item/CodeVersion.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : Rollbar.Item.CodeVersion @@ -13,11 +14,13 @@ ( CodeVersion(..) ) where -import Data.Aeson (ToJSON, toEncoding, toJSON) +import Data.Aeson (FromJSON, ToJSON, parseJSON, toEncoding, toJSON) +import Data.Aeson.Types (typeMismatch) import GHC.Generics (Generic) -import qualified Data.Text as T +import qualified Data.Aeson as A +import qualified Data.Text as T -- | Rollbar supports different ways to say what version the code is. data CodeVersion @@ -34,6 +37,13 @@ prettyCodeVersion (SemVer s) = s prettyCodeVersion (Number n) = T.pack . show $ n prettyCodeVersion (SHA h) = h + +instance FromJSON CodeVersion where + parseJSON (A.String s) = case T.splitOn "." s of + [_major, _minor, _patch] -> pure $ SemVer s + _ -> pure $ SHA s + parseJSON (A.Number n) = pure $ Number $ floor n + parseJSON v = typeMismatch "CodeVersion" v instance ToJSON CodeVersion where toJSON = toJSON . prettyCodeVersion diff --git a/src/Rollbar/Item/Data.hs b/src/Rollbar/Item/Data.hs --- a/src/Rollbar/Item/Data.hs +++ b/src/Rollbar/Item/Data.hs @@ -27,18 +27,22 @@ ) where import Data.Aeson - ( ToJSON - , Value + ( FromJSON + , ToJSON + , Value(String) , defaultOptions + , genericParseJSON , genericToEncoding , genericToJSON + , parseJSON , toEncoding , toJSON ) -import Data.Aeson.Types (fieldLabelModifier, omitNothingFields) +import Data.Aeson.Types + (Options, fieldLabelModifier, omitNothingFields, typeMismatch) import Data.String (IsString) import Data.Time (UTCTime) -import Data.UUID (UUID, toText) +import Data.UUID (UUID, fromText, toText) import GHC.Generics (Generic) @@ -87,16 +91,19 @@ } deriving (Eq, Generic, Show) +instance FromJSON body => FromJSON (Data body headers) where + parseJSON = genericParseJSON options + instance (RemoveHeaders headers, ToJSON body) => ToJSON (Data body headers) where - toJSON = genericToJSON defaultOptions - { fieldLabelModifier = codeVersionModifier - , omitNothingFields = True - } - toEncoding = genericToEncoding defaultOptions - { fieldLabelModifier = codeVersionModifier - , omitNothingFields = True - } + toJSON = genericToJSON options + toEncoding = genericToEncoding options +options :: Options +options = defaultOptions + { fieldLabelModifier = codeVersionModifier + , omitNothingFields = True + } + codeVersionModifier :: (Eq s, IsString s) => s -> s codeVersionModifier = \case "codeVersion" -> "code_version" @@ -106,27 +113,32 @@ -- E.g. "scotty", "servant", "yesod" newtype Framework = Framework T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) -- | The place in the code where this item came from. newtype Context = Context T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) -- | How to group the item. newtype Fingerprint = Fingerprint T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) -- | The title of the item. newtype Title = Title T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) -- | A unique identifier for each item. newtype UUID4 = UUID4 UUID deriving (Eq, Generic, Show) + +instance FromJSON UUID4 where + parseJSON v@(String s) = + maybe (typeMismatch "UUID4" v) (pure . UUID4) $ fromText s + parseJSON v = typeMismatch "UUID4" v instance ToJSON UUID4 where toJSON (UUID4 u) = toJSON (toText u) diff --git a/src/Rollbar/Item/Environment.hs b/src/Rollbar/Item/Environment.hs --- a/src/Rollbar/Item/Environment.hs +++ b/src/Rollbar/Item/Environment.hs @@ -13,7 +13,7 @@ ( Environment(..) ) where -import Data.Aeson (ToJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.String (IsString) import qualified Data.Text as T @@ -22,4 +22,4 @@ -- E.g. "development", "production", "staging" newtype Environment = Environment T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Hardcoded.hs b/src/Rollbar/Item/Hardcoded.hs --- a/src/Rollbar/Item/Hardcoded.hs +++ b/src/Rollbar/Item/Hardcoded.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| Module : Rollbar.Item.Hardcoded @@ -17,7 +18,10 @@ ( Hardcoded(..) ) where -import Data.Aeson (ToJSON, toEncoding, toJSON) +import Data.Aeson + (FromJSON, ToJSON, Value(String), parseJSON, toEncoding, toJSON) +import Data.Aeson.Types (typeMismatch) +import Data.Text (pack) import GHC.Generics (Generic) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) @@ -31,3 +35,8 @@ instance KnownSymbol symbol => ToJSON (Hardcoded symbol) where toJSON = toJSON . symbolVal toEncoding = toEncoding . symbolVal + +instance KnownSymbol symbol => FromJSON (Hardcoded symbol) where + parseJSON (String str) + | str == pack (symbolVal (Hardcoded :: Hardcoded symbol)) = pure Hardcoded + parseJSON v = typeMismatch "Hardcoded symbol" v diff --git a/src/Rollbar/Item/Internal/Notifier.hs b/src/Rollbar/Item/Internal/Notifier.hs --- a/src/Rollbar/Item/Internal/Notifier.hs +++ b/src/Rollbar/Item/Internal/Notifier.hs @@ -17,7 +17,8 @@ ( Notifier(..) ) where -import Data.Aeson (ToJSON, defaultOptions, genericToEncoding, toEncoding) +import Data.Aeson + (FromJSON, ToJSON, defaultOptions, genericToEncoding, toEncoding) import Data.Version (Version) import GHC.Generics (Generic) @@ -34,5 +35,6 @@ } deriving (Eq, Generic, Show) +instance FromJSON Notifier instance ToJSON Notifier where toEncoding = genericToEncoding defaultOptions diff --git a/src/Rollbar/Item/Internal/Platform.hs b/src/Rollbar/Item/Internal/Platform.hs --- a/src/Rollbar/Item/Internal/Platform.hs +++ b/src/Rollbar/Item/Internal/Platform.hs @@ -15,7 +15,7 @@ ( Platform(..) ) where -import Data.Aeson (ToJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.String (IsString) import qualified Data.Text as T @@ -23,4 +23,4 @@ -- | Should be something meaningful to rollbar, like "linux". newtype Platform = Platform T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Level.hs b/src/Rollbar/Item/Level.hs --- a/src/Rollbar/Item/Level.hs +++ b/src/Rollbar/Item/Level.hs @@ -14,14 +14,17 @@ ) where import Data.Aeson - ( ToJSON + ( FromJSON + , ToJSON , defaultOptions + , genericParseJSON , genericToEncoding , genericToJSON + , parseJSON , toEncoding , toJSON ) -import Data.Aeson.Types (constructorTagModifier) +import Data.Aeson.Types (Options, constructorTagModifier) import Data.Char (toLower) import GHC.Generics (Generic) @@ -35,10 +38,14 @@ | Critical deriving (Bounded, Enum, Eq, Generic, Ord, Show) +instance FromJSON Level where + parseJSON = genericParseJSON options + instance ToJSON Level where - toJSON = genericToJSON defaultOptions - { constructorTagModifier = fmap toLower - } - toEncoding = genericToEncoding defaultOptions - { constructorTagModifier = fmap toLower - } + toJSON = genericToJSON options + toEncoding = genericToEncoding options + +options :: Options +options = defaultOptions + { constructorTagModifier = fmap toLower + } diff --git a/src/Rollbar/Item/MissingHeaders.hs b/src/Rollbar/Item/MissingHeaders.hs --- a/src/Rollbar/Item/MissingHeaders.hs +++ b/src/Rollbar/Item/MissingHeaders.hs @@ -18,7 +18,9 @@ , RemoveHeaders ) where -import Data.Aeson (KeyValue, ToJSON, object, toJSON, (.=)) +import Data.Aeson + (FromJSON, KeyValue, ToJSON, object, parseJSON, toJSON, (.=)) +import Data.Bifunctor (bimap) import Data.CaseInsensitive (mk, original) import Data.Maybe (catMaybes) import Data.Proxy (Proxy(Proxy)) @@ -54,6 +56,9 @@ where go (rh, _) = rh /= (mk . BSC8.pack $ symbolVal (Proxy :: Proxy header)) + +instance FromJSON (MissingHeaders headers) where + parseJSON v = MissingHeaders . fmap (bimap (mk . BS.pack) BS.pack) <$> parseJSON v instance RemoveHeaders headers => ToJSON (MissingHeaders headers) where toJSON = object . catMaybes . requestHeadersKVs . removeHeaders diff --git a/src/Rollbar/Item/Person.hs b/src/Rollbar/Item/Person.hs --- a/src/Rollbar/Item/Person.hs +++ b/src/Rollbar/Item/Person.hs @@ -19,7 +19,8 @@ ) where import Data.Aeson - ( ToJSON + ( FromJSON + , ToJSON , defaultOptions , genericToEncoding , genericToJSON @@ -45,6 +46,7 @@ } deriving (Eq, Generic, Show) +instance FromJSON Person instance ToJSON Person where toJSON = genericToJSON defaultOptions { omitNothingFields = True } toEncoding = genericToEncoding defaultOptions { omitNothingFields = True } @@ -52,14 +54,14 @@ -- | The user's identifier. This uniquely identifies a 'Person' to Rollbar. newtype Id = Id T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) -- | The user's name. newtype Username = Username T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) -- | The user's email. newtype Email = Email T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/src/Rollbar/Item/Request.hs b/src/Rollbar/Item/Request.hs --- a/src/Rollbar/Item/Request.hs +++ b/src/Rollbar/Item/Request.hs @@ -25,17 +25,33 @@ , RemoveHeaders ) where -import Data.Aeson (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) -import Data.Maybe (catMaybes, fromMaybe) -import Data.String (IsString) +import Data.Aeson + ( FromJSON + , KeyValue + , ToJSON + , Value(Object, String) + , object + , pairs + , parseJSON + , toEncoding + , toJSON + , (.:) + , (.=) + ) +import Data.Aeson.Types (typeMismatch) +import Data.Bifunctor (bimap) +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) import GHC.Generics (Generic) import Network.HTTP.Types (Query) -import Network.Socket (SockAddr) +import Network.Socket (SockAddr(SockAddrInet), tupleToHostAddress) import Rollbar.Item.MissingHeaders +import Text.Read (readMaybe) + import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -61,6 +77,9 @@ = RawBody BS.ByteString deriving (Eq, Generic, IsString, Show) +instance FromJSON RawBody where + parseJSON v = RawBody . BS.pack <$> parseJSON v + instance ToJSON RawBody where toJSON (RawBody body) = toJSON (myDecodeUtf8 body) toEncoding (RawBody body) = toEncoding (myDecodeUtf8 body) @@ -70,6 +89,9 @@ = Get Query deriving (Eq, Generic, Show) +instance FromJSON Get where + parseJSON v = Get . fmap (bimap BS.pack (fmap BS.pack)) <$> parseJSON v + instance ToJSON Get where toJSON (Get q) = object . catMaybes . queryKVs $ q toEncoding (Get q) = pairs . mconcat . catMaybes . queryKVs $ q @@ -88,6 +110,9 @@ = Method BS.ByteString deriving (Eq, Generic, Show) +instance FromJSON Method where + parseJSON v = Method . BS.pack <$> parseJSON v + instance ToJSON Method where toJSON (Method q) = toJSON (myDecodeUtf8 q) toEncoding (Method q) = toEncoding (myDecodeUtf8 q) @@ -97,6 +122,9 @@ = QueryString BS.ByteString deriving (Eq, Generic, Show) +instance FromJSON QueryString where + parseJSON v = QueryString . BS.pack <$> parseJSON v + instance ToJSON QueryString where toJSON (QueryString q) = toJSON (myDecodeUtf8' q) toEncoding (QueryString q) = toEncoding (myDecodeUtf8' q) @@ -106,6 +134,17 @@ = IP SockAddr deriving (Eq, Generic, Show) +instance FromJSON IP where + parseJSON v@(String s) = case T.splitOn "." s of + [a', b', c', d] -> case T.splitOn ":" d of + [e', f'] -> maybe (typeMismatch "IP" v) pure $ do + [a, b, c, e] <- traverse (readMaybe . T.unpack) [a', b', c', e'] + f <- (readMaybe . T.unpack) f' + pure . IP . SockAddrInet f $ tupleToHostAddress (a, b, c, e) + _ -> typeMismatch "IP" v + _ -> typeMismatch "IP" v + parseJSON v = typeMismatch "IP" v + instance ToJSON IP where toJSON (IP ip) = toJSON (show ip) toEncoding (IP ip) = toEncoding (show ip) @@ -121,6 +160,18 @@ , "user_ip" .= userIP ] +instance FromJSON (Request headers) where + parseJSON (Object o) = + Request + <$> o .: "body" + <*> o .: "GET" + <*> o .: "headers" + <*> o .: "method" + <*> o .: "query_string" + <*> o .: "url" + <*> o .: "user_ip" + parseJSON v = typeMismatch "Request headers" v + instance (RemoveHeaders headers) => ToJSON (Request headers) where toJSON = object . requestKVs toEncoding = pairs . mconcat . requestKVs @@ -133,6 +184,12 @@ prettyURL :: URL -> T.Text prettyURL (URL (host, parts)) = T.intercalate "/" (fromMaybe "" (host >>= myDecodeUtf8) : parts) + +instance FromJSON URL where + parseJSON (String s) = case T.splitOn "/" s of + host:parts | "http" `T.isPrefixOf` host -> pure $ URL (Just $ TE.encodeUtf8 host, parts) + parts -> pure $ URL (Nothing, parts) + parseJSON v = typeMismatch "URL" v instance ToJSON URL where toJSON = toJSON . prettyURL diff --git a/src/Rollbar/Item/Server.hs b/src/Rollbar/Item/Server.hs --- a/src/Rollbar/Item/Server.hs +++ b/src/Rollbar/Item/Server.hs @@ -18,9 +18,22 @@ , Branch(..) ) where -import Data.Aeson (KeyValue, ToJSON, object, pairs, toEncoding, toJSON, (.=)) -import Data.Maybe (catMaybes) -import Data.String (IsString) +import Data.Aeson + ( FromJSON + , KeyValue + , ToJSON + , Value(Object) + , object + , pairs + , parseJSON + , toEncoding + , toJSON + , (.:) + , (.=) + ) +import Data.Aeson.Types (typeMismatch) +import Data.Maybe (catMaybes) +import Data.String (IsString) import GHC.Generics (Generic) @@ -52,6 +65,15 @@ , ("code_version" .=) <$> serverCodeVersion ] +instance FromJSON Server where + parseJSON (Object o) = + Server + <$> o .: "host" + <*> o .: "root" + <*> o .: "branch" + <*> o .: "code_version" + parseJSON v = typeMismatch "Server" v + instance ToJSON Server where toJSON = object . catMaybes . serverKVs toEncoding = pairs . mconcat . catMaybes . serverKVs @@ -59,9 +81,9 @@ -- | The root directory. newtype Root = Root T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) -- | The git branch the server is running on. newtype Branch = Branch T.Text - deriving (Eq, IsString, Show, ToJSON) + deriving (Eq, FromJSON, IsString, Show, ToJSON) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Test.QuickCheck (conjoin, quickCheck) - +import qualified Rollbar.Golden import qualified Rollbar.Item.Data.Test import qualified Rollbar.Item.MissingHeaders.Test import qualified Rollbar.Item.Request.Test main :: IO () main = do + Rollbar.Golden.main Rollbar.Item.Data.Test.props Rollbar.Item.MissingHeaders.Test.props Rollbar.Item.Request.Test.props diff --git a/test/Rollbar/Golden.hs b/test/Rollbar/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Rollbar/Golden.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +module Rollbar.Golden where + +import Data.Proxy (Proxy(Proxy)) + +import Rollbar.Item (Item) +import Rollbar.QuickCheck () + +import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs) +import Test.Hspec (hspec) + +main :: IO () +main = + hspec $ roundtripAndGoldenSpecs (Proxy :: Proxy (Item () '["Authorization"])) diff --git a/test/Rollbar/Item/Data/Test.hs b/test/Rollbar/Item/Data/Test.hs --- a/test/Rollbar/Item/Data/Test.hs +++ b/test/Rollbar/Item/Data/Test.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Rollbar.Item.Data.Test where @@ -7,14 +6,12 @@ import Data.Aeson (encode, toJSON) import Data.Aeson.Lens (key, members) -import Data.Text (Text, pack) - -import Prelude hiding (error) +import Data.Text (Text) import Rollbar.Item +import Rollbar.QuickCheck () -import Test.QuickCheck - (Arbitrary, Property, arbitrary, conjoin, elements, quickCheck) +import Test.QuickCheck (conjoin, quickCheck) props :: IO () props = @@ -34,16 +31,6 @@ length ms == 1 && fst (head ms) `elem` requiredBodyKeys where ms = encode x ^@.. key "body" . members - -instance Arbitrary a => Arbitrary (Data a '["Authorization"]) where - arbitrary = do - env <- Environment . pack <$> arbitrary - message <- fmap (MessageBody . pack) <$> arbitrary - payload <- arbitrary - elements $ (\f -> f env message payload) <$> datas - -datas :: [Environment -> Maybe MessageBody -> a -> Data a '["Authorization"]] -datas = [debug, info, warning, error, critical] requiredBodyKeys :: [Text] requiredBodyKeys = ["trace", "trace_chain", "message", "crash_report"] diff --git a/test/Rollbar/Item/MissingHeaders/Test.hs b/test/Rollbar/Item/MissingHeaders/Test.hs --- a/test/Rollbar/Item/MissingHeaders/Test.hs +++ b/test/Rollbar/Item/MissingHeaders/Test.hs @@ -2,31 +2,22 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Rollbar.Item.MissingHeaders.Test where import Control.Lens ((&), (^@..)) -import Data.Aeson (encode, toJSON) -import Data.Aeson.Lens (key, members) -import Data.Bifunctor (bimap) -import Data.CaseInsensitive (mk, original) -import Data.Proxy (Proxy(Proxy)) -import Data.Text (Text, pack) - -import GHC.TypeLits (KnownSymbol, symbolVal) +import Data.Aeson (encode, toJSON) +import Data.Aeson.Lens (members) import Prelude hiding (error) import Rollbar.Item.MissingHeaders (MissingHeaders(..)) +import Rollbar.QuickCheck () -import Test.QuickCheck - (Arbitrary, Gen, Property, arbitrary, conjoin, elements, quickCheck) +import Test.QuickCheck (conjoin, quickCheck) -import Data.ByteString.Char8 as BSC8 -import Data.Set as S -import Data.Text.Encoding as TE +import Data.Set as S props :: IO () props = do @@ -46,25 +37,25 @@ ] prop_valueAuthorizationIsRemoved :: MissingHeaders '["Authorization"] -> Bool -prop_valueAuthorizationIsRemoved hs@(MissingHeaders rhs) = +prop_valueAuthorizationIsRemoved hs = "Authorization" `S.notMember` actual where actual = toJSON hs ^@.. members & fmap fst & S.fromList prop_encodingAuthorizationIsRemoved :: MissingHeaders '["Authorization"] -> Bool -prop_encodingAuthorizationIsRemoved hs@(MissingHeaders rhs) = +prop_encodingAuthorizationIsRemoved hs = "Authorization" `S.notMember` actual where actual = encode hs ^@.. members & fmap fst & S.fromList prop_valueX_AccessTokenIsRemoved :: MissingHeaders '["X-AccessToken"] -> Bool -prop_valueX_AccessTokenIsRemoved hs@(MissingHeaders rhs) = +prop_valueX_AccessTokenIsRemoved hs = "X-AccessToken" `S.notMember` actual where actual = toJSON hs ^@.. members & fmap fst & S.fromList prop_encodingX_AccessTokenIsRemoved :: MissingHeaders '["X-AccessToken"] -> Bool -prop_encodingX_AccessTokenIsRemoved hs@(MissingHeaders rhs) = +prop_encodingX_AccessTokenIsRemoved hs = "X-AccessToken" `S.notMember` actual where actual = encode hs ^@.. members & fmap fst & S.fromList @@ -73,7 +64,7 @@ :: MissingHeaders '["Authorization", "this is made up", "Server", "X-AccessToken"] -> Bool -prop_valueAllHeadersAreRemoved hs@(MissingHeaders rhs) = +prop_valueAllHeadersAreRemoved hs = "Authorization" `S.notMember` actual && "this is made up" `S.notMember` actual && "Server" `S.notMember` actual @@ -85,24 +76,10 @@ :: MissingHeaders '["Authorization", "this is made up", "Server", "X-AccessToken"] -> Bool -prop_encodingAllHeadersAreRemoved hs@(MissingHeaders rhs) = +prop_encodingAllHeadersAreRemoved hs = "Authorization" `S.notMember` actual && "this is made up" `S.notMember` actual && "Server" `S.notMember` actual && "X-AccessToken" `S.notMember` actual where actual = encode hs ^@.. members & fmap fst & S.fromList - -instance Arbitrary (MissingHeaders '[]) where - arbitrary = do - xs <- arbitrary - let hs = bimap (mk . BSC8.pack) BSC8.pack <$> xs - pure . MissingHeaders $ hs - -instance (KnownSymbol header, Arbitrary (MissingHeaders headers)) - => Arbitrary (MissingHeaders (header ': headers)) where - arbitrary = do - MissingHeaders hs <- arbitrary :: Gen (MissingHeaders headers) - let name = mk . BSC8.pack $ symbolVal (Proxy :: Proxy header) - value <- BSC8.pack <$> arbitrary - pure . MissingHeaders $ (name, value) : hs diff --git a/test/Rollbar/Item/Request/Test.hs b/test/Rollbar/Item/Request/Test.hs --- a/test/Rollbar/Item/Request/Test.hs +++ b/test/Rollbar/Item/Request/Test.hs @@ -7,21 +7,18 @@ import Control.Lens ((&), (^@..)) import Data.Aeson (encode, toJSON) -import Data.Aeson.Lens (key, members) -import Data.Bifunctor (bimap) -import Data.CaseInsensitive (mk, original) -import Data.Text (Text, pack) +import Data.Aeson.Lens (members) +import Data.CaseInsensitive (original) import Prelude hiding (error) -import Rollbar.Item.Request (MissingHeaders(..), RemoveHeaders) +import Rollbar.Item.Request (MissingHeaders(..)) +import Rollbar.QuickCheck () -import Test.QuickCheck - (Arbitrary, Property, arbitrary, conjoin, elements, quickCheck) +import Test.QuickCheck (conjoin, quickCheck) -import Data.ByteString.Char8 as BSC8 -import Data.Set as S -import Data.Text.Encoding as TE +import Data.Set as S +import Data.Text.Encoding as TE props :: IO () props = @@ -43,8 +40,3 @@ where actual = encode hs ^@.. members & fmap fst & S.fromList expected = S.fromList $ either (const "") id . TE.decodeUtf8' . original . fst <$> rhs - -instance Arbitrary (MissingHeaders ("Authorization" ': headers)) where - arbitrary = do - xs <- arbitrary - pure . MissingHeaders $ bimap (mk . BSC8.pack) BSC8.pack <$> xs diff --git a/test/Rollbar/QuickCheck.hs b/test/Rollbar/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/test/Rollbar/QuickCheck.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Rollbar.QuickCheck where + +import Data.Bifunctor (bimap) +import Data.CaseInsensitive (mk) +import Data.Proxy (Proxy(Proxy)) + +import GHC.TypeLits (KnownSymbol, symbolVal) + +import Prelude hiding (error) + +import Rollbar.Item + +import Test.QuickCheck + +import qualified Data.ByteString.Char8 as BSC8 +import qualified Data.Text as T + +instance Arbitrary a => Arbitrary (Item a '["Authorization"]) where + arbitrary = Item <$> arbitrary <*> arbitrary + +instance Arbitrary AccessToken where + arbitrary = AccessToken . T.pack <$> arbitrary + +instance Arbitrary a => Arbitrary (Data a '["Authorization"]) where + arbitrary = do + env <- Environment . T.pack <$> arbitrary + message <- fmap (MessageBody . T.pack) <$> arbitrary + payload <- arbitrary + elements $ (\f -> f env message payload) <$> datas + +datas :: [Environment -> Maybe MessageBody -> a -> Data a '["Authorization"]] +datas = [debug, info, warning, error, critical] + +instance Arbitrary (MissingHeaders '[]) where + arbitrary = do + xs <- arbitrary + let hs = bimap (mk . BSC8.pack) BSC8.pack <$> xs + pure . MissingHeaders $ hs + +instance (KnownSymbol header, Arbitrary (MissingHeaders headers)) + => Arbitrary (MissingHeaders (header ': headers)) where + arbitrary = do + MissingHeaders hs <- arbitrary :: Gen (MissingHeaders headers) + let name = mk . BSC8.pack $ symbolVal (Proxy :: Proxy header) + value <- BSC8.pack <$> arbitrary + pure . MissingHeaders $ (name, value) : hs diff --git a/wai-middleware-rollbar.cabal b/wai-middleware-rollbar.cabal --- a/wai-middleware-rollbar.cabal +++ b/wai-middleware-rollbar.cabal @@ -1,5 +1,5 @@ name: wai-middleware-rollbar -version: 0.3.0 +version: 0.4.0 synopsis: Middleware that communicates to Rollbar. description: Middleware that communicates to Rollbar. homepage: https://github.com/joneshf/wai-middleware-rollbar#readme @@ -34,12 +34,12 @@ , Rollbar.Item.Internal.Platform other-modules: Paths_wai_middleware_rollbar build-depends: base >= 4.7 && < 5 - , aeson >= 1.0 && < 1.2 + , aeson >= 1.0 && < 1.3 , 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-client >= 0.4 && < 0.6 + , http-conduit >= 2.1 && < 2.3 , http-types >= 0.9 && < 0.10 , network >= 2.6 && < 2.7 , text >= 1.2 && < 1.3 @@ -55,20 +55,25 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs - other-modules: Rollbar.Item.Data.Test + other-modules: Rollbar.Golden + , Rollbar.Item.Data.Test , Rollbar.Item.MissingHeaders.Test , Rollbar.Item.Request.Test + , Rollbar.QuickCheck build-depends: base + , QuickCheck >= 2.8 && < 2.10 , aeson , bytestring , case-insensitive , containers >= 0.5 && < 0.6 - , lens >= 4.15 && < 4.16 + , hspec >= 2.2 && < 2.5 + , hspec-golden-aeson >= 0.2 && < 0.3 + , lens >= 4.14 && < 4.16 , lens-aeson >= 1.0 && < 1.1 - , QuickCheck >= 2.9 && < 2.10 , text , wai-middleware-rollbar default-language: Haskell2010 + ghc-options: -Wall source-repository head type: git