git.iko.soy/typeable/katip
on master help sign in
First stab at payload type annotation
e700f8aMichael Xavier
katip-elasticsearch/bench/Main.hs+29−3
compare with master
unifiedsplit
@@ -10,27 +10,53 @@ module Main
10import Control.DeepSeq
10import Control.DeepSeq
11import Control.Monad
11import Control.Monad
12import Criterion.Main
12import Criterion.Main
13+import Data.Aeson
14+import qualified Data.HashMap.Strict as HM
13import Data.RNG
15import Data.RNG
14−import qualified Data.Text as T
16+import qualified Data.Text as T
15import Database.Bloodhound.Types
17import Database.Bloodhound.Types
16import Numeric
18import Numeric
17-------------------------------------------------------------------------------
19-------------------------------------------------------------------------------
18import Katip.Scribes.ElasticSearch
20import Katip.Scribes.ElasticSearch
21+import Katip.Scribes.ElasticSearch.Annotations
19-------------------------------------------------------------------------------
22-------------------------------------------------------------------------------
20
23
21main :: IO ()
24main :: IO ()
22main = do
25main = do
23 rng <- mkRNG
26 rng <- mkRNG
27+ defaultMain
28+ [
24− defaultMain [mkDocIdBenchmark rng]
29+ mkDocIdBenchmark rng
30+ , deannotateValueBenchmark
31+ ]
25
32
26-------------------------------------------------------------------------------
33-------------------------------------------------------------------------------
27mkDocIdBenchmark :: RNG -> Benchmark
34mkDocIdBenchmark :: RNG -> Benchmark
28mkDocIdBenchmark rng = bgroup "mkDocId"
35mkDocIdBenchmark rng = bgroup "mkDocId"
36+ [
29− [ bench "mkDocId (randomIO)" $ nfIO mkDocId
37+ bench "mkDocId (randomIO)" $ nfIO mkDocId
30 , bench "mkDocId' (shared )" $ nfIO $ mkDocId' rng
38 , bench "mkDocId' (shared )" $ nfIO $ mkDocId' rng
31 ]
39 ]
32
40
33
41
42+-------------------------------------------------------------------------------
43+deannotateValueBenchmark :: Benchmark
44+deannotateValueBenchmark = bgroup "deannotateValue"
45+ [
46+ bench "deannotateValue" $ nf deannotateValue annotatedValue
47+ ]
48+
49+
50+-------------------------------------------------------------------------------
51+annotatedValue :: Value
52+annotatedValue = Object $ HM.fromList [ ("a::string", String "whatever")
53+ , ("b::double", Number 4.5)
54+ , ("c::long", Number 4)
55+ , ("d::boolean", Bool True)
56+ , ("e::null", Null)
57+ ]
58+
59+-------------------------------------------------------------------------------
34mkDocId' :: RNG -> IO DocId
60mkDocId' :: RNG -> IO DocId
35mkDocId' rng = do
61mkDocId' rng = do
36 is <- withRNG rng $ \gen -> replicateM len $ mk gen
62 is <- withRNG rng $ \gen -> replicateM len $ mk gen
katip-elasticsearch/katip-elasticsearch.cabal+11−2
@@ -16,6 +16,7 @@ flag lib-Werror
16library
16library
17 exposed-modules:
17 exposed-modules:
18 Katip.Scribes.ElasticSearch
18 Katip.Scribes.ElasticSearch
19+ Katip.Scribes.ElasticSearch.Annotations
19 build-depends:
20 build-depends:
20 base >=4.6 && <4.9
21 base >=4.6 && <4.9
21 , katip
22 , katip
@@ -31,6 +32,8 @@ library
31 , text
32 , text
32 , retry >= 0.6 && < 0.8
33 , retry >= 0.6 && < 0.8
33 , exceptions
34 , exceptions
35+ , scientific
36+ , unordered-containers
34 hs-source-dirs: src
37 hs-source-dirs: src
35 default-language: Haskell2010
38 default-language: Haskell2010
36 hs-source-dirs: src
39 hs-source-dirs: src
@@ -53,6 +56,8 @@ benchmark bench
53 , rng-utils
56 , rng-utils
54 , uuid
57 , uuid
55 , text
58 , text
59+ , unordered-containers
60+ , aeson
56
61
57test-suite test
62test-suite test
58 type: exitcode-stdio-1.0
63 type: exitcode-stdio-1.0
@@ -65,8 +70,10 @@ test-suite test
65 , http-client
70 , http-client
66 , bloodhound
71 , bloodhound
67 , base
72 , base
68− , tasty
73+ , tasty >= 0.10.1.2 && < 0.11
69 , tasty-hunit
74 , tasty-hunit
75+ , tasty-quickcheck
76+ , quickcheck-instances
70 , containers
77 , containers
71 , transformers
78 , transformers
72 , lens
79 , lens
@@ -74,4 +81,6 @@ test-suite test
74 , text
81 , text
75 , http-types
82 , http-types
76 , aeson
83 , aeson
77−
84+ , vector
85+ , unordered-containers
86+ , scientific
katip-elasticsearch/src/Katip/Scribes/ElasticSearch.hs+39−9
@@ -15,13 +15,16 @@ module Katip.Scribes.ElasticSearch
15 , essRetryPolicy
15 , essRetryPolicy
16 , essQueueSize
16 , essQueueSize
17 , essPoolSize
17 , essPoolSize
18+ , essAnnotateTypes
18 , defaultEsScribeCfg
19 , defaultEsScribeCfg
19 -- * Utilities
20 -- * Utilities
20 , mkDocId
21 , mkDocId
22+ , module Katip.Scribes.ElasticSearch.Annotations
21 ) where
23 ) where
22
24
23
25
24-------------------------------------------------------------------------------
26-------------------------------------------------------------------------------
27+import Control.Applicative
25import Control.Concurrent
28import Control.Concurrent
26import Control.Concurrent.Async
29import Control.Concurrent.Async
27import Control.Concurrent.STM.TBMQueue
30import Control.Concurrent.STM.TBMQueue
@@ -30,12 +33,13 @@ import Control.Exception.Enclosed
30import Control.Monad
33import Control.Monad
31import Control.Monad.Catch
34import Control.Monad.Catch
32import Control.Monad.STM
35import Control.Monad.STM
33−import Control.Retry (RetryPolicy,
36+import Control.Retry (RetryPolicy,
34− exponentialBackoff,
37+ exponentialBackoff,
35− limitRetries, recovering)
38+ limitRetries,
39+ recovering)
36import Data.Aeson
40import Data.Aeson
37−import Data.Monoid ((<>))
41+import Data.Monoid ((<>))
38−import qualified Data.Text.Encoding as T
42+import qualified Data.Text.Encoding as T
39import Data.Typeable
43import Data.Typeable
40import Data.UUID
44import Data.UUID
41import Database.Bloodhound
45import Database.Bloodhound
@@ -43,6 +47,7 @@ import Network.HTTP.Client
43import System.Random
47import System.Random
44-------------------------------------------------------------------------------
48-------------------------------------------------------------------------------
45import Katip.Core
49import Katip.Core
50+import Katip.Scribes.ElasticSearch.Annotations
46-------------------------------------------------------------------------------
51-------------------------------------------------------------------------------
47
52
48
53
@@ -55,6 +60,19 @@ data EsScribeCfg = EsScribeCfg {
55 -- ^ Maximum size of the bounded log queue
60 -- ^ Maximum size of the bounded log queue
56 , essPoolSize :: EsPoolSize
61 , essPoolSize :: EsPoolSize
57 -- ^ Worker pool size limit for sending data to the
62 -- ^ Worker pool size limit for sending data to the
63+ , essAnnotateTypes :: Bool
64+ -- ^ Different payload items coexist in the "data" attribute in
65+ -- ES. It is possible for different payloads to have different
66+ -- types for the same key, e.g. an "id" key that is sometimes a
67+ -- number and sometimes a string. If you're having ES do dynamic
68+ -- mapping, the first log item will set the type and any that
69+ -- don't conform will be *discarded*. If you set this to True,
70+ -- keys will recursively be appended with their ES core
71+ -- type. e.g. "id" would become "id::long" and "id::string"
72+ -- automatically, so they won't conflict. When this library
73+ -- exposes a querying API, we will try to make deserialization and
74+ -- querying transparently remove the type annotations if this is
75+ -- enabled.
58 } deriving (Typeable)
76 } deriving (Typeable)
59
77
60
78
@@ -67,15 +85,23 @@ data EsScribeCfg = EsScribeCfg {
67-- * Queue size of 1000
85-- * Queue size of 1000
68--
86--
69-- * Pool size of 2
87-- * Pool size of 2
88+--
89+-- * Annotate types set to False
70defaultEsScribeCfg :: EsScribeCfg
90defaultEsScribeCfg :: EsScribeCfg
71defaultEsScribeCfg = EsScribeCfg {
91defaultEsScribeCfg = EsScribeCfg {
72 essManagerSettings = defaultManagerSettings
92 essManagerSettings = defaultManagerSettings
73− , essRetryPolicy = exponentialBackoff 25 <> limitRetries 5
93+ , essRetryPolicy = exponentialBackoff 25 <> limitRetries 5
74− , essQueueSize = EsQueueSize 1000
94+ , essQueueSize = EsQueueSize 1000
75− , essPoolSize = EsPoolSize 2
95+ , essPoolSize = EsPoolSize 2
96+ , essAnnotateTypes = False
76 }
97 }
77
98
78
99
100+-------------------------------------------------------------------------------
101+
102+
103+
104+
79-------------------------------------------------------------------------------
105-------------------------------------------------------------------------------
80mkEsScribe
106mkEsScribe
81 :: EsScribeCfg
107 :: EsScribeCfg
@@ -106,9 +132,13 @@ mkEsScribe cfg@EsScribeCfg {..} server ix mapping sev verb = do
106
132
107 let scribe = Scribe $ \ i ->
133 let scribe = Scribe $ \ i ->
108 when (_itemSeverity i >= sev) $
134 when (_itemSeverity i >= sev) $
109− void $ atomically $ tryWriteTBMQueue q (itemJson verb i)
135+ void $ atomically $ tryWriteTBMQueue q (itemJson' verb i)
110 let finalizer = putMVar endSig () >> takeMVar endSig
136 let finalizer = putMVar endSig () >> takeMVar endSig
111 return (scribe, finalizer)
137 return (scribe, finalizer)
138+ where
139+ itemJson' v i
140+ | essAnnotateTypes = itemJson v (TypeAnnotated <$> i)
141+ | otherwise = itemJson v i
112
142
113
143
114-------------------------------------------------------------------------------
144-------------------------------------------------------------------------------
katip-elasticsearch/src/Katip/Scribes/ElasticSearch/Annotations.hsnew file+111
@@ -0,0 +1,111 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Katip.Scribes.ElasticSearch.Annotations
3+ ( TypeAnnotated(..)
4+ -- * Exported for benchmarking
5+ , deannotateValue
6+ ) where
7+
8+
9+-------------------------------------------------------------------------------
10+import Control.Applicative
11+import Data.Aeson
12+import qualified Data.Foldable as FT
13+import qualified Data.HashMap.Strict as HM
14+import Data.Maybe
15+import Data.Monoid
16+import Data.Scientific (isFloating)
17+import Data.Text (Text)
18+import qualified Data.Text as T
19+-------------------------------------------------------------------------------
20+import Katip
21+-------------------------------------------------------------------------------
22+
23+
24+-- | Represents a value that can be converted to and from JSON that
25+-- will type annotate object keys when serializing and strip them out when deserializating
26+newtype TypeAnnotated a = TypeAnnotated {
27+ typeAnnotatedValue :: a
28+ }
29+
30+instance ToJSON a => ToJSON (TypeAnnotated a) where
31+ toJSON = annotateValue . toJSON . typeAnnotatedValue
32+
33+
34+instance ToObject a => ToObject (TypeAnnotated a)
35+
36+
37+instance FromJSON a => FromJSON (TypeAnnotated a) where
38+ parseJSON v = TypeAnnotated <$> parseJSON (deannotateValue v)
39+
40+
41+instance LogItem a => LogItem (TypeAnnotated a) where
42+ payloadKeys v (TypeAnnotated x) = case payloadKeys v x of
43+ AllKeys -> AllKeys
44+ -- Take the key selection, overlap it with the actual keys
45+ -- produced and annotate them
46+ SomeKeys ks -> let o = toObject x
47+ oInFocus = HM.fromList $ zip ks (repeat Null)
48+ final = annotateKeys $ HM.intersection o oInFocus
49+ in SomeKeys $ HM.keys final
50+
51+-------------------------------------------------------------------------------
52+-- Conversion Functions
53+-------------------------------------------------------------------------------
54+
55+
56+annotateValue :: Value -> Value
57+annotateValue (Object o) = Object $ annotateKeys o
58+annotateValue (Array a) = Array (annotateValue <$> a)
59+annotateValue x = x
60+
61+
62+annotateKeys :: Object -> Object
63+annotateKeys = HM.fromList . map go . HM.toList
64+ where
65+ go (k, Object o) = (k, Object $ annotateKeys o)
66+ go (k, Array a) = (k, Array (annotateValue <$> a))
67+ go (k, s@(String _)) = (k <> stringAnn, s)
68+ go (k, n@(Number sci)) = if isFloating sci
69+ then (k <> doubleAnn, n)
70+ else (k <> longAnn, n)
71+ go (k, b@(Bool _)) = (k <> booleanAnn, b)
72+ go (k, Null) = (k <> nullAnn, Null)
73+
74+
75+deannotateValue :: Value -> Value
76+deannotateValue (Object o) = Object $ deannotateKeys o
77+deannotateValue (Array a) = Array (deannotateValue <$> a)
78+deannotateValue x = x
79+
80+
81+deannotateKeys :: Object -> Object
82+deannotateKeys = HM.fromList . map go . HM.toList
83+ where
84+ go (k, Object o) = (k, Object $ deannotateKeys o)
85+ go (k, Array a) = (k, Array (deannotateValue <$> a))
86+ go (k, v) = (fromMaybe k k', v)
87+ where
88+ k' = FT.asum (stripSuffix <$> suffixes)
89+ suffixes = [stringAnn, doubleAnn, longAnn, booleanAnn, nullAnn]
90+ stripSuffix suffix = T.stripSuffix suffix k
91+
92+
93+-------------------------------------------------------------------------------
94+-- Annotation Constants
95+-------------------------------------------------------------------------------
96+
97+
98+stringAnn :: Text
99+stringAnn = "::string"
100+
101+doubleAnn :: Text
102+doubleAnn = "::double"
103+
104+longAnn :: Text
105+longAnn = "::long"
106+
107+booleanAnn :: Text
108+booleanAnn = "::boolean"
109+
110+nullAnn :: Text
111+nullAnn = "::null"
katip-elasticsearch/test/Main.hs+93−6
@@ -1,24 +1,32 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
4module Main
5module Main
5 ( main
6 ( main
6 ) where
7 ) where
7
8
8
9
9-------------------------------------------------------------------------------
10-------------------------------------------------------------------------------
11+import Control.Applicative
10−import Control.Lens hiding (mapping)
12+import Control.Lens hiding (mapping, (.=))
11import Control.Monad
13import Control.Monad
12import Control.Monad.IO.Class
14import Control.Monad.IO.Class
13import Data.Aeson
15import Data.Aeson
14import Data.Aeson.Lens
16import Data.Aeson.Lens
17+import Data.Aeson.Types
18+import qualified Data.HashMap.Strict as HM
15import qualified Data.Map as M
19import qualified Data.Map as M
16import Data.Monoid
20import Data.Monoid
21+import Data.Scientific
22+import qualified Data.Vector as V
17import Database.Bloodhound hiding (key)
23import Database.Bloodhound hiding (key)
18import Network.HTTP.Client
24import Network.HTTP.Client
19import Network.HTTP.Types.Status
25import Network.HTTP.Types.Status
26+import Test.QuickCheck.Instances ()
20import Test.Tasty
27import Test.Tasty
21import Test.Tasty.HUnit
28import Test.Tasty.HUnit
29+import Test.Tasty.QuickCheck
22-------------------------------------------------------------------------------
30-------------------------------------------------------------------------------
23import Katip
31import Katip
24import Katip.Scribes.ElasticSearch
32import Katip.Scribes.ElasticSearch
@@ -29,6 +37,7 @@ main :: IO ()
29main = defaultMain $ testGroup "katip-elasticsearch"
37main = defaultMain $ testGroup "katip-elasticsearch"
30 [
38 [
31 withResource setupSearch teardownSearch esTests
39 withResource setupSearch teardownSearch esTests
40+ , typeAnnotatedTests
32 ]
41 ]
33
42
34
43
@@ -36,7 +45,7 @@ main = defaultMain $ testGroup "katip-elasticsearch"
36setupSearch :: IO (Scribe, IO ())
45setupSearch :: IO (Scribe, IO ())
37setupSearch = do
46setupSearch = do
38 bh recreateESSchema
47 bh recreateESSchema
39− mkEsScribe defaultEsScribeCfg svr ixn mn DebugS V3
48+ mkEsScribe defaultEsScribeCfg { essAnnotateTypes = True } svr ixn mn DebugS V3
40
49
41
50
42-------------------------------------------------------------------------------
51-------------------------------------------------------------------------------
@@ -51,13 +60,73 @@ esTests :: IO (Scribe, IO ()) -> TestTree
51esTests setup = testGroup "elasticsearch scribe"
60esTests setup = testGroup "elasticsearch scribe"
52 [
61 [
53 testCase "it flushes to elasticsearch" $ withTestLogging setup $ \done -> do
62 testCase "it flushes to elasticsearch" $ withTestLogging setup $ \done -> do
54− $(logT) () mempty InfoS "A test message"
63+ $(logT) (ExampleCtx True) mempty InfoS "A test message"
55 liftIO $ do
64 liftIO $ do
56 done
65 done
57 logs <- getLogs
66 logs <- getLogs
58 length logs @?= 1
67 length logs @?= 1
59 let l = head logs
68 let l = head logs
60 l ^? key "_source" . key "msg" . _String @?= Just "A test message"
69 l ^? key "_source" . key "msg" . _String @?= Just "A test message"
70+ l ^? key "_source" . key "data" . key "whatever::boolean" . _Bool @?= Just True
71+ ]
72+
73+
74+-------------------------------------------------------------------------------
75+data ExampleCtx = ExampleCtx {
76+ ecBool :: Bool
77+ }
78+
79+instance ToJSON ExampleCtx where
80+ toJSON c = object ["whatever" .= ecBool c]
81+
82+
83+instance ToObject ExampleCtx
84+
85+
86+instance LogItem ExampleCtx where
87+ payloadKeys _ _ = AllKeys
88+
89+-------------------------------------------------------------------------------
90+typeAnnotatedTests :: TestTree
91+typeAnnotatedTests = testGroup "TypeAnnotated"
92+ [
93+ testCase "annotates values on toJSON" $ do
94+ toJSON (TypeAnnotated exampleValue) @?= annotatedExampleValue
95+ , testCase "deannotates on parseJSON" $ do
96+ parseEither parseJSON (toJSON exampleValue) @?= Right exampleValue
97+ , testProperty "roundtrips the same as raw" $ \(v :: Value) ->
98+ let res = typeAnnotatedValue <$> (parseEither parseJSON (toJSON (TypeAnnotated v)))
99+ in res === Right v
100+ ]
101+
102+
103+-------------------------------------------------------------------------------
104+exampleValue :: Value
105+exampleValue = Array $ V.fromList [Null, Object ob]
106+ where
107+ ob = HM.fromList [ ("a bool", Bool False)
108+ , ("a long", Number 24)
109+ , ("a double", Number 52.3)
110+ , ("a string", String "s")
111+ , ("a null", Null)
112+ , ("a map", Object (HM.singleton "baz" (Bool True)))
113+ ]
114+
115+
116+-------------------------------------------------------------------------------
117+annotatedExampleValue :: Value
118+annotatedExampleValue = Array $ V.fromList
119+ [
120+ Null
121+ , Object $ HM.fromList
122+ [
123+ ("a map",Object $ HM.fromList [("baz::boolean", Bool True)])
124+ , ("a bool::boolean", Bool False)
125+ , ("a null::null", Null)
126+ , ("a string::string", String "s")
127+ , ("a double::double", Number 52.3)
128+ , ("a long::long", Number 24.0)
129+ ]
61 ]
130 ]
62
131
63
132
@@ -126,3 +195,21 @@ createESSchema :: BH IO Reply
126createESSchema = do
195createESSchema = do
127 createIndex ixs ixn
196 createIndex ixs ixn
128 putMapping ixn mn mapping
197 putMapping ixn mn mapping
198+
199+
200+-------------------------------------------------------------------------------
201+instance Arbitrary Value where
202+ arbitrary = oneof
203+ [ Object <$> reduceSize arbitrary
204+ , Array . V.fromList <$> reduceSize arbitrary
205+ , String <$> arbitrary
206+ , Number <$> (scientific <$> arbitrary <*> arbitrary)
207+ , Bool <$> arbitrary
208+ , pure Null
209+ ]
210+
211+
212+-------------------------------------------------------------------------------
213+-- | Reduce the size of Arbitrary input for the given generator
214+reduceSize :: Gen a -> Gen a
215+reduceSize f = sized $ \ n -> resize (n `div` 2) f
katip/src/Katip/Core.hs+2−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DeriveFunctor #-}
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -198,7 +199,7 @@ data Item a = Item {
198 , _itemTime :: UTCTime
199 , _itemTime :: UTCTime
199 , _itemNamespace :: Namespace
200 , _itemNamespace :: Namespace
200 , _itemLoc :: Maybe Loc
201 , _itemLoc :: Maybe Loc
201− } deriving (Generic)
202+ } deriving (Generic, Functor)
202makeLenses ''Item
203makeLenses ''Item
203
204
204
205