mirror of
https://github.com/typeable/rollbar-hs.git
synced 2024-09-11 05:35:27 +03:00
This is almost entirely copy-pasted from `wai-middleware-rollbar` 0.8.4. The intent is to make the core data types available for other packages. If this gets unweildy, move it right back.
54 lines
1.8 KiB
Haskell
54 lines
1.8 KiB
Haskell
{-# 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 Test.QuickCheck.Modifiers (getASCIIString)
|
|
|
|
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 . getASCIIString <$> arbitrary
|
|
|
|
instance Arbitrary a => Arbitrary (Data a '["Authorization"]) where
|
|
arbitrary = do
|
|
env <- Environment . T.pack . getASCIIString <$> arbitrary
|
|
message <- fmap (MessageBody . T.pack . getASCIIString) <$> 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
|