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 - psimons@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) -------------------------------------------------------------------------------