Hello community,
here is the log from the commit of package ghc-katip-elasticsearch for
openSUSE:Factory checked in at 2017-08-31 20:56:55
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-katip-elasticsearch (Old)
and /work/SRC/openSUSE:Factory/.ghc-katip-elasticsearch.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-katip-elasticsearch"
Thu Aug 31 20:56:55 2017 rev:3 rq:513412 version:0.4.0.0
Changes:
--------
---
/work/SRC/openSUSE:Factory/ghc-katip-elasticsearch/ghc-katip-elasticsearch.changes
2017-07-11 08:26:41.248321059 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-katip-elasticsearch.new/ghc-katip-elasticsearch.changes
2017-08-31 20:56:55.615509731 +0200
@@ -1,0 +2,5 @@
+Fri Jul 28 10:09:18 UTC 2017 - psim...@suse.com
+
+- Update to version 0.4.0.0.
+
+-------------------------------------------------------------------
Old:
----
katip-elasticsearch-0.3.1.0.tar.gz
New:
----
katip-elasticsearch-0.4.0.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-katip-elasticsearch.spec ++++++
--- /var/tmp/diff_new_pack.nRhBdQ/_old 2017-08-31 20:56:56.203427126 +0200
+++ /var/tmp/diff_new_pack.nRhBdQ/_new 2017-08-31 20:56:56.203427126 +0200
@@ -19,7 +19,7 @@
%global pkg_name katip-elasticsearch
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.3.1.0
+Version: 0.4.0.0
Release: 0
Summary: ElasticSearch scribe for the Katip logging framework
License: BSD-3-Clause
@@ -30,6 +30,7 @@
BuildRequires: ghc-aeson-devel
BuildRequires: ghc-async-devel
BuildRequires: ghc-bloodhound-devel
+BuildRequires: ghc-bytestring-devel
BuildRequires: ghc-enclosed-exceptions-devel
BuildRequires: ghc-exceptions-devel
BuildRequires: ghc-http-client-devel
@@ -51,6 +52,7 @@
BuildRequires: ghc-lens-aeson-devel
BuildRequires: ghc-lens-devel
BuildRequires: ghc-quickcheck-instances-devel
+BuildRequires: ghc-tagged-devel
BuildRequires: ghc-tasty-devel
BuildRequires: ghc-tasty-hunit-devel
BuildRequires: ghc-tasty-quickcheck-devel
@@ -96,6 +98,6 @@
%files devel -f %{name}-devel.files
%defattr(-,root,root,-)
-%doc README.md changelog.md
+%doc README.md changelog.md examples
%changelog
++++++ katip-elasticsearch-0.3.1.0.tar.gz -> katip-elasticsearch-0.4.0.0.tar.gz
++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/bench/Main.hs
new/katip-elasticsearch-0.4.0.0/bench/Main.hs
--- old/katip-elasticsearch-0.3.1.0/bench/Main.hs 2017-06-27
00:42:06.000000000 +0200
+++ new/katip-elasticsearch-0.4.0.0/bench/Main.hs 2017-07-24
22:50:35.000000000 +0200
@@ -11,14 +11,15 @@
import Control.Monad
import Criterion.Main
import Data.Aeson
-import qualified Data.HashMap.Strict as HM
+import qualified Data.HashMap.Strict as HM
+import Data.Proxy (Proxy (..))
import Data.RNG
-import qualified Data.Text as T
-import Database.Bloodhound.Types
+import qualified Data.Text as T
+import Database.V1.Bloodhound.Types
import Numeric
-------------------------------------------------------------------------------
import Katip.Scribes.ElasticSearch
-import Katip.Scribes.ElasticSearch.Annotations
+import Katip.Scribes.ElasticSearch.Internal (ESV1)
-------------------------------------------------------------------------------
main :: IO ()
@@ -34,7 +35,7 @@
mkDocIdBenchmark :: RNG -> Benchmark
mkDocIdBenchmark rng = bgroup "mkDocId"
[
- bench "mkDocId (randomIO)" $ nfIO mkDocId
+ bench "mkDocId (randomIO)" $ nfIO (mkDocId (Proxy :: Proxy ESV1))
, bench "mkDocId' (shared )" $ nfIO $ mkDocId' rng
]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/changelog.md
new/katip-elasticsearch-0.4.0.0/changelog.md
--- old/katip-elasticsearch-0.3.1.0/changelog.md 2017-06-27
00:42:06.000000000 +0200
+++ new/katip-elasticsearch-0.4.0.0/changelog.md 2017-07-24
22:50:35.000000000 +0200
@@ -1,3 +1,8 @@
+0.4.0.0
+=======
+* Update to bloodhound >= 0.13.0.0. This version adds support for both
ElasticSearch versions 1 and 5. Previously, we implicitly supported one and
maybe would work on 5. The types in `EsScribeCfg` had to change to be able to
specify which version was being targeted.
+* Improved documentation.
+
0.3.1.0
=======
* Widen dependency on katip
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/examples/example.hs
new/katip-elasticsearch-0.4.0.0/examples/example.hs
--- old/katip-elasticsearch-0.3.1.0/examples/example.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/katip-elasticsearch-0.4.0.0/examples/example.hs 2017-07-24
22:50:35.000000000 +0200
@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main
+ ( main
+ ) where
+
+
+-------------------------------------------------------------------------------
+import Control.Exception
+import Database.V5.Bloodhound
+import Network.HTTP.Client
+-------------------------------------------------------------------------------
+import Katip
+import Katip.Scribes.ElasticSearch
+-------------------------------------------------------------------------------
+
+
+main :: IO ()
+main = do
+ mgr <- newManager defaultManagerSettings
+ let bhe = mkBHEnv (Server "localhost") mgr
+ esScribe <- mkEsScribe
+ -- Reasonable for production
+ defaultEsScribeCfgV5
+ -- Reasonable for single-node in development
+ -- defaultEsScribeCfgV5 { essIndexSettings = IndexSettings (ShardCound 1)
(ReplicaCount 0)}
+ bhe
+ (IndexName "all-indices-prefixed-with")
+ (MappingName "application-logs")
+ DebugS
+ V3
+ let mkLogEnv = registerScribe "es" esScribe defaultScribeSettings =<<
initLogEnv "MyApp" "production"
+ bracket mkLogEnv closeScribes $ \le -> runKatipT le $ do
+ logMsg "ns" InfoS "This goes to elasticsearch"
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/katip-elasticsearch-0.3.1.0/katip-elasticsearch.cabal
new/katip-elasticsearch-0.4.0.0/katip-elasticsearch.cabal
--- old/katip-elasticsearch-0.3.1.0/katip-elasticsearch.cabal 2017-06-27
00:42:06.000000000 +0200
+++ new/katip-elasticsearch-0.4.0.0/katip-elasticsearch.cabal 2017-07-24
22:50:35.000000000 +0200
@@ -1,7 +1,7 @@
name: katip-elasticsearch
synopsis: ElasticSearch scribe for the Katip logging framework.
description: See README.md for more details.
-version: 0.3.1.0
+version: 0.4.0.0
license: BSD3
license-file: LICENSE
author: Ozgun Ataman, Michael Xavier
@@ -14,6 +14,7 @@
README.md
changelog.md
bench/Main.hs
+ examples/example.hs
test/Main.hs
tested-with: GHC == 7.8.4, GHC== 7.10.3
@@ -25,10 +26,11 @@
exposed-modules:
Katip.Scribes.ElasticSearch
Katip.Scribes.ElasticSearch.Annotations
+ Katip.Scribes.ElasticSearch.Internal
build-depends:
base >=4.6 && <5
- , katip >= 0.2.0.0 && < 0.5
- , bloodhound >= 0.11.0.0 && < 0.13
+ , katip >= 0.2.0.0 && < 0.6
+ , bloodhound >= 0.13.0.0 && < 0.15
, uuid >= 1.3.12 && < 1.4
, aeson >=0.6 && <1.2
, stm >= 2.4.3 && < 2.5
@@ -44,6 +46,7 @@
, transformers >= 0.2 && < 0.6
, http-types >= 0.8 && < 0.10
, time >= 1 && < 1.7
+ , bytestring
hs-source-dirs: src
default-language: Haskell2010
hs-source-dirs: src
@@ -96,6 +99,8 @@
, scientific
, time
, stm
+ , bytestring
+ , tagged
if flag(lib-Werror)
ghc-options: -Wall -Werror
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/katip-elasticsearch-0.3.1.0/src/Katip/Scribes/ElasticSearch/Internal.hs
new/katip-elasticsearch-0.4.0.0/src/Katip/Scribes/ElasticSearch/Internal.hs
--- old/katip-elasticsearch-0.3.1.0/src/Katip/Scribes/ElasticSearch/Internal.hs
1970-01-01 01:00:00.000000000 +0100
+++ new/katip-elasticsearch-0.4.0.0/src/Katip/Scribes/ElasticSearch/Internal.hs
2017-07-24 22:50:35.000000000 +0200
@@ -0,0 +1,520 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+-- | This is an internal module. No guarantees are made in this module
+-- about API stability.
+module Katip.Scribes.ElasticSearch.Internal where
+
+
+-------------------------------------------------------------------------------
+import Control.Applicative as A
+import Control.Concurrent
+import Control.Concurrent.Async
+import Control.Concurrent.STM.TBMQueue
+import Control.Exception.Base
+import Control.Exception.Enclosed
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.IO.Class
+import Control.Monad.STM
+import Control.Retry (RetryPolicy,
+ exponentialBackoff,
+ limitRetries,
+ recovering)
+import Data.Aeson
+import Data.ByteString.Lazy (ByteString)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Time
+import Data.Time.Calendar.WeekDate
+import Data.Typeable as Typeable
+import Data.UUID
+import qualified Data.UUID.V4 as UUID4
+import qualified Database.V1.Bloodhound as V1
+import qualified Database.V5.Bloodhound as V5
+import Network.HTTP.Client
+import Network.HTTP.Types.Status
+import Text.Printf (printf)
+-------------------------------------------------------------------------------
+import Katip.Core
+import Katip.Scribes.ElasticSearch.Annotations
+-------------------------------------------------------------------------------
+
+
+-- | EsScribeCfg now carries a type variable for the version of
+-- ElasticSearch it targets, either 'ESV1' or 'ESV5'. You can use
+-- 'defaultEsScribeCfgV1' and 'defaultESScribeCfgV5' for a good
+-- starting point depending on the ES version you have.
+data EsScribeCfg v = EsScribeCfg {
+ essRetryPolicy :: RetryPolicy
+ -- ^ Retry policy when there are errors sending logs to the server
+ , essQueueSize :: EsQueueSize
+ -- ^ Maximum size of the bounded log queue
+ , essPoolSize :: EsPoolSize
+ -- ^ Worker pool size limit for sending data to the
+ , essAnnotateTypes :: Bool
+ -- ^ Different payload items coexist in the "data" attribute in
+ -- ES. It is possible for different payloads to have different
+ -- types for the same key, e.g. an "id" key that is sometimes a
+ -- number and sometimes a string. If you're having ES do dynamic
+ -- mapping, the first log item will set the type and any that
+ -- don't conform will be *discarded*. If you set this to True,
+ -- keys will recursively be appended with their ES core
+ -- type. e.g. "id" would become "id::l" and "id::s"
+ -- automatically, so they won't conflict. When this library
+ -- exposes a querying API, we will try to make deserialization and
+ -- querying transparently remove the type annotations if this is
+ -- enabled.
+ , essIndexSettings :: IndexSettings v
+ -- ^ This will be the IndexSettings type from the appropriate
+ -- bloodhound module, either @Database.V1.Bloodhound@ or
+ -- @Database.V5.Bloodhound@
+ , essIndexSharding :: IndexShardingPolicy
+ } deriving (Typeable)
+
+
+-- | Reasonable defaults for a config:
+--
+-- * defaultManagerSettings
+--
+-- * exponential backoff with 25ms base delay up to 5 retries
+--
+-- * Queue size of 1000
+--
+-- * Pool size of 2
+--
+-- * Annotate types set to False
+--
+-- * DailyIndexSharding
+defaultEsScribeCfg' :: ESVersion v => proxy v -> EsScribeCfg v
+defaultEsScribeCfg' prx = EsScribeCfg {
+ essRetryPolicy = exponentialBackoff 25 <> limitRetries 5
+ , essQueueSize = EsQueueSize 1000
+ , essPoolSize = EsPoolSize 2
+ , essAnnotateTypes = False
+ , essIndexSettings = defaultIndexSettings prx
+ , essIndexSharding = DailyIndexSharding
+ }
+
+
+-------------------------------------------------------------------------------
+-- | Alias of 'defaultEsScribeCfgV1' to minimize API
+-- breakage. Previous versions of katip-elasticsearch only supported
+-- ES version 1.
+defaultEsScribeCfg :: EsScribeCfg ESV1
+defaultEsScribeCfg = defaultEsScribeCfgV1
+
+
+-------------------------------------------------------------------------------
+-- | EsScribeCfg that will use ElasticSearch V1
+defaultEsScribeCfgV1 :: EsScribeCfg ESV1
+defaultEsScribeCfgV1 = defaultEsScribeCfg' (Typeable.Proxy :: Typeable.Proxy
ESV1)
+
+
+-------------------------------------------------------------------------------
+-- | EsScribeCfg that will use ElasticSearch V5
+defaultEsScribeCfgV5 :: EsScribeCfg ESV5
+defaultEsScribeCfgV5 = defaultEsScribeCfg' (Typeable.Proxy :: Typeable.Proxy
ESV5)
+
+
+-------------------------------------------------------------------------------
+-- | How should katip store your log data?
+--
+-- * NoIndexSharding will store all logs in one index name. This is
+-- the simplest option but is not advised in production. In practice,
+-- the index will grow very large and will get slower to
+-- search. Deleting records based on some sort of retention period is
+-- also extremely slow.
+--
+-- * MonthlyIndexSharding, DailyIndexSharding, HourlyIndexSharding,
+-- EveryMinuteIndexSharding will generate indexes based on the time of
+-- the log. Index name is treated as a prefix. So if your index name
+-- is @foo@ and DailySharding is used, logs will be stored in
+-- @foo-2016-2-25@, @foo-2016-2-26@ and so on. Index templating will
+-- be used to set up mappings automatically. Deletes based on date are
+-- very fast and queries can be restricted to date ranges for better
+-- performance. Queries against all dates should use @foo-*@ as an
+-- index name. Note that index aliasing's glob feature is not suitable
+-- for these date ranges as it matches index names as they are
+-- declared, so new dates will be excluded. DailyIndexSharding is a
+-- reasonable choice. Changing index sharding strategies is not
+-- advisable.
+--
+-- * CustomSharding: supply your own function that decomposes an item
+-- into its index name hierarchy which will be appended to the index
+-- name. So for instance if your function return ["arbitrary",
+-- "prefix"], the index will be @foo-arbitrary-prefix@ and the index
+-- template will be set to match @foo-*@. In general, you want to use
+-- segments of increasing granularity (like year, month, day for
+-- dates). This makes it easier to address groups of indexes
+-- (e.g. @foo-2016-*@).
+data IndexShardingPolicy = NoIndexSharding
+ | MonthlyIndexSharding
+ | WeeklyIndexSharding
+ -- ^ A special case of daily which shards to sunday
+ | DailyIndexSharding
+ | HourlyIndexSharding
+ | EveryMinuteIndexSharding
+ | CustomIndexSharding (forall a. Item a ->
[IndexNameSegment])
+
+
+instance Show IndexShardingPolicy where
+ show NoIndexSharding = "NoIndexSharding"
+ show MonthlyIndexSharding = "MonthlyIndexSharding"
+ show WeeklyIndexSharding = "WeeklyIndexSharding"
+ show DailyIndexSharding = "DailyIndexSharding"
+ show HourlyIndexSharding = "HourlyIndexSharding"
+ show EveryMinuteIndexSharding = "EveryMinuteIndexSharding"
+ show (CustomIndexSharding _) = "CustomIndexSharding λ"
+
+
+-------------------------------------------------------------------------------
+newtype IndexNameSegment = IndexNameSegment {
+ indexNameSegment :: Text
+ } deriving (Show, Eq, Ord)
+
+
+-------------------------------------------------------------------------------
+shardPolicySegs :: IndexShardingPolicy -> Item a -> [IndexNameSegment]
+shardPolicySegs NoIndexSharding _ = []
+shardPolicySegs MonthlyIndexSharding Item {..} = [sis y, sis m]
+ where
+ (y, m, _) = toGregorian (utctDay _itemTime)
+shardPolicySegs WeeklyIndexSharding Item {..} = [sis y, sis m, sis d]
+ where
+ (y, m, d) = toGregorian (roundToSunday (utctDay _itemTime))
+shardPolicySegs DailyIndexSharding Item {..} = [sis y, sis m, sis d]
+ where
+ (y, m, d) = toGregorian (utctDay _itemTime)
+shardPolicySegs HourlyIndexSharding Item {..} = [sis y, sis m, sis d, sis h]
+ where
+ (y, m, d) = toGregorian (utctDay _itemTime)
+ (h, _) = splitTime (utctDayTime _itemTime)
+shardPolicySegs EveryMinuteIndexSharding Item {..} = [sis y, sis m, sis d, sis
h, sis mn]
+ where
+ (y, m, d) = toGregorian (utctDay _itemTime)
+ (h, mn) = splitTime (utctDayTime _itemTime)
+shardPolicySegs (CustomIndexSharding f) i = f i
+
+
+-------------------------------------------------------------------------------
+-- | If the given day is sunday, returns the input, otherwise returns
+-- the previous sunday
+roundToSunday :: Day -> Day
+roundToSunday d
+ | dow == 7 = d
+ | w > 1 = fromWeekDate y (w - 1) 7
+ | otherwise = fromWeekDate (y - 1) 53 7
+ where
+ (y, w, dow) = toWeekDate d
+
+
+-------------------------------------------------------------------------------
+chooseIxn :: ESVersion v => proxy v -> IndexName v -> IndexShardingPolicy ->
Item a -> IndexName v
+chooseIxn prx ixn p i =
+ toIndexName prx (T.intercalate "-" ((fromIndexName prx ixn):segs))
+ where
+ segs = indexNameSegment A.<$> shardPolicySegs p i
+
+
+-------------------------------------------------------------------------------
+sis :: Integral a => a -> IndexNameSegment
+sis = IndexNameSegment . T.pack . fmt
+ where
+ fmt = printf "%02d" . toInteger
+
+
+-------------------------------------------------------------------------------
+splitTime :: DiffTime -> (Int, Int)
+splitTime t = asMins `divMod` 60
+ where
+ asMins = floor t `div` 60
+
+
+-------------------------------------------------------------------------------
+data EsScribeSetupError = CouldNotCreateIndex !(Response ByteString)
+ | CouldNotCreateMapping !(Response ByteString)
deriving (Typeable, Show)
+
+
+instance Exception EsScribeSetupError
+
+
+-------------------------------------------------------------------------------
+-- | The Any field tagged with a @v@ corresponds to the type of the
+-- same name in the corresponding @bloodhound@ module. For instance,
+-- if you are configuring for ElasticSearch version 1, import
+-- @Database.V1.Bloodhound@ and @BHEnv v@ will refer to @BHEnv@ from
+-- that module, @IndexName v@ will repsond to @IndexName@ from that
+-- module, etc.
+mkEsScribe
+ :: forall v. ( ESVersion v
+ , MonadIO (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ )
+ => EsScribeCfg v
+ -> BHEnv v
+ -> IndexName v
+ -- ^ Treated as a prefix if index sharding is enabled
+ -> MappingName v
+ -> Severity
+ -> Verbosity
+ -> IO Scribe
+mkEsScribe cfg@EsScribeCfg {..} env ix mapping sev verb = do
+ q <- newTBMQueueIO $ unEsQueueSize essQueueSize
+ endSig <- newEmptyMVar
+
+ runBH prx env $ do
+ chk <- indexExists prx ix
+ -- note that this doesn't update settings. That's not available
+ -- through the Bloodhound API yet
+ unless chk $ void $ do
+ r1 <- createIndex prx essIndexSettings ix
+ unless (statusIsSuccessful (responseStatus r1)) $
+ liftIO $ throwIO (CouldNotCreateIndex r1)
+ r2 <- if shardingEnabled
+ then putTemplate prx tpl tplName
+ else putMapping prx ix mapping base
+ unless (statusIsSuccessful (responseStatus r2)) $
+ liftIO $ throwIO (CouldNotCreateMapping r2)
+
+ workers <- replicateM (unEsPoolSize essPoolSize) $ async $
+ startWorker cfg env mapping q
+
+ _ <- async $ do
+ takeMVar endSig
+ atomically $ closeTBMQueue q
+ mapM_ waitCatch workers
+ putMVar endSig ()
+
+ let finalizer = putMVar endSig () >> takeMVar endSig
+ return (Scribe (logger q) finalizer)
+ where
+ logger :: forall a. LogItem a => TBMQueue (IndexName v, Value) -> Item a
-> IO ()
+ logger q i = when (_itemSeverity i >= sev) $
+ void $ atomically $ tryWriteTBMQueue q (chooseIxn prx ix
essIndexSharding i, itemJson' i)
+ prx :: Typeable.Proxy v
+ prx = Typeable.Proxy
+ tplName = toTemplateName prx ixn
+ shardingEnabled = case essIndexSharding of
+ NoIndexSharding -> False
+ _ -> True
+ tpl = toIndexTemplate prx (toTemplatePattern prx (ixn <> "-*")) (Just
essIndexSettings) [toJSON base]
+ base = baseMapping prx mapping
+ ixn = fromIndexName prx ix
+ itemJson' :: LogItem a => Item a -> Value
+ itemJson' i
+ | essAnnotateTypes = itemJson verb (TypeAnnotated <$> i)
+ | otherwise = itemJson verb i
+
+
+-------------------------------------------------------------------------------
+baseMapping :: ESVersion v => proxy v -> MappingName v -> Value
+baseMapping prx mn =
+ object [ fromMappingName prx mn .= object ["properties" .= object prs] ]
+ where prs = [ str "thread"
+ , str "sev"
+ , str "pid"
+ , str "ns"
+ , str "msg"
+ , "loc" .= locType
+ , str "host"
+ , str "env"
+ , "at" .= dateType
+ , str "app"
+ ]
+ str k = k .= object ["type" .= String "string"]
+ locType = object ["properties" .= object locPairs]
+ locPairs = [ str "loc_pkg"
+ , str "loc_mod"
+ , str "loc_ln"
+ , str "loc_fn"
+ , str "loc_col"
+ ]
+ dateType = object [ "format" .= esDateFormat
+ , "type" .= String "date"
+ ]
+
+
+-------------------------------------------------------------------------------
+-- | Handle both old-style aeson and picosecond-level precision
+esDateFormat :: Text
+esDateFormat =
"yyyy-MM-dd'T'HH:mm:ssZ||yyyy-MM-dd'T'HH:mm:ss.SSSZ||yyyy-MM-dd'T'HH:mm:ss.SSSSSSSSSSSSZ"
+
+
+-------------------------------------------------------------------------------
+mkDocId :: ESVersion v => proxy v -> IO (DocId v)
+mkDocId prx = (toDocId prx . T.decodeUtf8 . toASCIIBytes) `fmap`
UUID4.nextRandom
+
+
+-------------------------------------------------------------------------------
+newtype EsQueueSize = EsQueueSize {
+ unEsQueueSize :: Int
+ } deriving (Show, Eq, Ord)
+
+
+instance Bounded EsQueueSize where
+ minBound = EsQueueSize 1
+ maxBound = EsQueueSize maxBound
+
+
+mkEsQueueSize :: Int -> Maybe EsQueueSize
+mkEsQueueSize = mkNonZero EsQueueSize
+
+
+-------------------------------------------------------------------------------
+newtype EsPoolSize = EsPoolSize {
+ unEsPoolSize :: Int
+ } deriving (Show, Eq, Ord)
+
+
+instance Bounded EsPoolSize where
+ minBound = EsPoolSize 1
+ maxBound = EsPoolSize maxBound
+
+
+mkEsPoolSize :: Int -> Maybe EsPoolSize
+mkEsPoolSize = mkNonZero EsPoolSize
+
+
+-------------------------------------------------------------------------------
+mkNonZero :: (Int -> a) -> Int -> Maybe a
+mkNonZero ctor n
+ | n > 0 = Just $ ctor n
+ | otherwise = Nothing
+
+
+-------------------------------------------------------------------------------
+startWorker
+ :: forall v. (ESVersion v)
+ => EsScribeCfg v
+ -> BHEnv v
+ -> MappingName v
+ -> TBMQueue (IndexName v, Value)
+ -> IO ()
+startWorker EsScribeCfg {..} env mapping q = go
+ where
+ go = do
+ popped <- atomically $ readTBMQueue q
+ case popped of
+ Just (ixn, v) -> do
+ sendLog ixn v `catchAny` eat
+ go
+ Nothing -> return ()
+ prx :: Typeable.Proxy v
+ prx = Typeable.Proxy
+ sendLog :: IndexName v -> Value -> IO ()
+ sendLog ixn v = void $ recovering essRetryPolicy [handler] $ const $ do
+ did <- mkDocId prx
+ res <- runBH prx env $ indexDocument prx ixn mapping
(defaultIndexDocumentSettings prx) v did
+ return res
+ eat _ = return ()
+ handler _ = Handler $ \e ->
+ case fromException e of
+ Just (_ :: AsyncException) -> return False
+ _ -> return True
+
+
+-------------------------------------------------------------------------------
+-- We are spanning multiple versions of ES which use completely
+-- separate types and APIs, but the subset we use is the same for both
+-- versions. This will be kept up to date with bloodhound's supported
+-- versions and should be minimally visible to the end user.
+class ESVersion v where
+ -- Types
+ type BHEnv v
+ type IndexSettings v
+ defaultIndexSettings :: proxy v -> IndexSettings v
+ type IndexName v
+ toIndexName :: proxy v -> Text -> IndexName v
+ fromIndexName :: proxy v -> IndexName v -> Text
+ type MappingName v
+ fromMappingName :: proxy v -> MappingName v -> Text
+ type DocId v
+ toDocId :: proxy v -> Text -> DocId v
+ type BH v :: (* -> *) -> * -> *
+ runBH :: proxy v -> BHEnv v -> BH v m a -> m a
+ type TemplateName v
+ toTemplateName :: proxy v -> Text -> TemplateName v
+ type TemplatePattern v
+ toTemplatePattern :: proxy v -> Text -> TemplatePattern v
+ type IndexTemplate v
+ toIndexTemplate :: proxy v -> TemplatePattern v -> Maybe (IndexSettings v)
-> [Value] -> IndexTemplate v
+ type IndexDocumentSettings v
+ defaultIndexDocumentSettings :: proxy v -> IndexDocumentSettings v
+
+ -- Operations
+ -- We're deciding on IO here, but it isn't necessary
+ indexExists :: proxy v -> IndexName v -> BH v IO Bool
+ indexDocument :: ToJSON doc => proxy v -> IndexName v -> MappingName v ->
IndexDocumentSettings v -> doc -> DocId v -> BH v IO (Response ByteString)
+ createIndex :: proxy v -> IndexSettings v -> IndexName v -> BH v IO
(Response ByteString)
+ putTemplate :: proxy v -> IndexTemplate v -> TemplateName v -> BH v IO
(Response ByteString)
+ putMapping :: (ToJSON a) => proxy v -> IndexName v -> MappingName v -> a ->
BH v IO (Response ByteString)
+
+
+data ESV1 = ESV1
+
+instance ESVersion ESV1 where
+ type BHEnv ESV1 = V1.BHEnv
+ type IndexSettings ESV1 = V1.IndexSettings
+ defaultIndexSettings _ = V1.defaultIndexSettings
+ type IndexName ESV1 = V1.IndexName
+ toIndexName _ = V1.IndexName
+ fromIndexName _ (V1.IndexName x) = x
+ type MappingName ESV1 = V1.MappingName
+ fromMappingName _ (V1.MappingName x) = x
+ type DocId ESV1 = V1.DocId
+ toDocId _ = V1.DocId
+ type BH ESV1 = V1.BH
+ runBH _ = V1.runBH
+ type TemplateName ESV1 = V1.TemplateName
+ toTemplateName _ = V1.TemplateName
+ type TemplatePattern ESV1 = V1.TemplatePattern
+ toTemplatePattern _ = V1.TemplatePattern
+ type IndexTemplate ESV1 = V1.IndexTemplate
+ toIndexTemplate _ = V1.IndexTemplate
+ type IndexDocumentSettings ESV1 = V1.IndexDocumentSettings
+ defaultIndexDocumentSettings _ = V1.defaultIndexDocumentSettings
+ indexExists _ = V1.indexExists
+ indexDocument _ = V1.indexDocument
+ createIndex _ = V1.createIndex
+ putTemplate _ = V1.putTemplate
+ putMapping _ = V1.putMapping
+
+
+data ESV5 = ESV5
+
+instance ESVersion ESV5 where
+ type BHEnv ESV5 = V5.BHEnv
+ type IndexSettings ESV5 = V5.IndexSettings
+ defaultIndexSettings _ = V5.defaultIndexSettings
+ type IndexName ESV5 = V5.IndexName
+ toIndexName _ = V5.IndexName
+ fromIndexName _ (V5.IndexName x) = x
+ type MappingName ESV5 = V5.MappingName
+ fromMappingName _ (V5.MappingName x) = x
+ type DocId ESV5 = V5.DocId
+ toDocId _ = V5.DocId
+ type BH ESV5 = V5.BH
+ runBH _ = V5.runBH
+ type TemplateName ESV5 = V5.TemplateName
+ toTemplateName _ = V5.TemplateName
+ type TemplatePattern ESV5 = V5.TemplatePattern
+ toTemplatePattern _ = V5.TemplatePattern
+ type IndexTemplate ESV5 = V5.IndexTemplate
+ toIndexTemplate _ = V5.IndexTemplate
+ type IndexDocumentSettings ESV5 = V5.IndexDocumentSettings
+ defaultIndexDocumentSettings _ = V5.defaultIndexDocumentSettings
+ indexExists _ = V5.indexExists
+ indexDocument _ = V5.indexDocument
+ createIndex _ = V5.createIndex
+ putTemplate _ = V5.putTemplate
+ putMapping _ = V5.putMapping
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/katip-elasticsearch-0.3.1.0/src/Katip/Scribes/ElasticSearch.hs
new/katip-elasticsearch-0.4.0.0/src/Katip/Scribes/ElasticSearch.hs
--- old/katip-elasticsearch-0.3.1.0/src/Katip/Scribes/ElasticSearch.hs
2017-06-27 00:42:06.000000000 +0200
+++ new/katip-elasticsearch-0.4.0.0/src/Katip/Scribes/ElasticSearch.hs
2017-07-24 22:50:35.000000000 +0200
@@ -1,14 +1,41 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-- | Includes a scribe that can be used to log structured, JSON log
-- messages to ElasticSearch. These logs can be explored easily using
-- <https://www.elastic.co/products/kibana kibana> or your tool of
--- choice.
+-- choice. Supports ElasticSearch servers with version 1.x or 5.x by
+-- way of different configs.
--
--- == __Important Note on Index Settings__
+-- Example of configuring for ES5:
+--
+-- @
+--
+-- import Control.Exception
+-- import Database.V5.Bloodhound
+-- import Network.HTTP.Client
+-- import Katip
+-- import Katip.Scribes.ElasticSearch
+--
+--
+-- main :: IO ()
+-- main = do
+-- mgr <- newManager defaultManagerSettings
+-- let bhe = mkBHEnv (Server "localhost") mgr
+-- esScribe <- mkEsScribe
+-- -- Reasonable for production
+-- defaultEsScribeCfgV5
+-- -- Reasonable for single-node in development
+-- -- defaultEsScribeCfgV5 { essIndexSettings = IndexSettings (ShardCound
1) (ReplicaCount 0)}
+-- bhe
+-- (IndexName "all-indices-prefixed-with")
+-- (MappingName "application-logs")
+-- DebugS
+-- V3
+-- let mkLogEnv = registerScribe "es" esScribe defaultScribeSettings =<<
initLogEnv "MyApp" "production"
+-- bracket mkLogEnv closeScribes $ \le -> runKatipT le $ do
+-- logMsg "ns" InfoS "This goes to elasticsearch"
+--
+-- @
+--
+-- __Important Note on Index Settings__
--
-- 'defaultEsScribeCfg' inherits a set of default index settings from
-- the @bloodhound@ package. These settings at this time of writing
@@ -30,6 +57,9 @@
, mkEsQueueSize
, EsPoolSize
, mkEsPoolSize
+ , IndexShardingPolicy(..)
+ , IndexNameSegment(..)
+ -- ** EsScribeCfg and fields
, EsScribeCfg
, essRetryPolicy
, essQueueSize
@@ -37,375 +67,29 @@
, essAnnotateTypes
, essIndexSettings
, essIndexSharding
- , IndexShardingPolicy(..)
- , IndexNameSegment(..)
, defaultEsScribeCfg
+ , defaultEsScribeCfgV1
+ , defaultEsScribeCfgV5
+ -- ** Version-Proxied APIS
+ -- $versionproxies
+ , defaultEsScribeCfg'
+ , ESV1
+ , ESV5
-- * Utilities
, mkDocId
, module Katip.Scribes.ElasticSearch.Annotations
- , roundToSunday
) where
-------------------------------------------------------------------------------
-import Control.Applicative as A
-import Control.Concurrent
-import Control.Concurrent.Async
-import Control.Concurrent.STM.TBMQueue
-import Control.Exception.Base
-import Control.Exception.Enclosed
-import Control.Monad
-import Control.Monad.Catch
-import Control.Monad.IO.Class
-import Control.Monad.STM
-import Control.Retry (RetryPolicy,
- exponentialBackoff,
- limitRetries,
- recovering)
-import Data.Aeson
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Data.Time
-import Data.Time.Calendar.WeekDate
-import Data.Typeable
-import Data.UUID
-import qualified Data.UUID.V4 as UUID4
-import Database.Bloodhound
-import Network.HTTP.Client
-import Network.HTTP.Types.Status
-import Text.Printf (printf)
--------------------------------------------------------------------------------
-import Katip.Core
import Katip.Scribes.ElasticSearch.Annotations
+import Katip.Scribes.ElasticSearch.Internal
-------------------------------------------------------------------------------
-data EsScribeCfg = EsScribeCfg {
- essRetryPolicy :: RetryPolicy
- -- ^ Retry policy when there are errors sending logs to the server
- , essQueueSize :: EsQueueSize
- -- ^ Maximum size of the bounded log queue
- , essPoolSize :: EsPoolSize
- -- ^ Worker pool size limit for sending data to the
- , essAnnotateTypes :: Bool
- -- ^ Different payload items coexist in the "data" attribute in
- -- ES. It is possible for different payloads to have different
- -- types for the same key, e.g. an "id" key that is sometimes a
- -- number and sometimes a string. If you're having ES do dynamic
- -- mapping, the first log item will set the type and any that
- -- don't conform will be *discarded*. If you set this to True,
- -- keys will recursively be appended with their ES core
- -- type. e.g. "id" would become "id::l" and "id::s"
- -- automatically, so they won't conflict. When this library
- -- exposes a querying API, we will try to make deserialization and
- -- querying transparently remove the type annotations if this is
- -- enabled.
- , essIndexSettings :: IndexSettings
- , essIndexSharding :: IndexShardingPolicy
- } deriving (Typeable)
-
-
--- | Reasonable defaults for a config:
---
--- * defaultManagerSettings
---
--- * exponential backoff with 25ms base delay up to 5 retries
---
--- * Queue size of 1000
---
--- * Pool size of 2
---
--- * Annotate types set to False
---
--- * DailyIndexSharding
-defaultEsScribeCfg :: EsScribeCfg
-defaultEsScribeCfg = EsScribeCfg {
- essRetryPolicy = exponentialBackoff 25 <> limitRetries 5
- , essQueueSize = EsQueueSize 1000
- , essPoolSize = EsPoolSize 2
- , essAnnotateTypes = False
- , essIndexSettings = defaultIndexSettings
- , essIndexSharding = DailyIndexSharding
- }
-
-
--------------------------------------------------------------------------------
--- | How should katip store your log data?
---
--- * NoIndexSharding will store all logs in one index name. This is
--- the simplest option but is not advised in production. In practice,
--- the index will grow very large and will get slower to
--- search. Deleting records based on some sort of retention period is
--- also extremely slow.
---
--- * MonthlyIndexSharding, DailyIndexSharding, HourlyIndexSharding,
--- EveryMinuteIndexSharding will generate indexes based on the time of
--- the log. Index name is treated as a prefix. So if your index name
--- is @foo@ and DailySharding is used, logs will be stored in
--- @foo-2016-2-25@, @foo-2016-2-26@ and so on. Index templating will
--- be used to set up mappings automatically. Deletes based on date are
--- very fast and queries can be restricted to date ranges for better
--- performance. Queries against all dates should use @foo-*@ as an
--- index name. Note that index aliasing's glob feature is not suitable
--- for these date ranges as it matches index names as they are
--- declared, so new dates will be excluded. DailyIndexSharding is a
--- reasonable choice. Changing index sharding strategies is not
--- advisable.
---
--- * CustomSharding: supply your own function that decomposes an item
--- into its index name hierarchy which will be appended to the index
--- name. So for instance if your function return ["arbitrary",
--- "prefix"], the index will be @foo-arbitrary-prefix@ and the index
--- template will be set to match @foo-*@. In general, you want to use
--- segments of increasing granularity (like year, month, day for
--- dates). This makes it easier to address groups of indexes
--- (e.g. @foo-2016-*@).
-data IndexShardingPolicy = NoIndexSharding
- | MonthlyIndexSharding
- | WeeklyIndexSharding
- -- ^ A special case of daily which shards to sunday
- | DailyIndexSharding
- | HourlyIndexSharding
- | EveryMinuteIndexSharding
- | CustomIndexSharding (forall a. Item a ->
[IndexNameSegment])
-
-
-instance Show IndexShardingPolicy where
- show NoIndexSharding = "NoIndexSharding"
- show MonthlyIndexSharding = "MonthlyIndexSharding"
- show WeeklyIndexSharding = "WeeklyIndexSharding"
- show DailyIndexSharding = "DailyIndexSharding"
- show HourlyIndexSharding = "HourlyIndexSharding"
- show EveryMinuteIndexSharding = "EveryMinuteIndexSharding"
- show (CustomIndexSharding _) = "CustomIndexSharding λ"
-
-
--------------------------------------------------------------------------------
-newtype IndexNameSegment = IndexNameSegment {
- indexNameSegment :: Text
- } deriving (Show, Eq, Ord)
-
-
--------------------------------------------------------------------------------
-shardPolicySegs :: IndexShardingPolicy -> Item a -> [IndexNameSegment]
-shardPolicySegs NoIndexSharding _ = []
-shardPolicySegs MonthlyIndexSharding Item {..} = [sis y, sis m]
- where
- (y, m, _) = toGregorian (utctDay _itemTime)
-shardPolicySegs WeeklyIndexSharding Item {..} = [sis y, sis m, sis d]
- where
- (y, m, d) = toGregorian (roundToSunday (utctDay _itemTime))
-shardPolicySegs DailyIndexSharding Item {..} = [sis y, sis m, sis d]
- where
- (y, m, d) = toGregorian (utctDay _itemTime)
-shardPolicySegs HourlyIndexSharding Item {..} = [sis y, sis m, sis d, sis h]
- where
- (y, m, d) = toGregorian (utctDay _itemTime)
- (h, _) = splitTime (utctDayTime _itemTime)
-shardPolicySegs EveryMinuteIndexSharding Item {..} = [sis y, sis m, sis d, sis
h, sis mn]
- where
- (y, m, d) = toGregorian (utctDay _itemTime)
- (h, mn) = splitTime (utctDayTime _itemTime)
-shardPolicySegs (CustomIndexSharding f) i = f i
-
-
--------------------------------------------------------------------------------
--- | If the given day is sunday, returns the input, otherwise returns
--- the previous sunday
-roundToSunday :: Day -> Day
-roundToSunday d
- | dow == 7 = d
- | w > 1 = fromWeekDate y (w - 1) 7
- | otherwise = fromWeekDate (y - 1) 53 7
- where
- (y, w, dow) = toWeekDate d
-
-
--------------------------------------------------------------------------------
-chooseIxn :: IndexName -> IndexShardingPolicy -> Item a -> IndexName
-chooseIxn (IndexName ixn) p i =
- IndexName (T.intercalate "-" (ixn:segs))
- where
- segs = indexNameSegment A.<$> shardPolicySegs p i
-
-
--------------------------------------------------------------------------------
-sis :: Integral a => a -> IndexNameSegment
-sis = IndexNameSegment . T.pack . fmt
- where
- fmt = printf "%02d" . toInteger
-
-
--------------------------------------------------------------------------------
-splitTime :: DiffTime -> (Int, Int)
-splitTime t = asMins `divMod` 60
- where
- asMins = floor t `div` 60
-
-
--------------------------------------------------------------------------------
-data EsScribeSetupError = CouldNotCreateIndex !Reply
- | CouldNotCreateMapping !Reply deriving (Typeable,
Show)
-
-
-instance Exception EsScribeSetupError
-
--------------------------------------------------------------------------------
-mkEsScribe
- :: EsScribeCfg
- -> BHEnv
- -> IndexName
- -- ^ Treated as a prefix if index sharding is enabled
- -> MappingName
- -> Severity
- -> Verbosity
- -> IO (Scribe, IO ())
- -- ^ Returns a finalizer that will gracefully flush all remaining logs
before shutting down workers
-mkEsScribe cfg@EsScribeCfg {..} env ix mapping sev verb = do
- q <- newTBMQueueIO $ unEsQueueSize essQueueSize
- endSig <- newEmptyMVar
-
- runBH env $ do
- chk <- indexExists ix
- -- note that this doesn't update settings. That's not available
- -- through the Bloodhound API yet
- unless chk $ void $ do
- r1 <- createIndex essIndexSettings ix
- unless (statusIsSuccessful (responseStatus r1)) $
- liftIO $ throwIO (CouldNotCreateIndex r1)
- r2 <- if shardingEnabled
- then putTemplate tpl tplName
- else putMapping ix mapping (baseMapping mapping)
- unless (statusIsSuccessful (responseStatus r2)) $
- liftIO $ throwIO (CouldNotCreateMapping r2)
-
- workers <- replicateM (unEsPoolSize essPoolSize) $ async $
- startWorker cfg env mapping q
+{- $versionproxies
- _ <- async $ do
- takeMVar endSig
- atomically $ closeTBMQueue q
- mapM_ waitCatch workers
- putMVar endSig ()
-
- let scribe = Scribe $ \ i ->
- when (_itemSeverity i >= sev) $
- void $ atomically $ tryWriteTBMQueue q (chooseIxn ix
essIndexSharding i, itemJson' i)
- let finalizer = putMVar endSig () >> takeMVar endSig
- return (scribe, finalizer)
- where
- tplName = TemplateName ixn
- shardingEnabled = case essIndexSharding of
- NoIndexSharding -> False
- _ -> True
- tpl = IndexTemplate (TemplatePattern (ixn <> "-*")) (Just
essIndexSettings) [toJSON (baseMapping mapping)]
- IndexName ixn = ix
- itemJson' i
- | essAnnotateTypes = itemJson verb (TypeAnnotated <$> i)
- | otherwise = itemJson verb i
-
-
--------------------------------------------------------------------------------
-baseMapping :: MappingName -> Value
-baseMapping (MappingName mn) =
- object [ mn .= object ["properties" .= object prs] ]
- where prs = [ str "thread"
- , str "sev"
- , str "pid"
- , str "ns"
- , str "msg"
- , "loc" .= locType
- , str "host"
- , str "env"
- , "at" .= dateType
- , str "app"
- ]
- str k = k .= object ["type" .= String "string"]
- locType = object ["properties" .= object locPairs]
- locPairs = [ str "loc_pkg"
- , str "loc_mod"
- , str "loc_ln"
- , str "loc_fn"
- , str "loc_col"
- ]
- dateType = object [ "format" .= esDateFormat
- , "type" .= String "date"
- ]
-
-
--------------------------------------------------------------------------------
--- | Handle both old-style aeson and picosecond-level precision
-esDateFormat :: Text
-esDateFormat =
"yyyy-MM-dd'T'HH:mm:ssZ||yyyy-MM-dd'T'HH:mm:ss.SSSZ||yyyy-MM-dd'T'HH:mm:ss.SSSSSSSSSSSSZ"
-
-
--------------------------------------------------------------------------------
-mkDocId :: IO DocId
-mkDocId = (DocId . T.decodeUtf8 . toASCIIBytes) `fmap` UUID4.nextRandom
-
-
--------------------------------------------------------------------------------
-newtype EsQueueSize = EsQueueSize {
- unEsQueueSize :: Int
- } deriving (Show, Eq, Ord)
-
-
-instance Bounded EsQueueSize where
- minBound = EsQueueSize 1
- maxBound = EsQueueSize maxBound
-
-
-mkEsQueueSize :: Int -> Maybe EsQueueSize
-mkEsQueueSize = mkNonZero EsQueueSize
-
-
--------------------------------------------------------------------------------
-newtype EsPoolSize = EsPoolSize {
- unEsPoolSize :: Int
- } deriving (Show, Eq, Ord)
-
-
-instance Bounded EsPoolSize where
- minBound = EsPoolSize 1
- maxBound = EsPoolSize maxBound
-
-
-mkEsPoolSize :: Int -> Maybe EsPoolSize
-mkEsPoolSize = mkNonZero EsPoolSize
-
-
--------------------------------------------------------------------------------
-mkNonZero :: (Int -> a) -> Int -> Maybe a
-mkNonZero ctor n
- | n > 0 = Just $ ctor n
- | otherwise = Nothing
-
-
--------------------------------------------------------------------------------
-startWorker
- :: EsScribeCfg
- -> BHEnv
- -> MappingName
- -> TBMQueue (IndexName, Value)
- -> IO ()
-startWorker EsScribeCfg {..} env mapping q = go
- where
- go = do
- popped <- atomically $ readTBMQueue q
- case popped of
- Just (ixn, v) -> do
- sendLog ixn v `catchAny` eat
- go
- Nothing -> return ()
- sendLog :: IndexName -> Value -> IO ()
- sendLog ixn v = void $ recovering essRetryPolicy [handler] $ const $ do
- did <- mkDocId
- res <- runBH env $ indexDocument ixn mapping
defaultIndexDocumentSettings v did
- return res
- eat _ = return ()
- handler _ = Handler $ \e ->
- case fromException e of
- Just (_ :: AsyncException) -> return False
- _ -> return True
+ You may need these these functions and types if type inference
+ fails. For instance, you may need to hint to the compiler that a
+ config is @:: EsScribeCfg ESV5@, for instance.
+-}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/katip-elasticsearch-0.3.1.0/test/Main.hs
new/katip-elasticsearch-0.4.0.0/test/Main.hs
--- old/katip-elasticsearch-0.3.1.0/test/Main.hs 2017-06-27
00:42:06.000000000 +0200
+++ new/katip-elasticsearch-0.4.0.0/test/Main.hs 2017-07-24
22:50:35.000000000 +0200
@@ -1,7 +1,13 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main
( main
@@ -9,117 +15,258 @@
-------------------------------------------------------------------------------
-import Control.Applicative as A
+import Control.Applicative as A
import Control.Concurrent.STM
-import Control.Lens hiding (mapping, (.=))
+import Control.Lens hiding (mapping, (.=))
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import Data.Aeson.Lens
import Data.Aeson.Types
-import qualified Data.HashMap.Strict as HM
-import qualified Data.Map as M
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.HashMap.Strict as HM
import Data.Monoid
import Data.Scientific
+import Data.Tagged
+import Data.Text (Text)
import Data.Time
import Data.Time.Calendar.WeekDate
-import qualified Data.Vector as V
-import Database.Bloodhound hiding (key)
+import Data.Typeable as Typeable
+import qualified Data.Vector as V
+import qualified Database.V1.Bloodhound as V1
+import qualified Database.V5.Bloodhound as V5
import Network.HTTP.Client
import Network.HTTP.Types.Status
-import Test.QuickCheck.Instances ()
+import Test.QuickCheck.Instances ()
import Test.Tasty
import Test.Tasty.HUnit
+import Test.Tasty.Options
import Test.Tasty.QuickCheck
-------------------------------------------------------------------------------
import Katip
-import Katip.Scribes.ElasticSearch
+import Katip.Scribes.ElasticSearch.Annotations
+import Katip.Scribes.ElasticSearch.Internal
-------------------------------------------------------------------------------
main :: IO ()
-main = defaultMain $ testGroup "katip-elasticsearch"
+main = defaultMainWithIngredients ings $ askOption $ \vers -> testGroup
"katip-elasticsearch"
[
- esTests
+ case vers of
+ TestV1 -> esTests (Typeable.Proxy :: Typeable.Proxy ESV1)
+ TestV5 -> esTests (Typeable.Proxy :: Typeable.Proxy ESV5)
, typeAnnotatedTests
, roundToSundayTests
]
+ where
+ ings = (includingOptions [Option (Typeable.Proxy :: Typeable.Proxy
TestWithESVersion)]):defaultIngredients
-------------------------------------------------------------------------------
-setupSearch :: (EsScribeCfg -> EsScribeCfg) -> IO (Scribe, IO ())
-setupSearch modScribeCfg = do
- bh dropESSchema
+data TestWithESVersion = TestV1
+ | TestV5
+ deriving (Typeable)
+
+
+instance IsOption TestWithESVersion where
+ defaultValue = TestV1
+ parseValue "1" = Just TestV1
+ parseValue "5" = Just TestV5
+ parseValue _ = Nothing
+ optionName = Tagged "es-version"
+ optionHelp = Tagged "Version of ES to test against, either 1 or 5,
defaulting to 1."
+
+
+class ESVersion v => TestESVersion v where
+ type Server v
+ toServer :: proxy v -> Text -> Server v
+ toMappingName :: proxy v -> Text -> MappingName v
+ type Search v
+ type Query v
+ type Filter v
+ mkSearch :: proxy v -> Maybe (Query v) -> Maybe (Filter v) -> Search v
+ mkBHEnv :: proxy v -> Server v -> Manager -> BHEnv v
+ type ShardCount v
+ toShardCount :: proxy v -> Int -> ShardCount v
+ type ReplicaCount v
+ toReplicaCount :: proxy v -> Int -> ReplicaCount v
+ indexShards :: proxy v -> Lens' (IndexSettings v) (ShardCount v)
+ indexReplicas :: proxy v -> Lens' (IndexSettings v) (ReplicaCount v)
+
+ deleteIndex :: proxy v -> IndexName v -> BH v IO (Response ByteString)
+ deleteTemplate :: proxy v -> TemplateName v -> BH v IO (Response ByteString)
+ refreshIndex :: proxy v -> IndexName v -> BH v IO (Response ByteString)
+ withBH :: proxy v -> ManagerSettings -> Server v -> BH v IO a -> IO a
+ searchByIndex :: proxy v -> IndexName v -> Search v -> BH v IO (Response
ByteString)
+
+
+instance TestESVersion ESV1 where
+ type Server ESV1 = V1.Server
+ toServer _ = V1.Server
+ toMappingName _ = V1.MappingName
+ type Search ESV1 = V1.Search
+ type Query ESV1 = V1.Query
+ type Filter ESV1 = V1.Filter
+ type ShardCount ESV1 = V1.ShardCount
+ toShardCount _ = V1.ShardCount
+ type ReplicaCount ESV1 = V1.ReplicaCount
+ toReplicaCount _ = V1.ReplicaCount
+ mkSearch _ = V1.mkSearch
+ mkBHEnv _ = V1.mkBHEnv
+ indexShards _ = lens V1.indexShards (\s v -> s { V1.indexShards = v})
+ indexReplicas _ = lens V1.indexReplicas (\r v -> r { V1.indexReplicas = v})
+
+ deleteIndex _ = V1.deleteIndex
+ deleteTemplate _ = V1.deleteTemplate
+ refreshIndex _ = V1.refreshIndex
+ withBH _ = V1.withBH
+ searchByIndex _ = V1.searchByIndex
+
+
+instance TestESVersion ESV5 where
+ type Server ESV5 = V5.Server
+ toServer _ = V5.Server
+ toMappingName _ = V5.MappingName
+ type Search ESV5 = V5.Search
+ type Query ESV5 = V5.Query
+ type Filter ESV5 = V5.Filter
+ type ShardCount ESV5 = V5.ShardCount
+ toShardCount _ = V5.ShardCount
+ type ReplicaCount ESV5 = V5.ReplicaCount
+ toReplicaCount _ = V5.ReplicaCount
+ mkSearch _ = V5.mkSearch
+ mkBHEnv _ = V5.mkBHEnv
+ indexShards _ = lens V5.indexShards (\s v -> s { V5.indexShards = v})
+ indexReplicas _ = lens V5.indexReplicas (\r v -> r { V5.indexReplicas = v})
+
+ deleteIndex _ = V5.deleteIndex
+ deleteTemplate _ = V5.deleteTemplate
+ refreshIndex _ = V5.refreshIndex
+ withBH _ = V5.withBH
+ searchByIndex _ = V5.searchByIndex
+
+
+-------------------------------------------------------------------------------
+setupSearch
+ :: forall proxy v. ( TestESVersion v
+ , MonadIO (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ )
+ => proxy v
+ -> (EsScribeCfg v -> EsScribeCfg v)
+ -> IO Scribe
+setupSearch prx modScribeCfg = do
+ bh prx (dropESSchema prx)
mgr <- newManager defaultManagerSettings
- mkEsScribe cfg (mkBHEnv svr mgr) ixn mn DebugS V3
+ mkEsScribe cfg (mkBHEnv prx (svr prx) mgr) (ixn prx) (mn prx) DebugS V3
where
- cfg = modScribeCfg (defaultEsScribeCfg { essAnnotateTypes = True
- , essIndexSettings = ixs
- })
+ cfg :: EsScribeCfg v
+ cfg = modScribeCfg $
+ (defaultEsScribeCfg' prx)
+ { essAnnotateTypes = True
+ , essIndexSettings = ixs prx
+ }
-------------------------------------------------------------------------------
-teardownSearch :: (Scribe, IO ()) -> IO ()
-teardownSearch (_, finalizer) = do
- finalizer
- bh $ do
- when False $ dropESSchema
- when False $ dropESSTemplate --TODO: drop
+teardownSearch
+ :: ( TestESVersion v
+ , Monad (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ )
+ => proxy v
+ -> IO ()
+teardownSearch prx = do
+ bh prx $ do
+ dropESSchema prx
+ dropESSTemplate prx
-------------------------------------------------------------------------------
-withSearch :: (IO (Scribe, IO ()) -> TestTree) -> TestTree
+withSearch
+ :: ( TestESVersion v
+ , MonadIO (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ )
+ => proxy v
+ -> (IO Scribe -> TestTree)
+ -> TestTree
withSearch = withSearch' id
-------------------------------------------------------------------------------
-withSearch' :: (EsScribeCfg -> EsScribeCfg) -> (IO (Scribe, IO ()) ->
TestTree) -> TestTree
-withSearch' modScribeCfg = withResource (setupSearch modScribeCfg)
teardownSearch
+withSearch'
+ :: ( TestESVersion v
+ , MonadIO (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ )
+ => (EsScribeCfg v -> EsScribeCfg v)
+ -> proxy v
+ -> (IO Scribe -> TestTree)
+ -> TestTree
+withSearch' modScribeCfg prx = withResource (setupSearch prx modScribeCfg)
(const (teardownSearch prx))
-------------------------------------------------------------------------------
-esTests :: TestTree
-esTests = testGroup "elasticsearch scribe"
+esTests
+ :: ( TestESVersion v
+ , MonadIO (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ , Show (IndexName v)
+ )
+ => proxy v
+ -> TestTree
+esTests prx = testGroup "elasticsearch scribe"
[
- withSearch' (\c -> c { essIndexSharding = NoIndexSharding}) $ \setup ->
testCase "it flushes to elasticsearch" $ withTestLogging setup $ \done -> do
+ withSearch' (\c -> c { essIndexSharding = NoIndexSharding}) prx $ \setup
-> testCase "it flushes to elasticsearch" $ withTestLogging prx setup $ \done
-> do
$(logT) (ExampleCtx True) mempty InfoS "A test message"
liftIO $ do
void done
- logs <- getLogs
+ logs <- getLogs prx
length logs @?= 1
let l = head logs
l ^? key "_source" . key "msg" . _String @?= Just "A test message"
l ^? key "_source" . key "data" . key "whatever::b" . _Bool @?= Just
True
- , withSearch $ \setup -> testCase "date-based index sharding" $ do
+ , withSearch prx $ \setup -> testCase "date-based index sharding" $ do
let t1 = mkTime 2016 1 2 3 4 5
fakeClock <- newTVarIO t1
- withTestLogging' (set logEnvTimer (readTVarIO fakeClock)) setup $ \done
-> do
+ withTestLogging' (set logEnvTimer (readTVarIO fakeClock)) prx setup $
\done -> do
$(logT) (ExampleCtx True) mempty InfoS "today"
let t2 = mkTime 2016 1 3 3 4 5
liftIO (atomically (writeTVar fakeClock t2))
$(logT) (ExampleCtx True) mempty InfoS "tomorrow"
liftIO $ do
void done
- todayLogs <- getLogsByIndex (IndexName
"katip-elasticsearch-tests-2016-01-02")
- tomorrowLogs <- getLogsByIndex (IndexName
"katip-elasticsearch-tests-2016-01-03")
+ todayLogs <- getLogsByIndex prx (toIndexName prx
"katip-elasticsearch-tests-2016-01-02")
+ tomorrowLogs <- getLogsByIndex prx (toIndexName prx
"katip-elasticsearch-tests-2016-01-03")
assertBool ("todayLogs has " <> show (length todayLogs) <> " items")
(length todayLogs == 1)
assertBool ("tomorrowLogs has " <> show (length tomorrowLogs) <> "
items") (length tomorrowLogs == 1)
let logToday = head todayLogs
let logTomorrow = head tomorrowLogs
logToday ^? key "_source" . key "msg" . _String @?= Just "today"
logTomorrow ^? key "_source" . key "msg" . _String @?= Just
"tomorrow"
- , withSearch' (\c -> c { essIndexSharding = WeeklyIndexSharding}) $ \setup
-> testCase "weekly index sharding rounds to previous sunday" $ do
+ , withSearch' (\c -> c { essIndexSharding = WeeklyIndexSharding}) prx $
\setup -> testCase "weekly index sharding rounds to previous sunday" $ do
let t1 = mkTime 2016 3 5 0 0 0 -- saturday, march 5th
fakeClock <- newTVarIO t1
- withTestLogging' (set logEnvTimer (readTVarIO fakeClock)) setup $ \done
-> do
+ withTestLogging' (set logEnvTimer (readTVarIO fakeClock)) prx setup $
\done -> do
$(logT) (ExampleCtx True) mempty InfoS "today"
let t2 = mkTime 2016 3 6 0 0 0 -- sunday march 6th
liftIO (atomically (writeTVar fakeClock t2))
$(logT) (ExampleCtx True) mempty InfoS "tomorrow"
liftIO $ do
void done
- todayLogs <- getLogsByIndex (IndexName
"katip-elasticsearch-tests-2016-02-28") -- rounds back to previous sunday
- tomorrowLogs <- getLogsByIndex (IndexName
"katip-elasticsearch-tests-2016-03-06") -- is on sunday, so uses current date
+ todayLogs <- getLogsByIndex prx (toIndexName prx
"katip-elasticsearch-tests-2016-02-28") -- rounds back to previous sunday
+ tomorrowLogs <- getLogsByIndex prx (toIndexName prx
"katip-elasticsearch-tests-2016-03-06") -- is on sunday, so uses current date
assertBool ("todayLogs has " <> show (length todayLogs) <> " items")
(length todayLogs == 1)
assertBool ("tomorrowLogs has " <> show (length tomorrowLogs) <> "
items") (length tomorrowLogs == 1)
let logToday = head todayLogs
@@ -232,76 +379,127 @@
-------------------------------------------------------------------------------
-getLogs :: IO [Value]
-getLogs = getLogsByIndex ixn
+getLogs
+ :: ( TestESVersion v
+ , Monad (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ , Show (IndexName v)
+ )
+ => proxy v
+ -> IO [Value]
+getLogs prx = getLogsByIndex prx (ixn prx)
-------------------------------------------------------------------------------
-getLogsByIndex :: IndexName -> IO [Value]
-getLogsByIndex i = do
- r <- bh $ do
- void (refreshIndex i)
- searchByIndex i (mkSearch Nothing Nothing)
+getLogsByIndex
+ :: ( TestESVersion v
+ , Monad (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ , Show (IndexName v)
+ )
+ => proxy v
+ -> IndexName v
+ -> IO [Value]
+getLogsByIndex prx i = do
+ r <- bh prx $ do
+ void (refreshIndex prx i)
+ searchByIndex prx i (mkSearch prx Nothing Nothing)
let actualCode = statusCode (responseStatus r)
assertBool ("search by " <> show i <> " " <> show actualCode <> " /= 200")
(actualCode == 200)
return $ responseBody r ^.. key "hits" . key "hits" . values
-------------------------------------------------------------------------------
-bh :: BH IO a -> IO a
-bh = withBH defaultManagerSettings svr
+bh :: TestESVersion v => proxy v -> BH v IO a -> IO a
+bh prx = withBH prx defaultManagerSettings (svr prx)
-------------------------------------------------------------------------------
withTestLogging
- :: IO (Scribe, IO a) -> (IO Reply -> KatipT IO b) -> IO b
+ :: TestESVersion v
+ => proxy v
+ -> IO Scribe
+ -> (IO (Response ByteString) -> KatipT IO b)
+ -> IO b
withTestLogging = withTestLogging' id
-------------------------------------------------------------------------------
withTestLogging'
- :: (LogEnv -> LogEnv)
- -> IO (Scribe, IO a)
- -> (IO Reply -> KatipT IO b)
+ :: (TestESVersion v)
+ => (LogEnv -> LogEnv)
+ -> proxy v
+ -> IO Scribe
+ -> (IO (Response ByteString) -> KatipT IO b)
-> IO b
-withTestLogging' modEnv setup f = do
- (scr, done) <- setup
+withTestLogging' modEnv prx setup f = do
+ scr <- setup
le <- modEnv <$> initLogEnv ns env
- let done' = done >> bh (refreshIndex ixn)
- runKatipT le { _logEnvScribes = M.singleton "es" scr} (f done')
+ le' <- registerScribe "es" scr defaultScribeSettings le
+ let done' = do
+ _ <- closeScribes le'
+ bh prx (refreshIndex prx (ixn prx))
+ runKatipT le' (f done')
where
ns = Namespace ["katip-test"]
env = Environment "test"
-------------------------------------------------------------------------------
-svr :: Server
-svr = Server "http://localhost:9200";
+svr :: TestESVersion v => proxy v -> Server v
+svr prx = toServer prx "http://localhost:9200";
+
+
+-------------------------------------------------------------------------------
+ixn :: TestESVersion v => proxy v -> IndexName v
+ixn prx = toIndexName prx "katip-elasticsearch-tests"
-------------------------------------------------------------------------------
-ixn :: IndexName
-ixn = IndexName "katip-elasticsearch-tests"
+ixs :: TestESVersion v => proxy v -> IndexSettings v
+ixs prx = defaultIndexSettings prx
+ & indexShards prx .~ toShardCount prx 1
+ & indexReplicas prx .~ toReplicaCount prx 1
-------------------------------------------------------------------------------
-ixs :: IndexSettings
-ixs = defaultIndexSettings { indexShards = ShardCount 1
- , indexReplicas = ReplicaCount 1}
+tn :: TestESVersion v => proxy v -> TemplateName v
+tn prx = toTemplateName prx "katip-elasticsearch-tests"
+
-------------------------------------------------------------------------------
-mn :: MappingName
-mn = MappingName "logs"
+mn :: TestESVersion v => proxy v -> MappingName v
+mn prx = toMappingName prx "logs"
-------------------------------------------------------------------------------
-dropESSchema :: BH IO ()
-dropESSchema = void $ deleteIndex (IndexName "katip-elasticsearch-tests*")
+dropESSchema
+ :: ( TestESVersion v
+ , Monad (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ )
+ => proxy v
+ -> BH v IO ()
+dropESSchema prx = void $ deleteIndex prx (toIndexName prx
"katip-elasticsearch-tests*")
-------------------------------------------------------------------------------
-dropESSTemplate :: BH IO ()
-dropESSTemplate = void $ deleteTemplate (TemplateName
"katip-elasticsearch-tests")
+dropESSTemplate
+ :: ( TestESVersion v
+ , Monad (BH v IO)
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 800
+ , Functor (BH v IO)
+#endif
+ )
+ => proxy v
+ -> BH v IO ()
+dropESSTemplate prx = void $ deleteTemplate prx (tn prx)
-------------------------------------------------------------------------------
