katip-elasticsearch 0.3.1.0 → 0.4.0.0

raw patch · 7 files changed

+888/−442 lines, 7 filesdep +bytestringdep +taggeddep ~bloodhounddep ~katipPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, tagged

Dependency ranges changed: bloodhound, katip

API changes (from Hackage documentation)

Files

• bench/Main.hs +6/−5
• changelog.md +5/−0
• examples/example.hs +33/−0
• katip-elasticsearch.cabal +8/−3
• src/Katip/Scribes/ElasticSearch.hs +50/−366
• src/Katip/Scribes/ElasticSearch/Internal.hs +520/−0
• test/Main.hs +266/−68

@@ -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   ] 

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

@@ -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"

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

@@ -1,15 +1,42 @@-{-# 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 -- set the indices up to have 3 shards and 2 replicas. This is an@@ -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--  _ <- 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-+{- $versionproxies ---------------------------------------------------------------------------------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.+-}

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

@@ -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 :: IndexName-ixn = IndexName "katip-elasticsearch-tests"+ixn :: TestESVersion v => proxy v -> IndexName v+ixn prx = toIndexName prx "katip-elasticsearch-tests"   --------------------------------------------------------------------------------ixs :: IndexSettings-ixs = defaultIndexSettings { indexShards = ShardCount 1-                           , indexReplicas = ReplicaCount 1}+ixs :: TestESVersion v => proxy v -> IndexSettings v+ixs prx = defaultIndexSettings prx+  & indexShards prx .~ toShardCount prx 1+  & indexReplicas prx .~ toReplicaCount prx 1 + --------------------------------------------------------------------------------mn :: MappingName-mn = MappingName "logs"+tn :: TestESVersion v => proxy v -> TemplateName v+tn prx = toTemplateName prx "katip-elasticsearch-tests"   --------------------------------------------------------------------------------dropESSchema :: BH IO ()-dropESSchema = void $ deleteIndex (IndexName "katip-elasticsearch-tests*")+mn :: TestESVersion v => proxy v -> MappingName v+mn prx = toMappingName prx "logs"   --------------------------------------------------------------------------------dropESSTemplate :: BH IO ()-dropESSTemplate = void $ deleteTemplate (TemplateName "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+  :: ( 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)   -------------------------------------------------------------------------------