on 0809f5a help sign in
.gitignore−1
since splitsnapshots
unifiedsplit
@@ -7,4 +7,3 @@ TAGS
7*.hi
7*.hi
8*.dyn_o
8*.dyn_o
9*.dyn_hi
9*.dyn_hi
10−stack.yaml.lock
.travis.yml+11−8
@@ -9,19 +9,23 @@ addons:
9 apt:
9 apt:
10 packages:
10 packages:
11 - libgmp-dev
11 - libgmp-dev
12+ - oracle-java8-installer
12
13
13# The different configurations we want to test. You could also do things like
14# The different configurations we want to test. You could also do things like
14# change flags or use --stack-yaml to point to a different file.
15# change flags or use --stack-yaml to point to a different file.
15matrix:
16matrix:
16 include:
17 include:
18+ - env: ARGS="--resolver=lts-6" ESVERSION=1.5.2 ESURL=https://download.elastic.co/elasticsearch/elasticsearch ESTESTARGS="--es-version 1"
17− - env: ARGS="--resolver=lts-16" ESVERSION=5.5.0 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m"
19+ - env: ARGS="--resolver=lts-7" ESVERSION=1.5.2 ESURL=https://download.elastic.co/elasticsearch/elasticsearch ESTESTARGS="--es-version 1"
20+ - env: ARGS="--resolver=lts-8" ESVERSION=1.5.2 ESURL=https://download.elastic.co/elasticsearch/elasticsearch ESTESTARGS="--es-version 1"
18− - env: ARGS="--resolver=lts-16" ESVERSION=6.2.2 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m"
21+ - env: ARGS="--resolver=lts-9" ESVERSION=1.5.2 ESURL=https://download.elastic.co/elasticsearch/elasticsearch ESTESTARGS="--es-version 1"
22+ - env: ARGS="--resolver=lts-10" ESVERSION=1.5.2 ESURL=https://download.elastic.co/elasticsearch/elasticsearch ESTESTARGS="--es-version 1"
19− - env: ARGS="--resolver=nightly" ESVERSION=5.5.0 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m"
23+ - env: ARGS="--resolver=nightly" ESVERSION=5.5.0 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m" JAVA_HOME=/usr/lib/jvm/java-8-oracle
20− - env: ARGS="--resolver=nightly" ESVERSION=6.2.2 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m"
24+ - env: ARGS="--resolver=nightly" ESVERSION=6.2.2 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m" JAVA_HOME=/usr/lib/jvm/java-8-oracle
21− # nightlies may fail usually due to lagging dependencies
25+ # nightlies may fail from time to time
22 allow_failures:
26 allow_failures:
23− - env: ARGS="--resolver=nightly" ESVERSION=5.5.0 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m"
27+ - env: ARGS="--resolver=nightly" ESVERSION=5.5.0 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m" JAVA_HOME=/usr/lib/jvm/java-8-oracle
24− - env: ARGS="--resolver=nightly" ESVERSION=6.2.2 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m"
28+ - env: ARGS="--resolver=nightly" ESVERSION=6.2.2 ESURL=https://artifacts.elastic.co/downloads/elasticsearch ESTESTARGS="--es-version 5" ES_JAVA_OPTS="-Xms500m -Xmx750m" JAVA_HOME=/usr/lib/jvm/java-8-oracle
25
29
26before_install:
30before_install:
27# Download and unpack the stack executable
31# Download and unpack the stack executable
@@ -34,7 +38,6 @@ install:
34 - tar xzf elasticsearch-$ESVERSION.tar.gz
38 - tar xzf elasticsearch-$ESVERSION.tar.gz
35 # set up a repo for snapshot testing. Required in ES >= 1.6
39 # set up a repo for snapshot testing. Required in ES >= 1.6
36 - echo "path.repo = [\"/tmp\"]" >> ./elasticsearch-$ESVERSION/elasticsearch.yml
40 - echo "path.repo = [\"/tmp\"]" >> ./elasticsearch-$ESVERSION/elasticsearch.yml
37− - java -version
38 - ./elasticsearch-$ESVERSION/bin/elasticsearch &
41 - ./elasticsearch-$ESVERSION/bin/elasticsearch &
39 # Bloodhound seems to take a while to build and can sometimes stall out the build when travis detects no output.
42 # Bloodhound seems to take a while to build and can sometimes stall out the build when travis detects no output.
40
43
katip-datadog/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2018, Soostone Inc
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Ozgun Ataman nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
katip-datadog/README.mddeleted−6
@@ -1,6 +0,0 @@
1−# Katip Datadog [![Build Status](https://travis-ci.org/Soostone/katip.svg?branch=master)](https://travis-ci.org/Soostone/katip)
2−
3−katip-datadog is a scribe for the Katip logging framework that sends
4−structured logs to the Datadog logging service. It supports both
5−directly sending to the ingestion API and through a locally installed
6−datadog agent.
katip-datadog/changelog.mddeleted−7
@@ -1,7 +0,0 @@
1−0.2.0.0
2−==========
3−* Remove import of deprecated Network module
4−
5−0.1.0.0
6−==========
7−* Initial release
katip-datadog/katip-datadog.cabaldeleted−78
@@ -1,78 +0,0 @@
1−name: katip-datadog
2−version: 0.2.0.0
3−synopsis: Datadog scribe for the Katip logging framework
4−description: See README.md for more details.
5−license: BSD3
6−license-file: LICENSE
7−author: Michael Xavier
8−maintainer: michael.xavier@soostone.com
9−copyright: Soostone Inc, 2018
10−category: Data, Text, Logging
11−homepage: https://github.com/Soostone/katip
12−bug-reports: https://github.com/Soostone/katip/issues
13−build-type: Simple
14−cabal-version: >=1.10
15−extra-source-files:
16− README.md
17− changelog.md
18−
19−--TODO: fill this in
20−tested-with: GHC == 8.4.3
21−
22−source-repository head
23− type: git
24− location: https://github.com/Soostone/katip.git
25−
26−flag lib-Werror
27− default: False
28− manual: True
29−
30−
31−library
32− exposed-modules:
33− Katip.Scribes.Datadog.TCP
34− build-depends:
35− base >=4.4.0.0 && <5
36− , aeson >= 1.0.0.0
37− , bytestring
38− , katip >= 0.8.0.0
39− , text
40− , connection
41− , resource-pool
42− , time
43− , binary
44− , network
45− , safe-exceptions
46− , retry >= 0.7
47− hs-source-dirs: src
48− default-language: Haskell2010
49− hs-source-dirs: src
50− ghc-options: -Wall
51− if flag(lib-Werror)
52− ghc-options: -Werror
53−
54−
55−test-suite test
56− type: exitcode-stdio-1.0
57− main-is: Main.hs
58− hs-source-dirs: test
59− default-language: Haskell2010
60− other-modules:
61− Katip.Tests.Scribes.Datadog.TCP
62− build-depends: base
63− , katip
64− , katip-datadog
65− , conduit
66− , conduit-extra
67− , tasty
68− , tasty-hunit
69− , aeson
70− , unordered-containers
71− , containers
72− , safe-exceptions
73− , async
74− , attoparsec
75− , text
76− ghc-options: -Wall
77− if flag(lib-Werror)
78− ghc-options: -Werror
katip-datadog/src/Katip/Scribes/Datadog/TCP.hsdeleted−191
@@ -1,191 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RankNTypes #-}
4−-- | Creates a scribe as a Custom Forwarder for Datadog that sends log
5−-- messages over TCP via their TLS endpoint.
6−module Katip.Scribes.Datadog.TCP
7− ( -- * Types
8− APIKey(..)
9− , DatadogScribeSettings(..)
10− , DatadogAuth(..)
11− , directAPIConnectionParams
12− , localAgentConnectionParams
13− -- * Scribe construction
14− , mkDatadogScribeSettings
15− , mkDatadogScribe
16− ) where
17−
18−
19−
20−-------------------------------------------------------------------------------
21−import qualified Control.Concurrent as Conc
22−import qualified Control.Exception.Safe as EX
23−import Control.Monad (void)
24−import qualified Control.Retry as Retry
25−import qualified Data.Aeson as A
26−import qualified Data.Binary.Builder as BB
27−import qualified Data.ByteString.Lazy as BSL
28−import Data.Monoid as Monoid
29−import qualified Data.Pool as Pool
30−import Data.Text (Text)
31−import qualified Data.Text.Encoding as T
32−import qualified Data.Text.Lazy.Builder as B
33−import Data.Time (NominalDiffTime)
34−import Katip
35−import Katip.Core (LocJs (..))
36−import qualified Network.Connection as C
37−import qualified Network.Socket as Net
38−import qualified System.Posix.Types as POSIX
39−-------------------------------------------------------------------------------
40−
41−
42−-- | When writing directly to the main intake API, you must specify an
43−-- API key
44−newtype APIKey = APIKey
45− { apiKey :: Text
46− } deriving (Show, Eq)
47−
48−
49−data DatadogAuth =
50− NoAuthLocal
51− -- ^ Writing to the local agent, no auth required
52− | DirectAuth APIKey
53− -- ^ Writing directly to the main intake API over TLS . API Key is
54− -- required. Using a local agent is recommended.
55−
56−
57−data DatadogScribeSettings = DatadogScribeSettings
58− { datadogScribeSettings_connectionParams :: C.ConnectionParams
59− -- ^ Specify where the logs should go. If writing directly to the
60− -- main intake API, you can use 'directAPIConnectionParams'. If
61− -- writing to a local agent, we recommend
62− -- 'localAgentConnectionParams'
63− , datadogScribeSettings_auth :: DatadogAuth
64− , datadogScribeSettings_poolStripes :: Int
65− -- ^ How many stripes should be used in the connection pool. 1 is a reasonable default
66− , datadogScribeSettings_connsPerStripe :: Int
67− -- ^ How many TCP connections per stripe should be maintained in the pool.
68− , datadogScribeSettings_connectionKeepalive :: NominalDiffTime
69− -- ^ How long should a TCP connection be kept open. 30 (seconds) is a reasonable default. Anything around 60 will tend to time out a lot.
70− , datadogScribeSettings_retry :: Retry.RetryPolicyM IO
71− -- ^ How should exceptions during write be retried?
72− }
73−
74−
75−-- | Configured for secure TLS communication to the main intake API at
76−-- intake.logs.datadoghq.com:10516. Must be combined with DirectAuth
77−-- authentication.
78−directAPIConnectionParams :: C.ConnectionParams
79−directAPIConnectionParams = C.ConnectionParams
80− { C.connectionHostname = "intake.logs.datadoghq.com"
81− , C.connectionPort = 10516
82− , C.connectionUseSecure = Just $ C.TLSSettingsSimple
83− { C.settingDisableCertificateValidation = False
84− , C.settingDisableSession = False
85− , C.settingUseServerName = False
86− }
87− , C.connectionUseSocks = Nothing
88− }
89−
90−
91−-- | Configure to talk to a local Datadog agent at 127.0.0.1. TLS is not
92−-- utilized. This is the preferred type of connection because
93−-- authentication, buffering, and other more advanced features are
94−-- handled by the agent configuration.
95−localAgentConnectionParams :: Net.PortNumber -> C.ConnectionParams
96−localAgentConnectionParams port = C.ConnectionParams
97− { C.connectionHostname = "127.0.0.1"
98− , C.connectionPort = port
99− , C.connectionUseSecure = Nothing
100− , C.connectionUseSocks = Nothing
101− }
102−
103−
104−-- | Reasonable defaults. Sets a 30s connection timeout, 1 stripe of
105−-- connections with a number of connections per stripe equal to
106−-- 'getNumCapabilities'. Retry policy will do an exponential backoff
107−-- with a 25ms base delay for up to 5 retries for a total cumulative delay of 775ms
108−mkDatadogScribeSettings :: C.ConnectionParams -> DatadogAuth -> IO DatadogScribeSettings
109−mkDatadogScribeSettings connectionParams auth = do
110− capabilities <- Conc.getNumCapabilities
111− pure $ DatadogScribeSettings
112− { datadogScribeSettings_connectionParams = connectionParams
113− , datadogScribeSettings_auth = auth
114− , datadogScribeSettings_poolStripes = 1
115− , datadogScribeSettings_connsPerStripe = capabilities
116− , datadogScribeSettings_connectionKeepalive = 30
117− , datadogScribeSettings_retry = Retry.exponentialBackoff 25000 <> Retry.limitRetries 5
118− }
119−
120−
121−-------------------------------------------------------------------------------
122−mkDatadogScribe
123− :: DatadogScribeSettings
124− -> PermitFunc
125− -- ^ Function on whether to permit items, e.g. @permitItem InfoS@
126− -> Verbosity
127− -- ^ Verbosity level to observe
128− -> IO Scribe
129−mkDatadogScribe settings permit verb = do
130− connectionContext <- C.initConnectionContext
131− pool <- Pool.createPool
132− (C.connectTo connectionContext (datadogScribeSettings_connectionParams settings))
133− C.connectionClose
134− (datadogScribeSettings_poolStripes settings)
135− (datadogScribeSettings_connectionKeepalive settings)
136− (datadogScribeSettings_connsPerStripe settings)
137− pure $ Scribe
138− { liPush = pushPool (datadogScribeSettings_retry settings) pool keyBuilder verb
139− , scribeFinalizer = Pool.destroyAllResources pool
140− , scribePermitItem = permit
141− }
142− where
143− !keyBuilder = case datadogScribeSettings_auth settings of
144− NoAuthLocal -> Nothing
145− DirectAuth (APIKey k) -> Just (BB.fromByteString (T.encodeUtf8 k))
146−
147−
148−pushPool
149− :: LogItem a
150− => Retry.RetryPolicyM IO
151− -> Pool.Pool C.Connection
152− -> Maybe BB.Builder
153− -- ^ Rendered API key
154− -> Verbosity
155− -> Item a
156− -> IO ()
157−pushPool retryPolicy pool token verb item =
158− void $ Retry.retrying retryPolicy (\_status shouldRetry -> pure shouldRetry) $ \_status -> do
159− res <- EX.tryAny $ Pool.withResource pool $ \conn -> do
160− C.connectionPut conn rendered
161− pure $ case res of
162− Left _ -> True
163− Right _ -> False
164− where
165− payloadBuilder = A.fromEncoding (encodeDatadog verb item) Monoid.<> "\n"
166− messageBuilder = case token of
167− --TODO: lots of conversion going on here. could use a bench
168− Nothing -> payloadBuilder
169− Just directKey -> directKey <> " " <> payloadBuilder
170− rendered = BSL.toStrict (BB.toLazyByteString messageBuilder)
171−
172−
173−encodeDatadog :: LogItem a => Verbosity -> Item a -> A.Encoding
174−encodeDatadog verb i = A.pairs $
175− -- datadog seems to use "service" to denote appname
176− "service" A..= _itemApp i <>
177− -- datadog uses severity (or some other alternatives for sev)
178− "severity" A..= _itemSeverity i <>
179− "env" A..= _itemEnv i <>
180− "thread" A..= getThreadIdText (_itemThread i) <>
181− "host" A..= _itemHost i <>
182− "pid" A..= pidInt <>
183− "data" A..= payloadObject verb (_itemPayload i) <>
184− -- datadog uses "message" instead of msg
185− "message" A..= (B.toLazyText (unLogStr (_itemMessage i))) <>
186− -- datadog uses "date" instead of "at"
187− "date" A..= _itemTime i <>
188− "ns" A..= _itemNamespace i <>
189− "loc" A..= fmap LocJs (_itemLoc i)
190− where
191− POSIX.CPid pidInt = _itemProcess i
katip-datadog/test/Katip/Tests/Scribes/Datadog/TCP.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Katip.Tests.Scribes.Datadog.TCP
3− ( tests
4− ) where
5−
6−
7−-------------------------------------------------------------------------------
8−import Control.Concurrent.Async
9−import qualified Control.Exception.Safe as EX
10−import qualified Data.Aeson as A
11−import qualified Data.Char as Char
12−import qualified Data.Conduit as C
13−import qualified Data.Conduit.Binary as CB
14−import qualified Data.Conduit.List as CL
15−import qualified Data.Conduit.Network as CN
16−import Data.Foldable (toList)
17−import qualified Data.HashMap.Strict as HM
18−import Data.IORef
19−import Data.Sequence ((|>))
20−import Data.Text (Text)
21−import qualified Data.Text as T
22−import Test.Tasty
23−import Test.Tasty.HUnit
24−-------------------------------------------------------------------------------
25−import Katip
26−import Katip.Scribes.Datadog.TCP
27−-------------------------------------------------------------------------------
28−
29−
30−
31−tests :: TestTree
32−tests = testGroup "Katip.Scribes.Datadog.TCP"
33− [ testCase "logs well-formed messages in order" $ do
34− logs <- collectLogs $ do
35− logItem (sl "foo" ("bar" :: Text)) "mynamespace" noLoc InfoS "a message"
36− length logs @?= 1
37− let (CapturedLog ns dta sev msg thread) = head logs
38− ns @?= Namespace ["katip-datadog-tests", "mynamespace"]
39− dta @?= A.Object (HM.singleton "foo" (A.String "bar"))
40− sev @?= InfoS
41− msg @?= "a message"
42− if T.all Char.isNumber thread && T.length thread > 0
43− then pure ()
44− else assertFailure ("Expected thread id to just be a number but it was " <> T.unpack thread)
45− ]
46− where
47− noLoc = Nothing
48−
49−
50−-------------------------------------------------------------------------------
51−-- | A log type parsed out of the fake datadog agent's buffer
52−data CapturedLog = CapturedLog
53− { capturedLog_namespace :: Namespace
54− , capturedLog_data :: A.Value
55− , capturedLog_sev :: Severity
56− , capturedLog_message :: Text
57− , capturedLog_thread :: Text
58− } deriving (Show, Eq)
59−
60−
61−instance A.FromJSON CapturedLog where
62− parseJSON = A.withObject "CapturedLog" $ \o -> do
63− message <- o A..: "message"
64− sev <- o A..: "severity"
65− dta <- o A..: "data"
66− namespace <- o A..: "ns"
67− thread <- o A..: "thread"
68− pure $ CapturedLog
69− { capturedLog_namespace = namespace
70− , capturedLog_data = dta
71− , capturedLog_sev = sev
72− , capturedLog_message = message
73− , capturedLog_thread = thread
74− }
75−
76−
77−-------------------------------------------------------------------------------
78−collectLogs :: KatipT IO () -> IO [CapturedLog]
79−collectLogs f = do
80− capturedRef <- newIORef mempty
81− withAsync (startServer capturedRef) $ \_worker -> do
82− EX.bracket mkLE closeLE $ \le -> do
83− runKatipT le f
84− toList <$> readIORef capturedRef
85− where
86− closeLE = closeScribes
87− port = 1337
88− mkLE = do
89− datadogScribeSettings <- mkDatadogScribeSettings (localAgentConnectionParams (fromInteger port)) NoAuthLocal
90− scribe <- mkDatadogScribe datadogScribeSettings (permitItem DebugS) V3
91− registerScribe "datadog" scribe defaultScribeSettings =<< initLogEnv "katip-datadog-tests" "test"
92− startServer capturedRef = CN.runTCPServer (CN.serverSettings (fromInteger port) "*") $ \appData -> C.runConduit $
93− CN.appSource appData C..|
94− CB.lines C..|
95− CL.map A.eitherDecodeStrict C..|
96− CL.mapM_ (\parseResult -> case parseResult of
97− Left e -> EX.throwM (ParseError e)
98− (Right capturedLog) -> modifyIORef' capturedRef (\captured -> captured |> capturedLog))
99−
100−
101−-------------------------------------------------------------------------------
102−newtype ParseError = ParseError String
103− deriving (Show)
104−
105−instance EX.Exception ParseError
katip-datadog/test/Main.hsdeleted−22
@@ -1,22 +0,0 @@
1−module Main
2− ( main
3− ) where
4−
5−
6−-------------------------------------------------------------------------------
7−import Test.Tasty
8−-------------------------------------------------------------------------------
9−import qualified Katip.Tests.Scribes.Datadog.TCP
10−-------------------------------------------------------------------------------
11−
12−
13−
14−main :: IO ()
15−main = defaultMain tests
16−
17−
18−-------------------------------------------------------------------------------
19−tests :: TestTree
20−tests = testGroup "katip-datadog"
21− [ Katip.Tests.Scribes.Datadog.TCP.tests
22− ]
katip-elasticsearch/bench/Main.hs+3−3
@@ -15,11 +15,11 @@ import qualified Data.HashMap.Strict as HM
15import Data.Proxy (Proxy (..))
15import Data.Proxy (Proxy (..))
16import System.Random
16import System.Random
17import qualified Data.Text as T
17import qualified Data.Text as T
18−import Database.Bloodhound.Types
18+import Database.V1.Bloodhound.Types
19import Numeric
19import Numeric
20-------------------------------------------------------------------------------
20-------------------------------------------------------------------------------
21import Katip.Scribes.ElasticSearch
21import Katip.Scribes.ElasticSearch
22−import Katip.Scribes.ElasticSearch.Internal (ESV5)
22+import Katip.Scribes.ElasticSearch.Internal (ESV1)
23-------------------------------------------------------------------------------
23-------------------------------------------------------------------------------
24
24
25main :: IO ()
25main :: IO ()
@@ -34,7 +34,7 @@ main = do
34mkDocIdBenchmark :: Benchmark
34mkDocIdBenchmark :: Benchmark
35mkDocIdBenchmark = bgroup "mkDocId"
35mkDocIdBenchmark = bgroup "mkDocId"
36 [
36 [
37− bench "mkDocId (randomIO)" $ nfIO (mkDocId (Proxy :: Proxy ESV5))
37+ bench "mkDocId (randomIO)" $ nfIO (mkDocId (Proxy :: Proxy ESV1))
38 , bench "mkDocId' (shared )" $ nfIO mkDocId'
38 , bench "mkDocId' (shared )" $ nfIO mkDocId'
39 ]
39 ]
40
40
katip-elasticsearch/changelog.md−38
@@ -1,41 +1,3 @@
1−0.7.0.0
2−=======
3−* Make compatible with unreleased bloodhound 0.17
4−* Deprecate use of ES version 1 which has been removed from bloodhound
5− 0.17. All users should move over to ESV5 which should work for
6− versions 5 and up.
7−* Default configuration to ESV5
8−* Add deprecation warnings for ESV1. Support for ESV1 will be removed
9− in the future.
10−
11−0.6.0.0
12−=======
13−* Update to katip-0.8.0.0 `PermitFunc` convention. To update, for
14− example, if you were passing `InfoS` to `mkEsScribe` to filter
15− severities, instead you should pass `(permitItem InfoS)`.
16−* Update examples to add necessary type signature for the default
17− scribe config.
18−* Bugfix: the default error retry policy was much more rapid than
19− documented.
20−* Internally switch to safe-exceptions from encolosed-exceptions.
21−
22−0.5.1.1
23−=======
24−* Loosen katip dep
25−
26−0.5.1.0
27−=======
28−* Loosen deps
29−
30−0.5.0.0
31−=======
32−* Update template for ESv1 to not analyze certain fields like host and
33− namespace. These are not fields that benefit from tokenization. If
34− you're on ESv1, after running `mkEsScribe`, the logs template will
35− be updated to stop analyzing those fields. That means the next
36− index that is cut (e.g. tomorrow's logs if you're using daily index
37− sharding) will no longer analyze some fields.
38−
390.4.2.0
10.4.2.0
40=======
2=======
41* Allow newer bloodhound, aeson, async.
3* Allow newer bloodhound, aeson, async.
katip-elasticsearch/docker-compose.ymldeleted−10
@@ -1,10 +0,0 @@
1−version: "3.7"
2−services:
3− # https://hub.docker.com/_/elasticsearch
4− elasticsearch:
5− image: elasticsearch:5-alpine
6− ports:
7− - target: 9200
8− published: 9200
9− protocol: tcp
10− mode: host
katip-elasticsearch/examples/example.hs+3−4
@@ -6,7 +6,7 @@ module Main
6
6
7-------------------------------------------------------------------------------
7-------------------------------------------------------------------------------
8import Control.Exception
8import Control.Exception
9−import Database.Bloodhound
9+import Database.V5.Bloodhound
10import Network.HTTP.Client
10import Network.HTTP.Client
11-------------------------------------------------------------------------------
11-------------------------------------------------------------------------------
12import Katip
12import Katip
@@ -18,16 +18,15 @@ main :: IO ()
18main = do
18main = do
19 mgr <- newManager defaultManagerSettings
19 mgr <- newManager defaultManagerSettings
20 let bhe = mkBHEnv (Server "http://localhost:9200") mgr
20 let bhe = mkBHEnv (Server "http://localhost:9200") mgr
21− -- You may need to specify the version in a type signature when customizing your index settings
22− let _customizedExample = defaultEsScribeCfgV5 { essIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)} :: EsScribeCfg ESV5
23 esScribe <- mkEsScribe
21 esScribe <- mkEsScribe
24 -- Reasonable for production
22 -- Reasonable for production
25 defaultEsScribeCfgV5
23 defaultEsScribeCfgV5
26 -- Reasonable for single-node in development
24 -- Reasonable for single-node in development
25+ -- defaultEsScribeCfgV5 { essIndexSettings = IndexSettings (ShardCound 1) (ReplicaCount 0)}
27 bhe
26 bhe
28 (IndexName "all-indices-prefixed-with")
27 (IndexName "all-indices-prefixed-with")
29 (MappingName "application-logs")
28 (MappingName "application-logs")
30− (permitItem DebugS)
29+ DebugS
31 V3
30 V3
32 let mkLogEnv = registerScribe "es" esScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"
31 let mkLogEnv = registerScribe "es" esScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"
33 bracket mkLogEnv closeScribes $ \le -> runKatipT le $ do
32 bracket mkLogEnv closeScribes $ \le -> runKatipT le $ do
katip-elasticsearch/katip-elasticsearch.cabal+20−17
@@ -1,7 +1,7 @@
1name: katip-elasticsearch
1name: katip-elasticsearch
2synopsis: ElasticSearch scribe for the Katip logging framework.
2synopsis: ElasticSearch scribe for the Katip logging framework.
3description: See README.md for more details.
3description: See README.md for more details.
4−version: 0.7.0.0
4+version: 0.4.2.0
5license: BSD3
5license: BSD3
6license-file: LICENSE
6license-file: LICENSE
7author: Ozgun Ataman, Michael Xavier
7author: Ozgun Ataman, Michael Xavier
@@ -18,7 +18,7 @@ extra-source-files:
18 bench/Main.hs
18 bench/Main.hs
19 examples/example.hs
19 examples/example.hs
20 test/Main.hs
20 test/Main.hs
21−tested-with: GHC == 7.8.4, GHC== 7.10.3, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.3
21+tested-with: GHC == 7.8.4, GHC== 7.10.3
22
22
23source-repository head
23source-repository head
24 type: git
24 type: git
@@ -35,23 +35,23 @@ library
35 Katip.Scribes.ElasticSearch.Internal
35 Katip.Scribes.ElasticSearch.Internal
36 build-depends:
36 build-depends:
37 base >=4.6 && <5
37 base >=4.6 && <5
38− , katip >= 0.8.0.0
38+ , katip >= 0.2.0.0 && < 0.7
39− , bloodhound >= 0.13.0.0
39+ , bloodhound >= 0.13.0.0 && < 0.17
40− , uuid >= 1.3.12
40+ , uuid >= 1.3.12 && < 1.4
41 , aeson >=0.6
41 , aeson >=0.6
42− , stm >= 2.4.3
42+ , stm >= 2.4.3 && < 2.5
43− , stm-chans >= 3.0.0.2
43+ , stm-chans >= 3.0.0.2 && < 3.1
44− , async >= 2.0.1.0
44+ , async >= 2.0.1.0 && < 3.0
45− , safe-exceptions >= 0.1.0.0
45+ , enclosed-exceptions >= 1.0.0 && < 1.1
46− , http-client >= 0.3
46+ , http-client >= 0.3 && < 0.6
47− , text >= 0.11
47+ , text >= 0.11 && < 1.3
48− , retry >= 0.7
48+ , retry >= 0.7 && < 0.8
49 , exceptions
49 , exceptions
50− , scientific >= 0.3.0.0
50+ , scientific >= 0.3.0.0 && < 0.4
51− , unordered-containers >= 0.1.0.0
51+ , unordered-containers >= 0.1.0.0 && < 0.3
52− , transformers >= 0.2
52+ , transformers >= 0.2 && < 0.6
53− , http-types >= 0.8
53+ , http-types >= 0.8 && < 0.13
54− , time >= 1
54+ , time >= 1 && < 1.9
55 , bytestring
55 , bytestring
56 , semigroups
56 , semigroups
57 hs-source-dirs: src
57 hs-source-dirs: src
@@ -108,4 +108,7 @@ test-suite test
108 , bytestring
108 , bytestring
109 , tagged
109 , tagged
110
110
111+ if flag(lib-Werror)
112+ ghc-options: -Wall -Werror
113+
111 ghc-options: -threaded -rtsopts
114 ghc-options: -threaded -rtsopts
katip-elasticsearch/src/Katip/Scribes/ElasticSearch.hs+1−6
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2-- | Includes a scribe that can be used to log structured, JSON log
1-- | Includes a scribe that can be used to log structured, JSON log
3-- messages to ElasticSearch. These logs can be explored easily using
2-- messages to ElasticSearch. These logs can be explored easily using
4-- <https://www.elastic.co/products/kibana kibana> or your tool of
3-- <https://www.elastic.co/products/kibana kibana> or your tool of
@@ -23,7 +22,7 @@
23-- -- Reasonable for production
22-- -- Reasonable for production
24-- defaultEsScribeCfgV5
23-- defaultEsScribeCfgV5
25-- -- Reasonable for single-node in development
24-- -- Reasonable for single-node in development
26−-- -- defaultEsScribeCfgV5 { essIndexSettings = IndexSettings (ShardCound 1) (ReplicaCount 0)} :: EsScribeCfg ESV5
25+-- -- defaultEsScribeCfgV5 { essIndexSettings = IndexSettings (ShardCound 1) (ReplicaCount 0)}
27-- bhe
26-- bhe
28-- (IndexName "all-indices-prefixed-with")
27-- (IndexName "all-indices-prefixed-with")
29-- (MappingName "application-logs")
28-- (MappingName "application-logs")
@@ -68,16 +67,12 @@ module Katip.Scribes.ElasticSearch
68 , essIndexSettings
67 , essIndexSettings
69 , essIndexSharding
68 , essIndexSharding
70 , defaultEsScribeCfg
69 , defaultEsScribeCfg
71−#if !MIN_VERSION_bloodhound(0,17,0)
72 , defaultEsScribeCfgV1
70 , defaultEsScribeCfgV1
73−#endif
74 , defaultEsScribeCfgV5
71 , defaultEsScribeCfgV5
75 -- ** Version-Proxied APIS
72 -- ** Version-Proxied APIS
76 -- $versionproxies
73 -- $versionproxies
77 , defaultEsScribeCfg'
74 , defaultEsScribeCfg'
78−#if !MIN_VERSION_bloodhound(0,17,0)
79 , ESV1
75 , ESV1
80−#endif
81 , ESV5
76 , ESV5
82 -- * Utilities
77 -- * Utilities
83 , mkDocId
78 , mkDocId
katip-elasticsearch/src/Katip/Scribes/ElasticSearch/Internal.hs+30−50
@@ -16,7 +16,8 @@ import Control.Applicative as A
16import Control.Concurrent
16import Control.Concurrent
17import Control.Concurrent.Async
17import Control.Concurrent.Async
18import Control.Concurrent.STM.TBMQueue
18import Control.Concurrent.STM.TBMQueue
19+import Control.Exception.Base
19−import qualified Control.Exception.Safe as EX
20+import Control.Exception.Enclosed
20import Control.Monad
21import Control.Monad
21import Control.Monad.Catch
22import Control.Monad.Catch
22import Control.Monad.IO.Class
23import Control.Monad.IO.Class
@@ -27,8 +28,8 @@ import Control.Retry (RetryPolicy,
27 recovering)
28 recovering)
28import Data.Aeson
29import Data.Aeson
29import Data.ByteString.Lazy (ByteString)
30import Data.ByteString.Lazy (ByteString)
30−import Data.List.NonEmpty (NonEmpty (..))
31+import Data.List.NonEmpty (NonEmpty(..))
31−import Data.Monoid as Monoid
32+import Data.Monoid ((<>))
32import Data.Text (Text)
33import Data.Text (Text)
33import qualified Data.Text as T
34import qualified Data.Text as T
34import qualified Data.Text.Encoding as T
35import qualified Data.Text.Encoding as T
@@ -37,12 +38,8 @@ import Data.Time.Calendar.WeekDate
37import Data.Typeable as Typeable
38import Data.Typeable as Typeable
38import Data.UUID
39import Data.UUID
39import qualified Data.UUID.V4 as UUID4
40import qualified Data.UUID.V4 as UUID4
40−#if MIN_VERSION_bloodhound(0,17,0)
41−import qualified Database.Bloodhound as V5
42−#else
43import qualified Database.V1.Bloodhound as V1
41import qualified Database.V1.Bloodhound as V1
44import qualified Database.V5.Bloodhound as V5
42import qualified Database.V5.Bloodhound as V5
45−#endif
46import Network.HTTP.Client
43import Network.HTTP.Client
47import Network.HTTP.Types.Status
44import Network.HTTP.Types.Status
48import Text.Printf (printf)
45import Text.Printf (printf)
@@ -88,7 +85,7 @@ data EsScribeCfg v = EsScribeCfg {
88--
85--
89-- * defaultManagerSettings
86-- * defaultManagerSettings
90--
87--
91−-- * exponential backoff with 25ms base delay up to 5 retries, for a total cumulative delay of 775ms
88+-- * exponential backoff with 25ms base delay up to 5 retries
92--
89--
93-- * Queue size of 1000
90-- * Queue size of 1000
94--
91--
@@ -99,7 +96,7 @@ data EsScribeCfg v = EsScribeCfg {
99-- * DailyIndexSharding
96-- * DailyIndexSharding
100defaultEsScribeCfg' :: ESVersion v => proxy v -> EsScribeCfg v
97defaultEsScribeCfg' :: ESVersion v => proxy v -> EsScribeCfg v
101defaultEsScribeCfg' prx = EsScribeCfg {
98defaultEsScribeCfg' prx = EsScribeCfg {
102− essRetryPolicy = exponentialBackoff 25000 Monoid.<> limitRetries 5
99+ essRetryPolicy = exponentialBackoff 25 <> limitRetries 5
103 , essQueueSize = EsQueueSize 1000
100 , essQueueSize = EsQueueSize 1000
104 , essPoolSize = EsPoolSize 2
101 , essPoolSize = EsPoolSize 2
105 , essAnnotateTypes = False
102 , essAnnotateTypes = False
@@ -108,22 +105,19 @@ defaultEsScribeCfg' prx = EsScribeCfg {
108 }
105 }
109
106
110
107
111−
112−
113-------------------------------------------------------------------------------
108-------------------------------------------------------------------------------
114−-- | Alias of 'defaultEsScribeCfgV5' to minimize API
109+-- | Alias of 'defaultEsScribeCfgV1' to minimize API
115-- breakage. Previous versions of katip-elasticsearch only supported
110-- breakage. Previous versions of katip-elasticsearch only supported
116−-- ES version 1 and defaulted to it.
111+-- ES version 1.
117−defaultEsScribeCfg :: EsScribeCfg ESV5
112+defaultEsScribeCfg :: EsScribeCfg ESV1
118−defaultEsScribeCfg = defaultEsScribeCfgV5
113+defaultEsScribeCfg = defaultEsScribeCfgV1
119
114
120
115
121-------------------------------------------------------------------------------
116-------------------------------------------------------------------------------
122−#if !MIN_VERSION_bloodhound(0,17,0)
123-- | EsScribeCfg that will use ElasticSearch V1
117-- | EsScribeCfg that will use ElasticSearch V1
124defaultEsScribeCfgV1 :: EsScribeCfg ESV1
118defaultEsScribeCfgV1 :: EsScribeCfg ESV1
125defaultEsScribeCfgV1 = defaultEsScribeCfg' (Typeable.Proxy :: Typeable.Proxy ESV1)
119defaultEsScribeCfgV1 = defaultEsScribeCfg' (Typeable.Proxy :: Typeable.Proxy ESV1)
126−#endif
120+
127
121
128-------------------------------------------------------------------------------
122-------------------------------------------------------------------------------
129-- | EsScribeCfg that will use ElasticSearch V5
123-- | EsScribeCfg that will use ElasticSearch V5
@@ -275,10 +269,10 @@ mkEsScribe
275 -> IndexName v
269 -> IndexName v
276 -- ^ Treated as a prefix if index sharding is enabled
270 -- ^ Treated as a prefix if index sharding is enabled
277 -> MappingName v
271 -> MappingName v
278− -> PermitFunc
272+ -> Severity
279 -> Verbosity
273 -> Verbosity
280 -> IO Scribe
274 -> IO Scribe
281−mkEsScribe cfg@EsScribeCfg {..} env ix mapping permit verb = do
275+mkEsScribe cfg@EsScribeCfg {..} env ix mapping sev verb = do
282 q <- newTBMQueueIO $ unEsQueueSize essQueueSize
276 q <- newTBMQueueIO $ unEsQueueSize essQueueSize
283 endSig <- newEmptyMVar
277 endSig <- newEmptyMVar
284
278
@@ -288,21 +282,21 @@ mkEsScribe cfg@EsScribeCfg {..} env ix mapping permit verb = do
288 -- create or update
282 -- create or update
289 res <- putTemplate prx tpl tplName
283 res <- putTemplate prx tpl tplName
290 unless (statusIsSuccessful (responseStatus res)) $
284 unless (statusIsSuccessful (responseStatus res)) $
291− liftIO $ EX.throwIO (CouldNotPutTemplate res)
285+ liftIO $ throwIO (CouldNotPutTemplate res)
292 else do
286 else do
293 ixExists <- indexExists prx ix
287 ixExists <- indexExists prx ix
294 if ixExists
288 if ixExists
295 then do
289 then do
296 res <- updateIndexSettings prx (toUpdatabaleIndexSettings prx essIndexSettings) ix
290 res <- updateIndexSettings prx (toUpdatabaleIndexSettings prx essIndexSettings) ix
297 unless (statusIsSuccessful (responseStatus res)) $
291 unless (statusIsSuccessful (responseStatus res)) $
298− liftIO $ EX.throwIO (CouldNotUpdateIndexSettings res)
292+ liftIO $ throwIO (CouldNotUpdateIndexSettings res)
299 else do
293 else do
300 r1 <- createIndex prx essIndexSettings ix
294 r1 <- createIndex prx essIndexSettings ix
301 unless (statusIsSuccessful (responseStatus r1)) $
295 unless (statusIsSuccessful (responseStatus r1)) $
302− liftIO $ EX.throwIO (CouldNotCreateIndex r1)
296+ liftIO $ throwIO (CouldNotCreateIndex r1)
303 r2 <- putMapping prx ix mapping base
297 r2 <- putMapping prx ix mapping base
304 unless (statusIsSuccessful (responseStatus r2)) $
298 unless (statusIsSuccessful (responseStatus r2)) $
305− liftIO $ EX.throwIO (CouldNotCreateMapping r2)
299+ liftIO $ throwIO (CouldNotCreateMapping r2)
306
300
307 workers <- replicateM (unEsPoolSize essPoolSize) $ async $
301 workers <- replicateM (unEsPoolSize essPoolSize) $ async $
308 startWorker cfg env mapping q
302 startWorker cfg env mapping q
@@ -314,10 +308,10 @@ mkEsScribe cfg@EsScribeCfg {..} env ix mapping permit verb = do
314 putMVar endSig ()
308 putMVar endSig ()
315
309
316 let finalizer = putMVar endSig () >> takeMVar endSig
310 let finalizer = putMVar endSig () >> takeMVar endSig
317− return (Scribe (logger q) finalizer permit)
311+ return (Scribe (logger q) finalizer)
318 where
312 where
319 logger :: forall a. LogItem a => TBMQueue (IndexName v, Value) -> Item a -> IO ()
313 logger :: forall a. LogItem a => TBMQueue (IndexName v, Value) -> Item a -> IO ()
320− logger q i =
314+ logger q i = when (_itemSeverity i >= sev) $
321 void $ atomically $ tryWriteTBMQueue q (chooseIxn prx ix essIndexSharding i, itemJson' i)
315 void $ atomically $ tryWriteTBMQueue q (chooseIxn prx ix essIndexSharding i, itemJson' i)
322 prx :: Typeable.Proxy v
316 prx :: Typeable.Proxy v
323 prx = Typeable.Proxy
317 prx = Typeable.Proxy
@@ -351,8 +345,8 @@ baseMapping prx mn =
351 , "at" .= dateType
345 , "at" .= dateType
352 , unanalyzedString "app"
346 , unanalyzedString "app"
353 ]
347 ]
354− unanalyzedString k = k .= unanalyzedStringSpec prx
348+ unanalyzedString k = k .= object ["type" .= String (unanalyzedStringType prx)]
355− analyzedString k = k .= analyzedStringSpec prx
349+ analyzedString k = k .= object ["type" .= String (analyzedStringType prx)]
356 locType = object ["properties" .= object locPairs]
350 locType = object ["properties" .= object locPairs]
357 locPairs = [ unanalyzedString "loc_pkg"
351 locPairs = [ unanalyzedString "loc_pkg"
358 , unanalyzedString "loc_mod"
352 , unanalyzedString "loc_mod"
@@ -427,7 +421,7 @@ startWorker EsScribeCfg {..} env mapping q = go
427 popped <- atomically $ readTBMQueue q
421 popped <- atomically $ readTBMQueue q
428 case popped of
422 case popped of
429 Just (ixn, v) -> do
423 Just (ixn, v) -> do
430− sendLog ixn v `EX.catchAny` eat
424+ sendLog ixn v `catchAny` eat
431 go
425 go
432 Nothing -> return ()
426 Nothing -> return ()
433 prx :: Typeable.Proxy v
427 prx :: Typeable.Proxy v
@@ -440,8 +434,8 @@ startWorker EsScribeCfg {..} env mapping q = go
440 eat _ = return ()
434 eat _ = return ()
441 handler _ = Handler $ \e ->
435 handler _ = Handler $ \e ->
442 case fromException e of
436 case fromException e of
443− Just (_ :: EX.SomeAsyncException) -> return False
437+ Just (_ :: AsyncException) -> return False
444− _ -> return True
438+ _ -> return True
445
439
446
440
447-------------------------------------------------------------------------------
441-------------------------------------------------------------------------------
@@ -486,15 +480,12 @@ class ESVersion v where
486
480
487 -- In ES 5 and beyond, "string" was deprecated in favor of text for
481 -- In ES 5 and beyond, "string" was deprecated in favor of text for
488 -- fulltext and keyword for unanalyzed tokens
482 -- fulltext and keyword for unanalyzed tokens
489− unanalyzedStringSpec :: proxy v -> Value
483+ unanalyzedStringType :: proxy v -> Text
490− analyzedStringSpec :: proxy v -> Value
484+ analyzedStringType :: proxy v -> Text
491
485
492
486
493
487
494−#if !MIN_VERSION_bloodhound(0,17,0)
495data ESV1 = ESV1
488data ESV1 = ESV1
496−{-# DEPRECATED ESV1 "ESV1 is deprecated and removed in bloodhound >= 0.17.0" #-}
497−
498
489
499instance ESVersion ESV1 where
490instance ESVersion ESV1 where
500 type BHEnv ESV1 = V1.BHEnv
491 type BHEnv ESV1 = V1.BHEnv
@@ -526,15 +517,8 @@ instance ESVersion ESV1 where
526 updateIndexSettings _ = V1.updateIndexSettings
517 updateIndexSettings _ = V1.updateIndexSettings
527 putTemplate _ = V1.putTemplate
518 putTemplate _ = V1.putTemplate
528 putMapping _ = V1.putMapping
519 putMapping _ = V1.putMapping
529− unanalyzedStringSpec _ = object
520+ unanalyzedStringType _ = "string"
530− [ "type" .= String "string"
521+ analyzedStringType _ = "string"
531− , "index" .= String "not_analyzed"
532− ]
533− analyzedStringSpec _ = object
534− [ "type" .= String "string"
535− , "index" .= String "analyzed"
536− ]
537−#endif
538
522
539
523
540data ESV5 = ESV5
524data ESV5 = ESV5
@@ -569,9 +553,5 @@ instance ESVersion ESV5 where
569 updateIndexSettings _ = V5.updateIndexSettings
553 updateIndexSettings _ = V5.updateIndexSettings
570 putTemplate _ = V5.putTemplate
554 putTemplate _ = V5.putTemplate
571 putMapping _ = V5.putMapping
555 putMapping _ = V5.putMapping
572− unanalyzedStringSpec _ = object
556+ unanalyzedStringType _ = "keyword"
573− [ "type" .= String "keyword"
557+ analyzedStringType _ = "text"
574− ]
575− analyzedStringSpec _ = object
576− [ "type" .= String "text"
577− ]
katip-elasticsearch/test/Main.hs+8−24
@@ -34,12 +34,8 @@ import Data.Time
34import Data.Time.Calendar.WeekDate
34import Data.Time.Calendar.WeekDate
35import Data.Typeable as Typeable
35import Data.Typeable as Typeable
36import qualified Data.Vector as V
36import qualified Data.Vector as V
37−#if MIN_VERSION_bloodhound(0,17,0)
38−import qualified Database.Bloodhound as V5
39−#else
40import qualified Database.V1.Bloodhound as V1
37import qualified Database.V1.Bloodhound as V1
41import qualified Database.V5.Bloodhound as V5
38import qualified Database.V5.Bloodhound as V5
42−#endif
43import Network.HTTP.Client
39import Network.HTTP.Client
44import Network.HTTP.Types.Status
40import Network.HTTP.Types.Status
45import Test.QuickCheck.Instances ()
41import Test.QuickCheck.Instances ()
@@ -58,10 +54,8 @@ main :: IO ()
58main = defaultMainWithIngredients ings $ askOption $ \vers -> testGroup "katip-elasticsearch"
54main = defaultMainWithIngredients ings $ askOption $ \vers -> testGroup "katip-elasticsearch"
59 [
55 [
60 case vers of
56 case vers of
61−#if !MIN_VERSION_bloodhound(0,17,0)
62− TestV1 -> esTests (Typeable.Proxy :: Typeable.Proxy ESV1)
57+ TestV1 -> esTests (Typeable.Proxy :: Typeable.Proxy ESV1)
63−#endif
64− TestV5 -> esTests (Typeable.Proxy :: Typeable.Proxy ESV5)
58+ TestV5 -> esTests (Typeable.Proxy :: Typeable.Proxy ESV5)
65 , typeAnnotatedTests
59 , typeAnnotatedTests
66 , roundToSundayTests
60 , roundToSundayTests
67 ]
61 ]
@@ -70,26 +64,18 @@ main = defaultMainWithIngredients ings $ askOption $ \vers -> testGroup "katip-e
70
64
71
65
72-------------------------------------------------------------------------------
66-------------------------------------------------------------------------------
73−data TestWithESVersion = TestV5
67+data TestWithESVersion = TestV1
74−#if !MIN_VERSION_bloodhound(0,17,0)
68+ | TestV5
75− | TestV1
76−#endif
77− deriving (Typeable)
69+ deriving (Typeable)
78
70
79
71
80instance IsOption TestWithESVersion where
72instance IsOption TestWithESVersion where
81− defaultValue = TestV5
73+ defaultValue = TestV1
82−#if !MIN_VERSION_bloodhound(0,17,0)
83 parseValue "1" = Just TestV1
74 parseValue "1" = Just TestV1
84−#endif
85 parseValue "5" = Just TestV5
75 parseValue "5" = Just TestV5
86 parseValue _ = Nothing
76 parseValue _ = Nothing
87 optionName = Tagged "es-version"
77 optionName = Tagged "es-version"
88−#if MIN_VERSION_bloodhound(0,17,0)
89− optionHelp = Tagged "Version of ES to test against, either 1 or 5, defaulting to 5."
78+ optionHelp = Tagged "Version of ES to test against, either 1 or 5, defaulting to 1."
90−#else
91− optionHelp = Tagged "Version of ES to test against, only v5 is supported, but should work for higher versions."
92−#endif
93
79
94
80
95class ESVersion v => TestESVersion v where
81class ESVersion v => TestESVersion v where
@@ -115,7 +101,6 @@ class ESVersion v => TestESVersion v where
115 searchByIndex :: proxy v -> IndexName v -> Search v -> BH v IO (Response ByteString)
101 searchByIndex :: proxy v -> IndexName v -> Search v -> BH v IO (Response ByteString)
116
102
117
103
118−#if !MIN_VERSION_bloodhound(0,17,0)
119instance TestESVersion ESV1 where
104instance TestESVersion ESV1 where
120 type Server ESV1 = V1.Server
105 type Server ESV1 = V1.Server
121 toServer _ = V1.Server
106 toServer _ = V1.Server
@@ -137,7 +122,6 @@ instance TestESVersion ESV1 where
137 refreshIndex _ = V1.refreshIndex
122 refreshIndex _ = V1.refreshIndex
138 withBH _ = V1.withBH
123 withBH _ = V1.withBH
139 searchByIndex _ = V1.searchByIndex
124 searchByIndex _ = V1.searchByIndex
140−#endif
141
125
142
126
143instance TestESVersion ESV5 where
127instance TestESVersion ESV5 where
@@ -177,7 +161,7 @@ setupSearch
177setupSearch prx modScribeCfg = do
161setupSearch prx modScribeCfg = do
178 bh prx (dropESSchema prx)
162 bh prx (dropESSchema prx)
179 mgr <- newManager defaultManagerSettings
163 mgr <- newManager defaultManagerSettings
180− mkEsScribe cfg (mkBHEnv prx (svr prx) mgr) (ixn prx) (mn prx) (permitItem DebugS) V3
164+ mkEsScribe cfg (mkBHEnv prx (svr prx) mgr) (ixn prx) (mn prx) DebugS V3
181 where
165 where
182 cfg :: EsScribeCfg v
166 cfg :: EsScribeCfg v
183 cfg = modScribeCfg $
167 cfg = modScribeCfg $
katip-logzio/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2018, Soostone Inc
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Ozgun Ataman nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
katip-logzio/README.mddeleted−4
@@ -1,4 +0,0 @@
1−# Katip Logz.IO [![Build Status](https://travis-ci.org/Soostone/katip.svg?branch=master)](https://travis-ci.org/Soostone/katip)
2−
3−katip-logzio is a scribe for the Katip logging framework that sends
4−structured logs to the logz.io centralized logging platform.
katip-logzio/changelog.mddeleted−9
@@ -1,9 +0,0 @@
1−0.1.1.0
2−=======
3−* Fixed bug where on scribe close, any items left in the buffer that
4− hadn't timed out or been flushed already would be dropped rather
5− than flushed. All users are encouraged to upgrade.
6−
7−0.1.0.0
8−==========
9−* Initial release
katip-logzio/katip-logzio.cabaldeleted−94
@@ -1,94 +0,0 @@
1−name: katip-logzio
2−version: 0.1.1.0
3−synopsis: Logz.IO scribe for the Katip logging framework
4−description: See README.md for more details.
5−license: BSD3
6−license-file: LICENSE
7−author: Michael Xavier
8−maintainer: michael.xavier@soostone.com
9−copyright: Soostone Inc, 2018
10−category: Data, Text, Logging
11−homepage: https://github.com/Soostone/katip
12−bug-reports: https://github.com/Soostone/katip/issues
13−build-type: Simple
14−cabal-version: >=1.10
15−extra-source-files:
16− README.md
17− changelog.md
18−
19−tested-with: GHC == 8.4.3
20−
21−source-repository head
22− type: git
23− location: https://github.com/Soostone/katip.git
24−
25−flag lib-Werror
26− default: False
27− manual: True
28−
29−
30−library
31− exposed-modules:
32− Katip.Scribes.LogzIO.HTTPS
33− build-depends:
34− base >=4.8.0.0 && <5
35− , katip >= 0.8.0.0
36− , stm >= 2.1.1
37− , async
38− , time >= 1.8.0.2
39− , aeson >= 0.10.0.0
40− , unix
41− , unordered-containers
42− , http-client >= 0.1.0
43− , http-client-tls >= 0.3.4
44− , uri-bytestring
45− , errors >= 2.0.0
46− , safe-exceptions
47− , retry
48− , http-types
49− , text
50− , bytestring
51− , scientific
52− , stm-chans >= 2.0.0
53− hs-source-dirs: src
54− default-language: Haskell2010
55− hs-source-dirs: src
56− ghc-options: -Wall -Wall -Wnoncanonical-monad-instances
57− if flag(lib-Werror)
58− ghc-options: -Werror
59−
60−
61−test-suite test
62− type: exitcode-stdio-1.0
63− main-is: Main.hs
64− hs-source-dirs: test
65− default-language: Haskell2010
66− other-modules:
67− Katip.Tests.Scribes.LogzIO.HTTPS
68− build-depends: base
69− , katip
70− , katip-logzio
71− , tasty
72− , tasty-hedgehog
73− , tasty-hunit
74− , hedgehog
75− , vector
76− , unordered-containers
77− , text
78− , bytestring
79− , time
80− , template-haskell
81− , aeson
82− , scientific
83− , unix
84− , hostname
85− , scotty
86− , stm
87− , async
88− , safe-exceptions
89− , uri-bytestring
90− , warp
91− , http-types
92− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -Wnoncanonical-monad-instances
93− if flag(lib-Werror)
94− ghc-options: -Werror
katip-logzio/src/Katip/Scribes/LogzIO/HTTPS.hsdeleted−639
@@ -1,639 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE TypeApplications #-}
7−-- | This is a log scribe that writes logs to logz.io's bulk
8−-- <https://app.logz.io/#/dashboard/data-sources/Bulk-HTTPS HTTPS
9−-- API>.
10−module Katip.Scribes.LogzIO.HTTPS
11− ( -- * Scribe construction
12− mkLogzIOScribe
13− -- * Types
14− , BulkAPIError(..)
15− , LogzIOScribeConfiguration(..)
16− , Scheme(..)
17− , APIToken(..)
18− , LoggingError(..)
19− -- ** Presets for configuration
20− , usRegionHost
21− , euRegionHost
22− , httpsPort
23− , httpPort
24− , defaultRetryPolicy
25− , defaultLogzIOScribeConfiguration
26− -- * Internal API exported for testing
27− , renderLineTruncated
28− , renderLineTruncated'
29− , maxPayloadBytes
30− , maxLogLineLength
31− , BulkBuffer (..)
32− , LogAction (..)
33− , bufferItem
34− , bufferItem'
35− , forceFlush
36− , Bytes (..)
37− ) where
38−
39−
40−-------------------------------------------------------------------------------
41−import Control.Applicative
42−import qualified Control.Concurrent.Async as Async
43−import qualified Control.Concurrent.STM as STM
44−import qualified Control.Concurrent.STM.TBMQueue as STM
45−import qualified Control.Error as E
46−import qualified Control.Exception.Safe as EX
47−import Control.Monad
48−import qualified Control.Retry as Retry
49−import qualified Data.Aeson as A
50−import qualified Data.ByteString.Builder as BB
51−import qualified Data.ByteString.Lazy as LBS
52−import qualified Data.ByteString.Lazy.Char8 as LBS8
53−import qualified Data.HashMap.Strict as HM
54−import Data.Int
55−import qualified Data.Scientific as Scientific
56−import Data.Semigroup as Semigroup
57−import Data.String (IsString)
58−import qualified Data.Text as T
59−import qualified Data.Text.Encoding as TE
60−import qualified Data.Text.Lazy as TL
61−import qualified Data.Text.Lazy.Builder as TB
62−import qualified Data.Time as Time
63−import qualified Katip as K
64−import Katip.Core (LocJs (..))
65−import qualified Network.HTTP.Client as HTTP
66−import qualified Network.HTTP.Client.TLS as HTTPS
67−import qualified Network.HTTP.Types as HTypes
68−import qualified System.Posix.Types as POSIX
69−import qualified URI.ByteString as URIBS
70−-------------------------------------------------------------------------------
71−
72−
73−
74−-- | This is returned when the bulk import was a partial success
75−data BulkAPIError = BulkAPIError
76− { bulkAPIError_malformedLines :: Int
77− -- ^ The number of log lines which are not well-formed JSON. This
78− -- indicates a __library bug__. Please file an issue on GitHub.
79− , bulkAPIError_successfulLines :: Int
80− -- ^ The number of log lines received successfully.
81− , bulkAPIError_oversizedLines :: Int
82− -- ^ The number of log lines which exceed the line length
83− -- limit. katip-logzio makes a best effort to truncate logs that
84− -- exceed the size limit. This probably indicates a __library bug__
85− -- and should be reported as an issue on GitHub.
86− , bulkAPIError_emptyLogLines :: Int
87− -- ^ The number of log lines which were empty. There isnt' really a
88− -- concept of a truly empty log line in katip, so this most likely
89− -- indicates a __library bug__ and should be reported as an issue on
90− -- GitHub.
91− } deriving (Show, Eq)
92−
93−
94−instance A.FromJSON BulkAPIError where
95− parseJSON = A.withObject "BulkAPIError" $ \o -> do
96− malformedLines <- o A..: "malformedLines"
97− successfulLines <- o A..: "successfulLines"
98− oversizedLines <- o A..: "oversizedLines"
99− emptyLogLines <- o A..: "emptyLogLines"
100− pure $ BulkAPIError
101− { bulkAPIError_malformedLines = malformedLines
102− , bulkAPIError_successfulLines = successfulLines
103− , bulkAPIError_oversizedLines = oversizedLines
104− , bulkAPIError_emptyLogLines = emptyLogLines
105− }
106−
107−
108−-------------------------------------------------------------------------------
109−data LogzIOScribeConfiguration = LogzIOScribeConfiguration
110− { logzIOScribeConfiguration_bufferItems :: Int
111− -- ^ Will flush the log buffer if this many items is in the buffer
112− -- __or__ 'logzIOScribeConfiguration_bufferTimeout' is reached,
113− -- whichever is first
114− , logzIOScribeConfiguration_bufferTimeout :: Time.NominalDiffTime
115− -- ^ Will flush the buffer if it has been this long since the last
116− -- flush __or__ 'logzIOScribeConfiguration_bufferItems' items are
117− -- accumulated, whichever is first. NominalDiffTime has a Num
118− -- instance, so you can use a literal to specify seconds, e.g. 30 =
119− -- 30s.
120− , logzIOScribeConfiguration_scheme :: Scheme
121− , logzIOScribeConfiguration_host :: URIBS.Host
122− , logzIOScribeConfiguration_port :: URIBS.Port
123− , logzIOScribeConfiguration_token :: APIToken
124− , logzIOScribeConfiguration_retry :: Retry.RetryPolicyM IO
125− -- ^ How should exceptions during writes be retried?
126− , logzIOScribeConfiguration_onError :: LoggingError -> IO ()
127− }
128−
129−
130−-- | A default configuration:
131−--
132−-- * 100 item buffering
133−--
134−-- * 30 second buffer timeout
135−--
136−-- * US, HTTPS logging endpoint (listener.logz.io:8071)
137−--
138−-- * 'defaultRetryPolicy' of 25ms exponential backoff, 5 retries
139−--
140−-- * Ignore logging errors
141−defaultLogzIOScribeConfiguration :: APIToken -> LogzIOScribeConfiguration
142−defaultLogzIOScribeConfiguration token = LogzIOScribeConfiguration
143− { logzIOScribeConfiguration_bufferItems = 100
144− , logzIOScribeConfiguration_bufferTimeout = 30
145− , logzIOScribeConfiguration_scheme = HTTPS
146− , logzIOScribeConfiguration_host = usRegionHost
147− , logzIOScribeConfiguration_port = httpsPort
148− , logzIOScribeConfiguration_token = token
149− , logzIOScribeConfiguration_retry = defaultRetryPolicy
150− , logzIOScribeConfiguration_onError = const (pure ())
151− }
152−
153−
154−-------------------------------------------------------------------------------
155−-- | You can retrieve your account or sub-account's API token on the
156−-- <https://app.logz.io/#/dashboard/settings/manage-accounts manage
157−-- accounts page>. Note that APIToken has an IsString instance,
158−-- meaning that you can use a string literal with OverloadedStrings
159−-- enabled.
160−newtype APIToken = APIToken
161− { apiToken :: T.Text
162− } deriving (Show, Eq, IsString)
163−
164−
165−-- | This particular bulk API only supports HTTP or HTTPS. HTTPS is
166−-- strongly recommended for security reasons.
167−data Scheme
168− = HTTPS
169− -- ^ HTTPs should always be used except for local testing.
170− | HTTP
171− deriving (Show, Eq)
172−
173−
174−-- | See
175−-- <https://support.logz.io/hc/en-us/articles/210206365-What-IP-addresses-should-I-open-in-my-firewall-to-ship-logs-to-Logz-io-
176−-- this> for a list of listeners. This is the US region host,
177−-- listener.logz.io
178−usRegionHost :: URIBS.Host
179−usRegionHost = URIBS.Host "listener.logz.io"
180−
181−
182−-- | See
183−-- <https://support.logz.io/hc/en-us/articles/210206365-What-IP-addresses-should-I-open-in-my-firewall-to-ship-logs-to-Logz-io-
184−-- this> for a list of listeners. This is the EU region host,
185−-- listener.logz.io
186−euRegionHost :: URIBS.Host
187−euRegionHost = URIBS.Host "listener-eu.logz.io"
188−
189−
190−-- | Logz.io uses port 8071 for HTTPS
191−httpsPort :: URIBS.Port
192−httpsPort = URIBS.Port 8071
193−
194−
195−-- | Logz.io uses port 8070 for HTTP
196−httpPort :: URIBS.Port
197−httpPort = URIBS.Port 8070
198−
199−
200−-- | A reasonable retry policy: exponential backoff with 25ms base
201−-- delay up to 5 retries, for a total cumulative delay of 775ms.
202−defaultRetryPolicy :: (Monad m) => Retry.RetryPolicyM m
203−defaultRetryPolicy = Retry.exponentialBackoff 25000 `mappend` Retry.limitRetries 5
204−
205−-------------------------------------------------------------------------------
206−mkLogzIOScribe
207− :: LogzIOScribeConfiguration
208− -> K.PermitFunc
209− -> K.Verbosity
210− -> IO K.Scribe
211−mkLogzIOScribe config permitItem verbosity = do
212− -- This size is actually somewhat arbitrary. We're just making sure
213− -- it isn't infinite so we don't consume the whole backlog right
214− -- away and take up lots of memory.. Katip above us does bounded
215− -- buffering and load-shedding when there's too much of a
216− -- backlog. Our writes are blocking to apply backpressure up to
217− -- katip. This value just holds onto values temporarily while we
218− -- concatenate them into a buffer.
219− ingestionQueue <- STM.newTBMQueueIO (itemBufferSize * 10)
220−
221− let newTimer = STM.registerDelay itemBufferTimeoutMicros
222− timerRef <- STM.newTVarIO =<< newTimer
223−
224− -- Set up a connection manager for requests
225− mgr <- case scheme of
226− HTTPS -> HTTPS.newTlsManager
227− HTTP -> HTTP.newManager HTTP.defaultManagerSettings
228−
229− -- An STM transaction that will return true when writes are stopped
230− -- and backlog is emptied.
231− let workExhausted :: STM.STM Bool
232− workExhausted = (&&)
233− <$> STM.isClosedTBMQueue ingestionQueue
234− <*> STM.isEmptyTBMQueue ingestionQueue
235− -- Block until there's no more work
236− let waitWorkExhausted :: STM.STM ()
237− waitWorkExhausted = STM.check =<< workExhausted
238− let pop :: STM.STM (Tick AnyLogItem)
239− pop = maybe WorkExhausted NewItem <$> STM.readTBMQueue ingestionQueue
240−
241− let timeExpired :: STM.STM (Tick a)
242− timeExpired = do
243− isExpired <- STM.readTVar =<< STM.readTVar timerRef
244− STM.check isExpired
245− pure TimeExpired
246−
247− -- Circular transaction that checks for completion of work, time
248− -- expiration, or new events.
249− let nextTick :: STM.STM (Tick AnyLogItem)
250− nextTick =
251− timeExpired <|>
252− pop <|>
253− (WorkExhausted <$ waitWorkExhausted)
254−
255− -- Blocking push. This applies backpressure upstream to katip, which does its own buffering
256− let push :: AnyLogItem -> STM.STM ()
257− push = void . STM.writeTBMQueue ingestionQueue
258−
259− let sealQueue = STM.atomically (STM.closeTBMQueue ingestionQueue)
260−
261− -- Replace the timer with a new one
262− let resetTimer = STM.atomically . STM.writeTVar timerRef =<< newTimer
263−
264− -- Send the buffer and then reset the timer
265− let flush curBuffer = do
266− res <- flushBuffer config mgr curBuffer
267− case res of
268− Left e -> onErrorSafe e
269− Right () -> pure ()
270− resetTimer
271−
272− let flushLoop :: BulkBuffer -> IO ()
273− flushLoop curBuffer = do
274− tick <- STM.atomically nextTick
275− case tick of
276− WorkExhausted -> do
277− flush curBuffer -- flush what you've got
278− pure () -- stop looping
279− TimeExpired -> do
280− flush curBuffer
281− flushLoop mempty
282− NewItem (AnyLogItem item) -> do
283− case bufferItem (logzIOScribeConfiguration_bufferItems config) verbosity item curBuffer of
284− Buffered newBuffer -> flushLoop newBuffer
285− FlushNow flushThis newBuffer -> do
286− flush flushThis
287− flushLoop newBuffer
288−
289− flushThread <- Async.async (flushLoop mempty)
290−
291− let close = do
292− sealQueue
293− _ <- Async.waitCatch flushThread
294− pure ()
295−
296− pure $ K.Scribe
297− { K.liPush = STM.atomically . push . AnyLogItem
298− , K.scribeFinalizer = close
299− , K.scribePermitItem = permitItem
300− }
301− where
302− itemBufferSize = logzIOScribeConfiguration_bufferItems config
303− itemBufferTimeoutMicros = ndtToMicros (logzIOScribeConfiguration_bufferTimeout config)
304− scheme = logzIOScribeConfiguration_scheme config
305− onErrorSafe ex = do
306− _ <- EX.tryAny (logzIOScribeConfiguration_onError config ex)
307− pure ()
308−
309−
310−data AnyLogItem where
311− AnyLogItem :: K.LogItem a => K.Item a -> AnyLogItem
312−
313−
314−-------------------------------------------------------------------------------
315−data Tick a =
316− TimeExpired
317− | NewItem !a
318− | WorkExhausted
319−
320−
321−-------------------------------------------------------------------------------
322−-- Match the native resolution of NominalDiffTime, which is excessive
323−-- for our needs
324−ndtPicos :: Time.NominalDiffTime -> Int64
325−ndtPicos = round . (* picos)
326− where
327− picos :: Time.NominalDiffTime
328− picos = 10 ^ (9 :: Int)
329−
330−
331−-------------------------------------------------------------------------------
332−ndtToMicros :: Time.NominalDiffTime -> Int
333−ndtToMicros t = round (((fromIntegral (ndtPicos t)) :: Double) / picosInMicro)
334− where
335− picosInMicro = 10 ^ (3 :: Int)
336−
337−
338−-------------------------------------------------------------------------------
339−data LoggingError =
340− URIError HTTP.HttpException
341− -- ^ The URI generated was invalid. Check your configuration
342− | RequestError HTTP.HttpException
343− -- ^ We encountered an exception while sending the batch request
344− | PartialFailure BulkAPIError
345− -- ^ Some or all of the request was rejected. Check the logz.io UI
346− -- for indexing errors.
347− | BadToken
348− -- ^ Your API token was rejected.
349− | UnknownFailureResponse HTypes.Status LBS.ByteString
350− -- ^ An error returned, but it could not be decoded into a
351− -- 'BulkAPIError'. This may indicate a __library bug__, which should
352− -- be reported to the issue tracker.
353− deriving (Show)
354−
355−-------------------------------------------------------------------------------
356−flushBuffer
357− :: LogzIOScribeConfiguration
358− -> HTTP.Manager
359− -> BulkBuffer
360− -> IO (Either LoggingError ())
361−flushBuffer config mgr bulkBuffer
362− | bulkBuffer_itemCount bulkBuffer <= 0 = pure (Right ())
363− | otherwise = do
364− E.runExceptT $ do
365− req <- E.fmapLT URIError (E.ExceptT (EX.try (configureRequest <$> HTTP.parseRequest uriStr)))
366− resp <- E.fmapLT RequestError $ E.ExceptT $ EX.try $
367− Retry.recovering retryPolicy [\_stat -> EX.Handler handleHttpException] $ \_stat ->
368− HTTP.httpLbs req mgr
369− let respLBS = HTTP.responseBody resp
370− let respStatus = HTTP.responseStatus resp
371− if HTypes.statusIsSuccessful respStatus
372− then pure ()
373− else case A.decode @BulkAPIError respLBS of
374− Nothing
375− | HTypes.statusCode respStatus == 401 -> E.throwE BadToken
376− | otherwise -> E.throwE (UnknownFailureResponse respStatus respLBS)
377− Just bulkError -> E.throwE (PartialFailure bulkError)
378− where
379− configureRequest req = req
380− { HTTP.method = HTypes.methodPost
381− , HTTP.requestBody = HTTP.RequestBodyLBS (BB.toLazyByteString (bulkBuffer_payload bulkBuffer))
382− }
383−
384− retryPolicy = logzIOScribeConfiguration_retry config
385− apiTokenBS = TE.encodeUtf8 (apiToken (logzIOScribeConfiguration_token config))
386−
387− handleHttpException :: (Applicative m) => HTTP.HttpException -> m Bool
388− handleHttpException _ = pure True
389−
390− uriStr = LBS8.unpack (BB.toLazyByteString (URIBS.serializeURIRef uri))
391−
392− authority = URIBS.Authority
393− { URIBS.authorityUserInfo = Nothing
394− , URIBS.authorityHost = logzIOScribeConfiguration_host config
395− , URIBS.authorityPort = Just (logzIOScribeConfiguration_port config)
396− }
397−
398− uri = URIBS.URI
399− { URIBS.uriScheme = case logzIOScribeConfiguration_scheme config of
400− HTTPS -> URIBS.Scheme "https"
401− HTTP -> URIBS.Scheme "http"
402− , URIBS.uriAuthority = Just authority
403− , URIBS.uriPath = "/"
404− , URIBS.uriQuery = URIBS.Query
405− [ ("token", apiTokenBS)
406− ]
407− , URIBS.uriFragment = Nothing
408− }
409−
410−
411−-------------------------------------------------------------------------------
412−newtype Bytes = Bytes
413− { bytes :: Int64
414− } deriving (Show, Eq, Num, Ord, Bounded)
415−
416−
417−-- | How big of a body can we send? The limit is defined
418−-- <https://app.logz.io/#/dashboard/data-sources/Bulk-HTTPS here>.
419−maxPayloadBytes :: Bytes
420−maxPayloadBytes = 10485760
421−
422−
423−-- | How long can each serialized payload be (let's assume including
424−-- the trailing newline). The limit is defined
425−-- <https://app.logz.io/#/dashboard/data-sources/Bulk-HTTPS here>.
426−maxLogLineLength :: Bytes
427−maxLogLineLength = 500000
428−
429−
430−measureJSONLine :: A.ToJSON a => a -> (BB.Builder, Bytes)
431−measureJSONLine a = (BB.lazyByteString lbs, Bytes (LBS.length lbs))
432− where
433− lbs = A.encode a <> "\n"
434−
435−
436−-- | Fully-rendered JSON object for an item
437−fullItemObject :: K.LogItem a => K.Verbosity -> K.Item a -> A.Object
438−fullItemObject verbosity item = HM.fromList
439− [ "app" A..= K._itemApp item
440− , "env" A..= K._itemEnv item
441− , "sev" A..= K._itemSeverity item
442− , "thread" A..= K.getThreadIdText (K._itemThread item)
443− , "host" A..= K._itemHost item
444− , "pid" A..= pidInt
445− , "data" A..= annotateKeys (K.payloadObject verbosity (K._itemPayload item))
446− -- Slight deviation, logz.io uses "message" instead of "msg"
447− , "message" A..= TB.toLazyText (K.unLogStr (K._itemMessage item))
448− -- Another slight deviation, logz.io uses "@timestamp" instead of
449− -- "at". Note, your logs should be sent roughly close to when they
450− -- are created. They are assigned to indexes based on index date, so
451− -- time searches act strange if you backfill too far from the
452− -- past. They seem to support 3 decimal places of
453− -- precision. Formatting like this requires time 1.8.0.2, which is
454− -- reflected in the cabal file.
455− , "@timestamp" A..= A.String (T.pack (Time.formatTime Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%03QZ" (K._itemTime item)))
456− , "ns" A..= K._itemNamespace item
457− , "loc" A..= (LocJs <$> K._itemLoc item)
458− ]
459− where
460− POSIX.CPid pidInt = K._itemProcess item
461−
462−
463−-- | A version of 'renderLine' which renders a line and stays under
464−-- the maximum line size of 500,000 bytes. If the default rendering is
465−-- too large, the log will be reduced to a timestamp and a potentially
466−-- truncated message.
467−renderLineTruncated :: K.LogItem a => K.Verbosity -> K.Item a -> (BB.Builder, Bytes)
468−renderLineTruncated = renderLineTruncated' maxLogLineLength
469−
470−
471−-- | A generalized renderLineTruncated that takes a custom line length
472−-- limit. This is exclusively for testing.
473−renderLineTruncated'
474− :: K.LogItem a
475− => Bytes
476− -- ^ Custom max log line length. Be careful, too low and no amount
477− -- of shrinking can get under the size, breaking the invariant. For
478− -- the production limit, we are guraanteed always able to come in
479− -- under the limit.
480− -> K.Verbosity
481− -> K.Item a
482− -> (BB.Builder, Bytes)
483−renderLineTruncated' customMaxLogLineLength verbosity item =
484− if fullSize <= customMaxLogLineLength
485− then (fullLine, fullSize)
486− else (fallbackLine, fallbackSize)
487− where
488− fullObject = fullItemObject verbosity item
489− (fullLine, fullSize) = measureJSONLine fullObject
490− -- only the absolutely necessary keys, with message stripped out
491− -- to help us calculate how much of the message we can keep. these
492− -- are lazily evaluated and as such won't be computed unless the
493− -- item is too big
494− blankObject :: A.Object
495− blankObject = HM.fromList
496− [ "message" A..= A.String "" -- we'll start with a blank message
497− , "@timestamp" A..= K._itemTime item
498− ]
499− (_, blankObjectSize) = measureJSONLine blankObject
500− messageBytesAllowed = maxLogLineLength - blankObjectSize
501− (fallbackLine, fallbackSize) = measureJSONLine fallbackObject
502− fallbackObject :: A.Object
503− fallbackObject = HM.fromList
504− [ "message" A..= A.toJSON (TL.take (bytes messageBytesAllowed) (TB.toLazyText (K.unLogStr (K._itemMessage item))))
505− , "@timestamp" A..= A.toJSON (K._itemTime item)
506− ]
507−
508−
509−data BulkBuffer = BulkBuffer
510− { bulkBuffer_bytesUsed :: !Bytes
511− , bulkBuffer_payload :: !BB.Builder
512− , bulkBuffer_itemCount :: !Int
513− }
514−
515−
516−instance Semigroup.Semigroup BulkBuffer where
517− (BulkBuffer bytesUsedA bufferA itemCountA) <>
518− (BulkBuffer bytesUsedB bufferB itemCountB) = BulkBuffer
519− (bytesUsedA + bytesUsedB)
520− (bufferA <> bufferB)
521− (itemCountA + itemCountB)
522−
523−
524−instance Monoid BulkBuffer where
525− mempty = BulkBuffer 0 mempty 0
526− mappend = (<>)
527−
528−
529−data LogAction buf =
530− Buffered
531− buf
532− -- ^ New buffer
533− | FlushNow
534− buf
535− -- ^ Buffer to flush
536− buf
537− -- ^ New buffer
538−
539−bufferItem
540− :: K.LogItem a
541− => Int
542− -- ^ Maximum items before flushing
543− -> K.Verbosity
544− -> K.Item a
545− -> BulkBuffer
546− -> LogAction BulkBuffer
547−bufferItem = bufferItem' maxPayloadBytes maxLogLineLength
548−
549−
550−-- | An internal version with a configurable max item size and max
551−-- message size for testing. Be careful with this: if you set the
552−-- values too low, some of the guarantees about reducability of
553−-- messages break down.
554−bufferItem'
555− :: (K.LogItem a)
556− => Bytes
557− -- ^ Max payload size
558− -> Bytes
559− -- ^ Max item size
560− -> Int
561− -- ^ Maximum items before flushing
562− -> K.Verbosity
563− -> K.Item a
564− -> BulkBuffer
565− -> LogAction BulkBuffer
566−bufferItem' customMaxPayload customMaxItem maxItems verb item bulkBuffer =
567− let (encodedLine, spaceNeeded) = renderLineTruncated' customMaxItem verb item
568− newBytesUsed = bulkBuffer_bytesUsed bulkBuffer + spaceNeeded
569− newItemCount = bulkBuffer_itemCount bulkBuffer + 1
570− in if newItemCount >= maxItems || newBytesUsed >= customMaxPayload
571− then FlushNow
572− bulkBuffer
573− BulkBuffer
574− { bulkBuffer_bytesUsed = spaceNeeded
575− , bulkBuffer_payload = encodedLine
576− , bulkBuffer_itemCount = 1
577− }
578− else Buffered $
579− BulkBuffer
580− { bulkBuffer_bytesUsed = newBytesUsed
581− , bulkBuffer_payload = bulkBuffer_payload bulkBuffer <> encodedLine
582− , bulkBuffer_itemCount = newItemCount
583− }
584−
585−
586−-- | When time has run out on a flush, splits the buffer. n.b. this
587−-- will always return 'FlushNow' with an empty new buffer.
588−forceFlush :: (Monoid buf) => buf -> LogAction buf
589−forceFlush buf = FlushNow buf mempty
590−
591−
592−-------------------------------------------------------------------------------
593−-- Annotation borrowed from katip-elasticsearch. There are fixed
594−-- fields in katip logs which should stay the same type forever and
595−-- thus won't need annotation. However, any code in userland may
596−-- choose to add akey to their log's metadata with a type that's
597−-- incompatible with the mapping. If the first value that's picked up
598−-- restrictive (e.g. a long), subsequent values will be rejected. By
599−-- differentiating types by their name, this is guaranteed not to
600−-- happen.
601−
602−annotateValue :: A.Value -> A.Value
603−annotateValue (A.Object o) = A.Object (annotateKeys o)
604−annotateValue (A.Array a) = A.Array (annotateValue <$> a)
605−annotateValue x = x
606−
607−
608−annotateKeys :: A.Object -> A.Object
609−annotateKeys = HM.fromList . map go . HM.toList
610− where
611− go (k, A.Object o) = (k, A.Object (annotateKeys o))
612− go (k, A.Array a) = (k, A.Array (annotateValue <$> a))
613− go (k, s@(A.String _)) = (k <> stringAnn, s)
614− go (k, n@(A.Number sci)) = if Scientific.isFloating sci
615− then (k <> doubleAnn, n)
616− else (k <> longAnn, n)
617− go (k, b@(A.Bool _)) = (k <> booleanAnn, b)
618− go (k, A.Null) = (k <> nullAnn, A.Null)
619−
620−
621−-------------------------------------------------------------------------------
622−-- Annotation Constants
623−-------------------------------------------------------------------------------
624−
625−
626−stringAnn :: T.Text
627−stringAnn = "::s"
628−
629−doubleAnn :: T.Text
630−doubleAnn = "::d"
631−
632−longAnn :: T.Text
633−longAnn = "::l"
634−
635−booleanAnn :: T.Text
636−booleanAnn = "::b"
637−
638−nullAnn :: T.Text
639−nullAnn = "::n"
katip-logzio/test/Katip/Tests/Scribes/LogzIO/HTTPS.hsdeleted−466
@@ -1,466 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Katip.Tests.Scribes.LogzIO.HTTPS
3− ( tests
4− ) where
5−
6−
7−-------------------------------------------------------------------------------
8−import Control.Concurrent.Async
9−import Control.Concurrent.STM
10−import Control.Concurrent.STM.TSem
11−import Control.Exception.Safe
12−import Control.Monad
13−import Control.Monad.IO.Class
14−import Data.Aeson as A
15−import qualified Data.ByteString.Builder as BB
16−import qualified Data.ByteString.Lazy as LBS
17−import qualified Data.ByteString.Lazy.Char8 as LBS8
18−import qualified Data.HashMap.Strict as HM
19−import Data.Int
20−import Data.Scientific
21−import Data.Text (Text)
22−import Data.Time
23−import Data.Time.Clock.POSIX
24−import qualified Data.Vector as V
25−import Hedgehog as HH
26−import qualified Hedgehog.Gen as Gen
27−import qualified Hedgehog.Range as Range
28−import Katip
29−import Katip.Core
30−import Language.Haskell.TH (Loc (..))
31−import Network.HostName
32−import qualified Network.HTTP.Types.Status as HTypes
33−import qualified Network.Wai.Handler.Warp as Warp
34−import System.Posix
35−import System.Timeout
36−import Test.Tasty
37−import Test.Tasty.Hedgehog
38−import Test.Tasty.HUnit
39−import URI.ByteString
40−import qualified Web.Scotty as Scotty
41−-------------------------------------------------------------------------------
42−import Katip.Scribes.LogzIO.HTTPS
43−-------------------------------------------------------------------------------
44−
45−
46−tests :: TestTree
47−tests = testGroup "Katip.Scribes.LogzIO.HTTP"
48− [ bufferItemTests
49− , renderLineTruncatedTests
50− , scribeTests
51− ]
52−
53−
54−-------------------------------------------------------------------------------
55−-- We bind to a system port so we use a lock on these tests to avoid interleaved, concurrent requests
56−scribeTests :: TestTree
57−scribeTests = withLock $ \mkSem -> testGroup "scribe"
58− [ testCase "writes well-formed log items as lines to the given API" $ do
59− sem <- mkSem
60− withServer sem $ \receivedMessages -> do
61− withScribe (\cfg -> cfg { logzIOScribeConfiguration_bufferTimeout = 1}) $ \scribe -> do
62− (liPush scribe) (genericLog "a message")
63−
64− requestLog <- timeoutFailure (20 * second) (atomically (readTQueue receivedMessages))
65− requestLog_token requestLog @?= testAPIToken
66− let logs = requestLog_logs requestLog
67− length logs @?= 1
68− let firstLog = head logs
69− receivedLog_message firstLog @?= "a message"
70− , testCase "respects the items limit" $ do
71− sem <- mkSem
72− withServer sem $ \receivedMessages -> do
73− withScribe (\cfg -> cfg { logzIOScribeConfiguration_bufferItems = 1, logzIOScribeConfiguration_bufferTimeout = 1}) $ \scribe -> do
74− (liPush scribe) (genericLog "message 1")
75− (liPush scribe) (genericLog "message 2")
76−
77− log1 <- timeoutFailure (20 * second) (atomically (readTQueue receivedMessages))
78− requestLog_token log1 @?= testAPIToken
79− let logs1 = requestLog_logs log1
80− length logs1 @?= 1
81− let firstLog1 = head logs1
82− receivedLog_message firstLog1 @?= "message 1"
83−
84− log2 <- timeoutFailure (20 * second) (atomically (readTQueue receivedMessages))
85− let logs2 = requestLog_logs log2
86− length logs2 @?= 1
87− let firstLog2 = head logs2
88− receivedLog_message firstLog2 @?= "message 2"
89− , testCase "respects the time limit" $ do
90− sem <- mkSem
91− withServer sem $ \receivedMessages -> do
92− withScribe (\cfg -> cfg { logzIOScribeConfiguration_bufferItems = 2, logzIOScribeConfiguration_bufferTimeout = 1}) $ \scribe -> do
93− (liPush scribe) (genericLog "a message")
94− log1 <- timeoutFailure (20 * second) (atomically (readTQueue receivedMessages))
95− requestLog_token log1 @?= testAPIToken
96− let logs1 = requestLog_logs log1
97− length logs1 @?= 1
98− let firstLog1 = head logs1
99− receivedLog_message firstLog1 @?= "a message"
100− , testCase "reports errors" $ do
101− sem <- mkSem
102− let badToken = APIToken "badtoken"
103− errorSignal <- newEmptyTMVarIO
104− withServer sem $ \_receivedMessages -> do
105− withScribe (\cfg -> cfg { logzIOScribeConfiguration_bufferItems = 1, logzIOScribeConfiguration_bufferTimeout = 1, logzIOScribeConfiguration_token = badToken, logzIOScribeConfiguration_onError = void . atomically . tryPutTMVar errorSignal}) $ \scribe -> do
106− (liPush scribe) (genericLog "a message")
107− loggingError <- timeoutFailure (20 * second) (atomically (takeTMVar errorSignal))
108− case loggingError of
109− BadToken -> pure ()
110− _ -> assertFailure ("Expected BadToken error but got " <> show loggingError)
111− , testCase "flushes all queued logs on close" $ do
112− sem <- mkSem
113− withServer sem $ \receivedMessages -> do
114− withScribe (\cfg -> cfg { logzIOScribeConfiguration_bufferItems = 100, logzIOScribeConfiguration_bufferTimeout = 100}) $ \scribe -> do
115− (liPush scribe) (genericLog "message 1")
116− (liPush scribe) (genericLog "message 2")
117− messages <- atomically (flushTQueue receivedMessages)
118− let allLogs = receivedLog_message <$> mconcat (requestLog_logs <$> messages)
119− allLogs @?= ["message 1", "message 2"]
120− ]
121− where
122− second = 1000000
123− timeoutFailure waitTime f = do
124− res <- timeout waitTime f
125− case res of
126− Nothing -> assertFailure ("Operation timed out after " <> show waitTime <> "us")
127− Just x -> pure x
128− withLock = withResource (atomically (newTSem 1)) (const (return ()))
129− withServer sem f = bracket_ (atomically (waitTSem sem)) (atomically (signalTSem sem)) $ do
130− receivedMessages <- atomically newTQueue
131− withAsync (startServer receivedMessages) $ \_async -> f receivedMessages
132− testAPIToken = "bigSECRET"
133− genericLog message = Item
134− { _itemApp = "katip-logzio"
135− , _itemEnv = "test"
136− , _itemSeverity = InfoS
137− , _itemThread = ThreadIdText "42"
138− , _itemHost = "localhost"
139− , _itemProcess = 111
140− , _itemPayload = ()
141− , _itemMessage = message
142− , _itemTime = mkUTCTime 2019 1 2 3 4 5
143− , _itemNamespace = "test"
144− , _itemLoc = Nothing
145− }
146− startServer receivedMessages = Scotty.scottyOpts serverOpts $ do
147− Scotty.post "/" $ do
148− token <- APIToken <$> Scotty.param "token"
149− if token == testAPIToken
150− then do
151− bodyLines <- LBS8.lines <$> Scotty.body
152− receivedLogs <- mapM (either error pure . A.eitherDecode) bodyLines
153− let requestLog = RequestLog
154− { requestLog_token = token
155− , requestLog_logs = receivedLogs
156− }
157− liftIO (atomically (writeTQueue receivedMessages requestLog))
158− else Scotty.status HTypes.unauthorized401
159− serverOpts = Scotty.Options
160− { Scotty.verbose = 0
161− , Scotty.settings = Warp.setPort 1337 Warp.defaultSettings
162− }
163− withScribe modConfig =
164− bracket (mkLogzIOScribe (modConfig scribeConfig) (const (pure True)) V3) scribeFinalizer
165− scribeConfig = LogzIOScribeConfiguration
166− { logzIOScribeConfiguration_bufferItems = 5
167− , logzIOScribeConfiguration_bufferTimeout = 10
168− , logzIOScribeConfiguration_scheme = HTTP
169− , logzIOScribeConfiguration_host = Host "127.0.0.1"
170− , logzIOScribeConfiguration_port = Port 1337
171− , logzIOScribeConfiguration_token = testAPIToken
172− , logzIOScribeConfiguration_retry = defaultRetryPolicy
173− , logzIOScribeConfiguration_onError = const (pure ())
174− }
175−
176−
177−
178−data RequestLog = RequestLog
179− { requestLog_token :: APIToken
180− , requestLog_logs :: [ReceivedLog]
181− }
182−
183−
184−-- | Simplified log that only parses the fields we want to assert on
185−data ReceivedLog = ReceivedLog
186− { receivedLog_message :: Text
187− }
188−
189−
190−instance FromJSON ReceivedLog where
191− parseJSON = withObject "ReceivedLog" $ \o -> do
192− message <- o .: "message"
193− pure $ ReceivedLog
194− { receivedLog_message = message
195− }
196−
197−
198−-------------------------------------------------------------------------------
199−bufferItemTests :: TestTree
200−bufferItemTests = testGroup "bufferItem"
201− [ testProperty "0 or negative maximum items always flushes immediately" $ property $ do
202− item <- forAllWith showSimplePayloadItem genSimplePayloadItem
203− verbosity <- forAll genVerbosity
204− maxItems <- forAll (Gen.int (Range.linear minBound 0))
205− bulkBuffer <- forAllWith inspectBulkBuffer genBulkBuffer
206− let logAction = bufferItem' reducedMaxPayloadBytes reducedMaxLogLineLength maxItems verbosity item bulkBuffer
207− assertFlushNow logAction
208− , testProperty "never buffers too many items" $ property $ do
209− item <- forAllWith showSimplePayloadItem genSimplePayloadItem
210− verbosity <- forAll genVerbosity
211− maxItems <- forAll (Gen.int (Range.linear 0 100))
212− bulkBuffer <- forAllWith inspectBulkBuffer genBulkBuffer
213− let logAction = bufferItem' reducedMaxPayloadBytes reducedMaxLogLineLength maxItems verbosity item bulkBuffer
214− case logAction of
215− Buffered newBuffer -> HH.assert (bulkBuffer_itemCount newBuffer <= maxItems)
216− _ -> pure ()
217− , testProperty "never produces too many bytes" $ property $ do
218− item <- forAllWith showSimplePayloadItem genSimplePayloadItem
219− verbosity <- forAll genVerbosity
220− maxItems <- forAll (Gen.int (Range.linear 0 100))
221− bulkBuffer <- forAllWith inspectBulkBuffer genBulkBuffer
222− let logAction = bufferItem' reducedMaxPayloadBytes reducedMaxLogLineLength maxItems verbosity item bulkBuffer
223− case logAction of
224− Buffered newBuffer -> HH.assert (bulkBuffer_bytesUsed newBuffer <= reducedMaxPayloadBytes)
225− _ -> pure ()
226− , testProperty "never flushes more than 1 item" $ property $ do
227− item <- forAllWith showSimplePayloadItem genSimplePayloadItem
228− verbosity <- forAll genVerbosity
229− maxItems <- forAll (Gen.int (Range.linear minBound 0))
230− bulkBuffer <- forAllWith inspectBulkBuffer genBulkBuffer
231− let logAction = bufferItem' reducedMaxPayloadBytes reducedMaxLogLineLength maxItems verbosity item bulkBuffer
232− case logAction of
233− FlushNow _ newBuffer -> bulkBuffer_itemCount newBuffer === 1
234− _ -> pure ()
235− , testProperty "flushes when the buffer is exactly at the limit" $ property $ do
236− maxItems <- forAll (Gen.int (Range.linear 1 20))
237− item <- forAllWith showSimplePayloadItem genSimplePayloadItem
238− bulkBuffer <- forAllWith inspectBulkBuffer ((\b -> b { bulkBuffer_itemCount = maxItems - 1 }) <$> genBulkBuffer)
239− verbosity <- forAll genVerbosity
240− let logAction = bufferItem' maxBound maxBound maxItems verbosity item bulkBuffer
241− case logAction of
242− FlushNow _ _ -> pure ()
243− Buffered _ -> fail "Expected a FlushNow but got a Buffered"
244− ]
245− where
246− assertFlushNow (FlushNow _ _) = pure ()
247− assertFlushNow (Buffered _) = fail ("Expceted FlushNow but got a Buffered")
248− inspectBulkBuffer (BulkBuffer used _ itemCount) =
249− "BulkBuffer (" <> show used <> ") ... " <> show itemCount
250−
251−
252−-------------------------------------------------------------------------------
253−-- | Reduced max log line length for more space and time efficient tests
254−reducedMaxLogLineLength :: Bytes
255−reducedMaxLogLineLength = Bytes (bytes maxLogLineLength `div` limitScalingFactor)
256−
257−
258−reducedMaxPayloadBytes :: Bytes
259−reducedMaxPayloadBytes = Bytes (bytes maxPayloadBytes `div` limitScalingFactor)
260−
261−
262−limitScalingFactor :: Int64
263−limitScalingFactor = 10
264−
265−-------------------------------------------------------------------------------
266−showSimplePayloadItem :: Item SimpleLogPayload -> String
267−showSimplePayloadItem item =
268− show (item { _itemPayload = [(k, toJSON v) | (k, AnyLogPayload v) <- unSimpleLogPayload (_itemPayload item)]})
269−
270−
271−-------------------------------------------------------------------------------
272−renderLineTruncatedTests :: TestTree
273−renderLineTruncatedTests = testGroup "renderLineTruncated"
274− [ testProperty "always produces an accurate byte count" $ property $ do
275− item <- forAllWith showSimplePayloadItem genSimplePayloadItem
276− verbosity <- forAll genVerbosity
277− let (builder, Bytes byteCount) = renderLineTruncated' reducedMaxLogLineLength verbosity item
278− builderLength builder === byteCount
279− , testProperty "always produces a payload smaller than the line limit" $ property $ do
280− let tinyMaxLineLength = 1024 -- set a really low one for speed
281− let lowerBound = fromIntegral (bytes tinyMaxLineLength - 100)
282− let upperBound = fromIntegral (bytes tinyMaxLineLength + 100)
283− bigMessage <- forAll (genLogStr' (Range.linear lowerBound upperBound))
284− item <- (\item -> item { _itemMessage = bigMessage}) <$> forAllWith showSimplePayloadItem genSimplePayloadItem
285− verbosity <- forAll genVerbosity
286− let (_, byteCount) = renderLineTruncated' tinyMaxLineLength verbosity item
287− HH.assert (byteCount <= reducedMaxLogLineLength)
288− ]
289−
290−
291−-------------------------------------------------------------------------------
292−builderLength :: BB.Builder -> Int64
293−builderLength = LBS.length . BB.toLazyByteString
294−
295−-------------------------------------------------------------------------------
296−genVerbosity :: Gen Verbosity
297−genVerbosity = Gen.enumBounded
298−
299−
300−-------------------------------------------------------------------------------
301−genBulkBuffer :: Gen BulkBuffer
302−genBulkBuffer = do
303− bytesUsed <- genBytes
304− -- generating a large bytestring string with hedghog seems quite slow, instead we'll generate a smaller string and replicate and merge it
305− payloadMultiplier <- Gen.int (Range.linear 1 100)
306− payloadSegment <- genBuilder (Range.linear 0 (round (toRational (bytes reducedMaxPayloadBytes) * 0.05)))
307− let payload = mconcat (replicate payloadMultiplier payloadSegment)
308− itemCount <- Gen.int (Range.linear 0 maxBound)
309− pure $ BulkBuffer
310− { bulkBuffer_bytesUsed = bytesUsed
311− , bulkBuffer_payload = payload
312− , bulkBuffer_itemCount = itemCount
313− }
314−
315−
316−-------------------------------------------------------------------------------
317−genBytes :: Gen Bytes
318−genBytes = Bytes <$> Gen.int64 (Range.linear 0 maxBound)
319−
320−
321−-------------------------------------------------------------------------------
322−genBuilder :: Range Int -> Gen BB.Builder
323−genBuilder size = BB.byteString <$> Gen.bytes size
324−
325−
326−-------------------------------------------------------------------------------
327−genSimplePayloadItem :: Gen (Item SimpleLogPayload)
328−genSimplePayloadItem = do
329− app <- genNamespace
330− env <- genEnvironment
331− severity <- genSeverity
332− thread <- genThreadIdText
333− host <- genHostName
334− process <- genProcessID
335− payload <- genSimpleLogPayload
336− message <- genLogStr
337− time <- genUTCTime
338− namespace <- genNamespace
339− loc <- Gen.maybe genLoc
340− pure $ Item
341− { _itemApp = app
342− , _itemEnv = env
343− , _itemSeverity = severity
344− , _itemThread = thread
345− , _itemHost = host
346− , _itemProcess = process
347− , _itemPayload = payload
348− , _itemMessage = message
349− , _itemTime = time
350− , _itemNamespace = namespace
351− , _itemLoc = loc
352− }
353−
354−
355−genNamespace :: Gen Namespace
356−genNamespace = Namespace <$> Gen.list (Range.linear 0 20) genSmallText
357−
358−
359−genEnvironment :: Gen Environment
360−genEnvironment = Environment <$> genSmallText
361−
362−
363−genSeverity :: Gen Severity
364−genSeverity = Gen.enumBounded
365−
366−
367−genThreadIdText :: Gen ThreadIdText
368−genThreadIdText = ThreadIdText <$> genSmallText
369−
370−
371−genHostName :: Gen HostName
372−genHostName = genSmallString
373−
374−
375−genProcessID :: Gen ProcessID
376−genProcessID = Gen.enumBounded
377−
378−
379−genLogStr :: Gen LogStr
380−genLogStr = genLogStr' (Range.linear 0 1024)
381−
382−
383−genLogStr' :: Range Int -> Gen LogStr
384−genLogStr' sizeRange = ls <$> Gen.text sizeRange Gen.unicode
385−
386−
387−genUTCTime :: Gen UTCTime
388−genUTCTime = posixSecondsToUTCTime . fromIntegral
389− <$> Gen.int (Range.linear 0 maxBound)
390−
391−
392−genLoc :: Gen Loc
393−genLoc = Loc
394− <$> genSmallString
395− <*> genSmallString
396− <*> genSmallString
397− <*> genCharPos
398− <*> genCharPos
399− where
400− genCharPos = (,)
401− <$> Gen.int (Range.linear 0 maxBound)
402− <*> Gen.int (Range.linear 0 maxBound)
403−
404−
405−genSimpleLogPayload :: Gen SimpleLogPayload
406−genSimpleLogPayload = SimpleLogPayload
407− <$> Gen.list (Range.linear 0 20) genPair
408− where
409− genPair = (,)
410− <$> genSmallText
411− <*> genAnyLogPayload
412−
413−
414−genAnyLogPayload :: Gen AnyLogPayload
415−genAnyLogPayload = AnyLogPayload
416− <$> genValue
417−
418−
419−genValue :: Gen Value
420−genValue = Gen.recursive Gen.choice nonRecursiveGens recursiveGens
421− where
422− nonRecursiveGens =
423− [ pure A.Null
424− , A.String <$> genSmallText
425− , A.Number <$> genScientific
426− , A.Bool <$> Gen.bool
427− ]
428− recursiveGens =
429− [ A.Object <$> genObject
430− , A.Array <$> genArray
431− ]
432− genObject = HM.fromList <$> Gen.list (Range.linear 0 20) genPair
433− where
434− genPair = (,) <$> genSmallText <*> genValue
435− genArray = V.fromList <$>
436− Gen.list (Range.linear 0 20) genValue
437−
438−
439−
440−genScientific :: Gen Scientific
441−genScientific = scientific
442− <$> Gen.integral (Range.linear (-999999) 999999)
443− <*> Gen.int (Range.linear (-999) (999))
444−
445−
446−genSmallText :: Gen Text
447−genSmallText = Gen.text (Range.linear 0 128) Gen.unicode
448−
449−
450−genSmallString :: Gen String
451−genSmallString = Gen.string (Range.linear 0 128) Gen.unicode
452−
453−
454−-------------------------------------------------------------------------------
455−mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime
456−mkUTCTime y m d hr mn s = UTCTime day dt
457− where
458− day = mkDay y m d
459− dt = s + 60 * mn + 60 * 60 * hr
460−
461−
462−-------------------------------------------------------------------------------
463−mkDay :: Integer -> Int -> Int -> Day
464−mkDay y m d = day
465− where
466− Just day = fromGregorianValid y m d
katip-logzio/test/Main.hsdeleted−22
@@ -1,22 +0,0 @@
1−module Main
2− ( main
3− ) where
4−
5−
6−-------------------------------------------------------------------------------
7−import Test.Tasty
8−-------------------------------------------------------------------------------
9−import qualified Katip.Tests.Scribes.LogzIO.HTTPS
10−-------------------------------------------------------------------------------
11−
12−
13−
14−main :: IO ()
15−main = defaultMain tests
16−
17−
18−-------------------------------------------------------------------------------
19−tests :: TestTree
20−tests = testGroup "katip-logzio"
21− [ Katip.Tests.Scribes.LogzIO.HTTPS.tests
22− ]
katip/README.md+1−4
@@ -16,7 +16,7 @@ Kâtip (pronounced kah-tip) is the Turkish word for scribe.
16 add context that will be automatically merged in with existing log
16 add context that will be automatically merged in with existing log
17 context.
17 context.
18
18
19−* *Easy Integration:* Katip was designed to be easily integrated
19+* *Easy to Integration:* Katip was designed to be easily integrated
20 into existing monads. By using typeclasses for logging facilities,
20 into existing monads. By using typeclasses for logging facilities,
21 individual subsystems and even libraries can easily add their own
21 individual subsystems and even libraries can easily add their own
22 namespacing and context without having any knowledge of their
22 namespacing and context without having any knowledge of their
@@ -84,6 +84,3 @@ stack.
84* [Leonid Onokhov](https://github.com/sopvop)
84* [Leonid Onokhov](https://github.com/sopvop)
85* [Alexander Vershilov](https://github.com/qnikst)
85* [Alexander Vershilov](https://github.com/qnikst)
86* [Chris Martin](https://github.com/chris-martin)
86* [Chris Martin](https://github.com/chris-martin)
87−* [Domen Kožar](https://github.com/domenkozar)
88−* [Tristan Bull](https://github.com/tmbull)
89−* [Aleksey Khudyakov](https://github.com/Shimuuar)
katip/bench/Main.hs+2−5
@@ -92,7 +92,7 @@ setup dest = do
92 return (tmp </> "katip-bench.log")
92 return (tmp </> "katip-bench.log")
93 DevNull -> return ("/dev/null")
93 DevNull -> return ("/dev/null")
94 h <- openFile outFile WriteMode
94 h <- openFile outFile WriteMode
95− s <- mkHandleScribe ColorIfTerminal h (permitItem DebugS) V0
95+ s <- mkHandleScribe ColorIfTerminal h DebugS V0
96 let cleanupHandle = hClose h `finally` (when (dest == TempFile) (removeLink outFile))
96 let cleanupHandle = hClose h `finally` (when (dest == TempFile) (removeLink outFile))
97 return s { scribeFinalizer = scribeFinalizer s `finally` cleanupHandle}
97 return s { scribeFinalizer = scribeFinalizer s `finally` cleanupHandle}
98
98
@@ -101,7 +101,4 @@ setup dest = do
101deriving instance NFData ThreadIdText
101deriving instance NFData ThreadIdText
102
102
103instance NFData Scribe where
103instance NFData Scribe where
104− rnf (Scribe a b p) = (a :: Item ExPayload -> IO ())
104+ rnf (Scribe a b) = (a :: Item ExPayload -> IO ()) `seq` b `seq` ()
105− `seq` b
106− `seq` (p :: Item ExPayload -> IO Bool)
107− `seq` ()
katip/changelog.md−58
@@ -1,61 +1,3 @@
1−0.8.5.0
2−=======
3−* Add MonadResource instances [#121](https://github.com/Soostone/katip/pull/121)
4−
5−0.8.4.0
6−=======
7−* Add support for unliftio-core 0.2 while maintaining backwards-compatible support for 0.1
8−
9−0.8.3.0
10−=======
11−
12−* Add `logKatipItem` function and reimplement `logItem` to use it. [vlatkoB](https://github.com/vlatkoB)
13−
14−0.8.2.0
15−=======
16−* Add `MonadFail` instances for `base` >= 4.9.0.0 [Koray Al](https://github.com/korayal)
17−
18−0.8.1.0
19−=======
20−* Export `logLoc`. Credit to [Brian McKenna](https://github.com/puffnfresh)
21−
22−0.8.0.0
23−=======
24−* **Breaking change**: switch from severity based log level filtering to
25− user-definable `PermitFunc`. To upgrade, any time you initialize one
26− of the standard scribes, rather than providing a severity like
27− `InfoS`, instead pass in `(permitItem InfoS)`. Credit to
28− [vlatkoB](https://github.com/vlatkoB).
29−* Update some misformatted and outdated docs.
30−* Set lower bound of base to 4.9.0.0, the version shipped with GHC
31− 8.0.2. Support for GHC versions older than that is removed.
32−* Update default formatter of Handle scribe to format pid as `[PID
33− 1234]` instead of `[1234]` and `[ThreadId 1234]` instead of
34− `[1234]`.
35−* Add missing `Bounded` instance for `Verbosity`. This allows you to
36− easily enumerate all verbosities via `[minBound..maxBound]`.
37−
38−0.7.0.0
39−=======
40−* Exclusively use HasCallstack for location reporting in errors. Credit to [Domen Kožar](https://github.com/domenkozar)
41−* Drop support for GHC 7.x
42−
43−0.6.3.0
44−=======
45−* Add `ToJSON`/`FromJSON` instances for Verbosity. Credit to [Aleksey Khudyakov](https://github.com/Shimuuar).
46−
47−0.6.2.1
48−=======
49−* Add `mkHandleScribeWithFormatter`. This allows control over the format of log items going to a handle. Credit to [Tristan Bull](https://github.com/tmbull) for the implementation.
50−* Documentation fixes. Credit to [Domen Kožar](https://github.com/domenkozar) for the implementation.
51−* Add `jsonFormat` handle formatter.
52−* Deprecate `formatItem` which is now replaced by `bracketFormat`.
53−
54−0.6.1.0
55−=======
56−* Loosen deps
57−* Support latest STM
58−
590.6.0.0
10.6.0.0
60=======
2=======
61* Drop ListT instance due to deprecations.
3* Drop ListT instance due to deprecations.
katip/examples/example.hs+1−1
@@ -36,7 +36,7 @@ main = do
36 -- hot-swap scribes at runtime if you need to. 'closeScribes' is
36 -- hot-swap scribes at runtime if you need to. 'closeScribes' is
37 -- blocking and flushes all messages out of a scribe and cleans up
37 -- blocking and flushes all messages out of a scribe and cleans up
38 -- resources that were allocated at creation.
38 -- resources that were allocated at creation.
39− handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2
39+ handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2
40 let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"
40 let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"
41 bracket mkLogEnv closeScribes $ \le -> do
41 bracket mkLogEnv closeScribes $ \le -> do
42 let s = MyState M.mempty mempty le
42 let s = MyState M.mempty mempty le
katip/examples/example_lens.hs+1−1
@@ -51,7 +51,7 @@ main = do
51 -- hot-swap scribes at runtime if you need to. 'closeScribes' is
51 -- hot-swap scribes at runtime if you need to. 'closeScribes' is
52 -- blocking and flushes all messages out of a scribe and cleans up
52 -- blocking and flushes all messages out of a scribe and cleans up
53 -- resources that were allocated at creation.
53 -- resources that were allocated at creation.
54− handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2
54+ handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2
55 let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"
55 let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"
56 bracket mkLogEnv closeScribes $ \le -> do
56 bracket mkLogEnv closeScribes $ \le -> do
57 let s = MyState M.mempty mempty le
57 let s = MyState M.mempty mempty le
katip/katip.cabal+24−24
@@ -1,5 +1,5 @@
1name: katip
1name: katip
2−version: 0.8.5.0
2+version: 0.6.0.0
3synopsis: A structured logging framework.
3synopsis: A structured logging framework.
4description:
4description:
5 Katip is a structured logging framework. See README.md for more details.
5 Katip is a structured logging framework. See README.md for more details.
@@ -25,7 +25,7 @@ extra-source-files:
25 test/Katip/Tests/Scribes/Handle.hs
25 test/Katip/Tests/Scribes/Handle.hs
26 test/Katip/Tests/Scribes/Handle-text.golden
26 test/Katip/Tests/Scribes/Handle-text.golden
27 test/Katip/Tests/Format/Time.hs
27 test/Katip/Tests/Format/Time.hs
28−tested-with: GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.3
28+tested-with: GHC == 7.8.4, GHC== 7.10.3
29
29
30source-repository head
30source-repository head
31 type: git
31 type: git
@@ -53,32 +53,32 @@ library
53 TemplateHaskell
53 TemplateHaskell
54 OverloadedStrings
54 OverloadedStrings
55
55
56− build-depends: base >=4.9.0.0 && <5
56+ build-depends: base >=4.5 && <5
57 , aeson >=0.6
57 , aeson >=0.6
58 , async < 3.0.0.0
58 , async < 3.0.0.0
59− , auto-update >= 0.1
59+ , auto-update >= 0.1 && < 0.2
60− , bytestring >= 0.9
60+ , bytestring >= 0.9 && < 0.11
61− , containers >=0.4
61+ , containers >=0.4 && <0.6
62− , either >= 4
62+ , either >= 4 && < 5.1
63 , safe-exceptions >= 0.1.0.0
63 , safe-exceptions >= 0.1.0.0
64− , hostname >=1.0
64+ , hostname >=1.0 && <1.1
65− , old-locale >= 1.0
65+ , old-locale >= 1.0 && < 1.1
66− , string-conv >= 0.1
66+ , string-conv >= 0.1 && < 0.2
67− , template-haskell >= 2.8
67+ , template-haskell >= 2.8 && < 2.14
68− , text >= 0.11
68+ , text >= 0.11 && <1.3
69− , time >= 1
69+ , time >= 1 && < 1.9
70− , transformers >= 0.3
70+ , transformers >= 0.3 && < 0.6
71 , transformers-compat
71 , transformers-compat
72− , unordered-containers >= 0.2
72+ , unordered-containers >= 0.2 && < 0.3
73− , monad-control >= 1.0
73+ , monad-control >= 1.0 && < 1.1
74− , mtl >= 2.0
74+ , mtl >= 2.0 && < 2.3
75− , transformers-base >= 0.3
75+ , transformers-base >= 0.3 && < 0.6
76− , resourcet >= 1.1
76+ , resourcet >= 1.1 && < 1.3
77 , scientific >= 0.3.3.0
77 , scientific >= 0.3.3.0
78− , microlens >= 0.2.0.0
78+ , microlens >= 0.2.0.0 && < 0.5
79− , microlens-th >= 0.1.0.0
79+ , microlens-th >= 0.1.0.0 && < 0.5
80 , semigroups
80 , semigroups
81− , unliftio-core >= 0.1
81+ , unliftio-core >= 0.1 && < 0.2
82 , stm >= 2.4
82 , stm >= 2.4
83
83
84 hs-source-dirs: src
84 hs-source-dirs: src
@@ -87,7 +87,7 @@ library
87 if flag(lib-Werror)
87 if flag(lib-Werror)
88 ghc-options: -Werror
88 ghc-options: -Werror
89 if os(windows)
89 if os(windows)
90− build-depends: Win32 >=2.3 && <2.9
90+ build-depends: Win32 >=2.3 && <2.6
91 exposed-modules: Katip.Compat
91 exposed-modules: Katip.Compat
92 else
92 else
93 build-depends: unix >= 2.5 && <2.8
93 build-depends: unix >= 2.5 && <2.8
@@ -114,7 +114,7 @@ test-suite test
114 , template-haskell
114 , template-haskell
115 , text
115 , text
116 , time
116 , time
117− , time-locale-compat >= 0.1.0.1
117+ , time-locale-compat >= 0.1.0.1 && < 0.2
118 , directory
118 , directory
119 , regex-tdfa
119 , regex-tdfa
120 , unordered-containers
120 , unordered-containers
katip/src/Katip.hs+4−10
@@ -11,8 +11,8 @@
11--
11--
12-- main :: IO ()
12-- main :: IO ()
13-- main = do
13-- main = do
14−-- handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2
14+-- handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2
15−-- let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv \"MyApp\" \"production\"
15+-- let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"
16-- -- closeScribes will stop accepting new logs, flush existing ones and clean up resources
16-- -- closeScribes will stop accepting new logs, flush existing ones and clean up resources
17-- bracket makeLogEnv closeScribes $ \le -> do
17-- bracket makeLogEnv closeScribes $ \le -> do
18-- let initialContext = () -- this context will be attached to every log in your app and merged w/ subsequent contexts
18-- let initialContext = () -- this context will be attached to every log in your app and merged w/ subsequent contexts
@@ -44,7 +44,7 @@
44--
44--
45-- newtype App m a = App {
45-- newtype App m a = App {
46-- unApp :: ReaderT Config m a
46-- unApp :: ReaderT Config m a
47−-- } deriving (Functor, Applicative, Monad, MonadIO, MonadReader Config) -- these are necessary
47+-- } deriving (Functor, Applicative, Monad) -- more instances as needed
48--
48--
49--
49--
50-- -- These instances get even easier with lenses!
50-- -- These instances get even easier with lenses!
@@ -153,22 +153,19 @@ module Katip
153 , LogStr (..)
153 , LogStr (..)
154 , logStr, ls, showLS
154 , logStr, ls, showLS
155
155
156− -- ** 'Katip' Logging Functions
156+ -- ** 'Katip' LoggingFunctions
157 -- $katiplogging
157 -- $katiplogging
158 , Katip (..)
158 , Katip (..)
159 , logF
159 , logF
160 , logMsg
160 , logMsg
161 , logT
161 , logT
162− , logLoc
163 , logItem
162 , logItem
164− , logKatipItem
165 , logException
163 , logException
166 -- ** 'KatipContext': Logging With Context
164 -- ** 'KatipContext': Logging With Context
167 -- $katipcontextlogging
165 -- $katipcontextlogging
168 , KatipContext (..)
166 , KatipContext (..)
169 , logFM
167 , logFM
170 , logTM
168 , logTM
171− , logLocM
172 , logItemM
169 , logItemM
173 , logExceptionM
170 , logExceptionM
174 , AnyLogContext
171 , AnyLogContext
@@ -188,9 +185,6 @@ module Katip
188 , jsonFormat
185 , jsonFormat
189
186
190 -- * Tools for implementing Scribes
187 -- * Tools for implementing Scribes
191− , PermitFunc
192− , permitAND
193− , permitOR
194 , permitItem
188 , permitItem
195 , payloadObject
189 , payloadObject
196 , itemJson
190 , itemJson
katip/src/Katip/Core.hs+87−182
@@ -7,6 +7,7 @@
7{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+{-# LANGUAGE ImplicitParams #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE OverloadedStrings #-}
12{-# LANGUAGE OverloadedStrings #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RankNTypes #-}
@@ -22,18 +23,15 @@
22module Katip.Core where
23module Katip.Core where
23
24
24-------------------------------------------------------------------------------
25-------------------------------------------------------------------------------
25−import Control.Applicative as A
26+import Control.Applicative as A
26import Control.AutoUpdate
27import Control.AutoUpdate
27import Control.Concurrent
28import Control.Concurrent
28−import qualified Control.Concurrent.Async as Async
29+import qualified Control.Concurrent.Async as Async
29import Control.Concurrent.STM
30import Control.Concurrent.STM
30−import qualified Control.Concurrent.STM.TBQueue as BQ
31+import qualified Control.Concurrent.STM.TBQueue as BQ
31import Control.Exception.Safe
32import Control.Exception.Safe
32−import Control.Monad (unless, void, when)
33+import Control.Monad (unless, void)
33import Control.Monad.Base
34import Control.Monad.Base
34−#if MIN_VERSION_base(4, 9, 0)
35−import qualified Control.Monad.Fail as MF
36−#endif
37import Control.Monad.IO.Class
35import Control.Monad.IO.Class
38import Control.Monad.IO.Unlift
36import Control.Monad.IO.Unlift
39import Control.Monad.Trans.Class
37import Control.Monad.Trans.Class
@@ -44,31 +42,28 @@ import Control.Monad.Trans.Either
44import Control.Monad.Trans.Except
42import Control.Monad.Trans.Except
45import Control.Monad.Trans.Maybe
43import Control.Monad.Trans.Maybe
46import Control.Monad.Trans.Reader
44import Control.Monad.Trans.Reader
47−import Control.Monad.Trans.Resource (MonadResource, ResourceT,
45+import Control.Monad.Trans.Resource (ResourceT, transResourceT)
48− transResourceT)
49−import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST)
46+import Control.Monad.Trans.State.Lazy (StateT, mapStateT)
50−import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
47+import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
51−import Control.Monad.Trans.State.Lazy (StateT, mapStateT)
48+import Control.Monad.Trans.Writer.Lazy (WriterT, mapWriterT)
52−import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
49+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT)
53−import Control.Monad.Trans.Writer.Lazy (WriterT, mapWriterT)
50+import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST)
54−import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT,
51+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
55− mapWriterT)
56−import Data.Aeson (FromJSON (..), ToJSON (..),
52+import Data.Aeson (FromJSON (..), ToJSON (..),
57− object)
53+ object)
58−import qualified Data.Aeson as A
54+import qualified Data.Aeson as A
59−import Data.Foldable as FT
55+import Data.Foldable as FT
60−import qualified Data.HashMap.Strict as HM
56+import qualified Data.HashMap.Strict as HM
61import Data.List
57import Data.List
62−import qualified Data.Map.Strict as M
58+import qualified Data.Map.Strict as M
63−import Data.Maybe (fromMaybe)
64−import Data.Semigroup as SG
59+import Data.Semigroup as SG
65import Data.String
60import Data.String
66import Data.String.Conv
61import Data.String.Conv
67−import Data.Text (Text)
62+import Data.Text (Text)
68−import qualified Data.Text as T
63+import qualified Data.Text as T
69−import qualified Data.Text.Lazy.Builder as B
64+import qualified Data.Text.Lazy.Builder as B
70import Data.Time
65import Data.Time
71−import GHC.Generics hiding (to)
66+import GHC.Generics hiding (to)
72#if MIN_VERSION_base(4, 8, 0)
67#if MIN_VERSION_base(4, 8, 0)
73#if !MIN_VERSION_base(4, 9, 0)
68#if !MIN_VERSION_base(4, 9, 0)
74import GHC.SrcLoc
69import GHC.SrcLoc
@@ -76,7 +71,7 @@ import GHC.SrcLoc
76import GHC.Stack
71import GHC.Stack
77#endif
72#endif
78import Language.Haskell.TH
73import Language.Haskell.TH
79−import qualified Language.Haskell.TH.Syntax as TH
74+import qualified Language.Haskell.TH.Syntax as TH
80import Lens.Micro
75import Lens.Micro
81import Lens.Micro.TH
76import Lens.Micro.TH
82import Network.HostName
77import Network.HostName
@@ -143,7 +138,7 @@ data Severity
143-- - 'V3' implies the maximum amount of payload information.
138-- - 'V3' implies the maximum amount of payload information.
144-- - Anything in between is left to the discretion of the developer.
139-- - Anything in between is left to the discretion of the developer.
145data Verbosity = V0 | V1 | V2 | V3
140data Verbosity = V0 | V1 | V2 | V3
146− deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded)
141+ deriving (Eq, Ord, Show, Read, Generic, Enum)
147
142
148
143
149-------------------------------------------------------------------------------
144-------------------------------------------------------------------------------
@@ -184,21 +179,6 @@ instance FromJSON Severity where
184 Just x -> return x
179 Just x -> return x
185 Nothing -> fail $ "Invalid Severity " ++ toS t
180 Nothing -> fail $ "Invalid Severity " ++ toS t
186
181
187−instance ToJSON Verbosity where
188− toJSON s = A.String $ case s of
189− V0 -> "V0"
190− V1 -> "V1"
191− V2 -> "V2"
192− V3 -> "V3"
193−
194−instance FromJSON Verbosity where
195− parseJSON = A.withText "Verbosity" $ \s -> case s of
196− "V0" -> return V0
197− "V1" -> return V1
198− "V2" -> return V2
199− "V3" -> return V3
200− _ -> fail $ "Invalid Verbosity " ++ toS s
201−
202
182
203-------------------------------------------------------------------------------
183-------------------------------------------------------------------------------
204-- | Log message with Builder underneath; use '<>' to concat in O(1).
184-- | Log message with Builder underneath; use '<>' to concat in O(1).
@@ -250,9 +230,7 @@ newtype ThreadIdText = ThreadIdText {
250
230
251
231
252mkThreadIdText :: ThreadId -> ThreadIdText
232mkThreadIdText :: ThreadId -> ThreadIdText
253−mkThreadIdText = ThreadIdText . stripPrefix' "ThreadId " . T.pack . show
233+mkThreadIdText = ThreadIdText . T.pack . show
254− where
255− stripPrefix' pfx t = fromMaybe t (T.stripPrefix pfx t)
256
234
257
235
258-------------------------------------------------------------------------------
236-------------------------------------------------------------------------------
@@ -540,93 +518,52 @@ itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb
540--
518--
541-- Scribes should always take a 'Severity' and 'Verbosity'.
519-- Scribes should always take a 'Severity' and 'Verbosity'.
542--
520--
543−-- Severity is used to __exclude log messages__ that are lower than
521+-- Severity is used to *exclude log messages* that are < the provided
544−-- the provided Severity. For instance, if the user passes InfoS,
522+-- Severity. For instance, if the user passes InfoS, DebugS items
545−-- DebugS items should be ignored. Katip provides the 'permitItem'
523+-- should be ignored. Katip provides the 'permitItem' utility for this.
546−-- utility for this. The user or the scribe may use 'permitAND' and
547−-- 'permitOR' to further customize this filtering, even dynamically if
548−-- they wish to.
549--
524--
550-- Verbosity is used to select keys from the log item's payload. Each
525-- Verbosity is used to select keys from the log item's payload. Each
551-- 'LogItem' instance describes what keys should be retained for each
526-- 'LogItem' instance describes what keys should be retained for each
552-- Verbosity level. Use the 'payloadObject' utility for extracting the keys
527-- Verbosity level. Use the 'payloadObject' utility for extracting the keys
553−-- that should be written.
528+-- that should be permitted.
554--
529--
555−-- Scribes provide a finalizer IO action ('scribeFinalizer') that is
530+-- There is no built-in mechanism in katip for telling a scribe that
556−-- meant to synchronously flush any remaining writes and clean up any
531+-- its time to shut down. 'unregisterScribe' merely drops it from the
557−-- resources acquired when the scribe was created. Internally, katip
532+-- 'LogEnv'. This means there are 2 ways to handle resources as a scribe:
558−-- keeps a buffer for each scribe's writes. When 'closeScribe' or
559−-- 'closeScribes' is called, that buffer stops accepting new log
560−-- messages and after the last item in its buffer is sent to 'liPush',
561−-- calls the finalizer. Thus, when the finalizer returns, katip can
562−-- assume that all resources are cleaned up and all log messages are
563−-- durably written.
564--
533--
565−-- While katip internally buffers messages per 'ScribeSettings', it
534+-- 1. Pass in the resource when the scribe is created. Handle
566−-- sends them one at a time to the scribe. Depending on the scribe
535+-- allocation and release of the resource elsewhere. This is what the
567−-- itself, it may make sense for that scribe to keep its own internal
536+-- Handle scribe does.
568−-- buffer to batch-send logs if writing items one at a time is not
537+--
569−-- efficient. The scribe implementer must be sure that on
538+-- 2. Return a finalizing function that tells the scribe to shut
570−-- finalization, all writes are committed synchronously.
539+-- down. @katip-elasticsearch@'s @mkEsScribe@ returns an @IO (Scribe,
571−
540+-- IO ())@. The finalizer will flush any queued log messages and shut
572−-- | Signature of a function passed to `Scribe` constructor and
541+-- down gracefully before returning. This can be hooked into your
573−-- mkScribe* functions that decides which messages to be
542+-- application's shutdown routine to ensure you never miss any log
574−-- logged. Typically filters based on 'Severity', but can be
543+-- messages on shutdown.
575−-- combined with other, custom logic with 'permitAND' and 'permitOR'
576−type PermitFunc = forall a. Item a -> IO Bool
577−
578−
579−-- | AND together 2 permit functions
580−permitAND :: PermitFunc -> PermitFunc -> PermitFunc
581−permitAND f1 f2 = \a -> liftA2 (&&) (f1 a) (f2 a)
582−
583−-- | OR together 2 permit functions
584−permitOR :: PermitFunc -> PermitFunc -> PermitFunc
585−permitOR f1 f2 = \a -> liftA2 (||) (f1 a) (f2 a)
586−
587−
588data Scribe = Scribe {
544data Scribe = Scribe {
589− liPush :: forall a. LogItem a => Item a -> IO ()
545+ liPush :: forall a. LogItem a => Item a -> IO ()
590− -- ^ How do we write an item to the scribe's output?
591− , scribeFinalizer :: IO ()
546+ , scribeFinalizer :: IO ()
592− -- ^ Provide a __blocking__ finalizer to call when your scribe is
547+ -- ^ Provide a *blocking* finalizer to call when your scribe is
593− -- removed. All pending writes should be flushed synchronously. If
594− -- this is not relevant to your scribe, return () is fine.
548+ -- removed. If this is not relevant to your scribe, return () is
595− , scribePermitItem :: PermitFunc
549+ -- fine.
596− -- ^ Provide a filtering function to allow the item to be logged,
597− -- or not. It can check Severity or some string in item's
598− -- body. The initial value of this is usually created from
599− -- 'permitItem'. Scribes and users can customize this by ANDing
600− -- or ORing onto the default with 'permitAND' or 'permitOR'
601 }
550 }
602
551
603
552
604−whenM :: Monad m => m Bool -> m () -> m ()
605−whenM mbool = (>>=) mbool . flip when
606−
607−
608−-- | Combine two scribes. Publishes to the left scribe if the left
609−-- would permit the item and to the right scribe if the right would
610−-- permit the item. Finalizers are called in sequence from left to
611−-- right.
612instance Semigroup Scribe where
553instance Semigroup Scribe where
613− (Scribe pushA finA permitA) <> (Scribe pushB finB permitB) =
554+ (Scribe pushA finA) <> (Scribe pushB finB) =
614− Scribe (\item -> whenM (permitA item) (pushA item)
615− >> whenM (permitB item) (pushB item)
616− )
617− (finA `finally` finB)
555+ Scribe (\item -> pushA item >> pushB item) (finA `finally` finB)
618− (permitOR permitA permitB)
619
556
620
557
621instance Monoid Scribe where
558instance Monoid Scribe where
622− mempty = Scribe (const (return ())) (return ()) (permitItem DebugS)
559+ mempty = Scribe (const (return ())) (return ())
623 mappend = (<>)
560 mappend = (<>)
624
561
625
562
626-------------------------------------------------------------------------------
563-------------------------------------------------------------------------------
627data ScribeHandle = ScribeHandle {
564data ScribeHandle = ScribeHandle {
628 shScribe :: Scribe
565 shScribe :: Scribe
629− , shChan :: BQ.TBQueue WorkerMessage
566+ , shChan :: BQ.TBQueue WorkerMessage
630 }
567 }
631
568
632
569
@@ -638,9 +575,8 @@ data WorkerMessage where
638
575
639-------------------------------------------------------------------------------
576-------------------------------------------------------------------------------
640-- | Should this item be logged given the user's maximum severity?
577-- | Should this item be logged given the user's maximum severity?
641−-- Most new scribes will use this as a base for their 'PermitFunc'
642−permitItem :: Monad m => Severity -> Item a -> m Bool
578+permitItem :: Severity -> Item a -> Bool
643−permitItem sev item = return (_itemSeverity item >= sev)
579+permitItem sev i = _itemSeverity i >= sev
644
580
645
581
646-------------------------------------------------------------------------------
582-------------------------------------------------------------------------------
@@ -665,7 +601,7 @@ makeLenses ''LogEnv
665
601
666
602
667-------------------------------------------------------------------------------
603-------------------------------------------------------------------------------
668−-- | Create a reasonable default InitLogEnv. Uses an 'AutoUpdate' which
604+-- | Create a reasonable default InitLogEnv. Uses an 'AutoUdate' which
669-- updates the timer every 1ms. If you need even more timestamp
605-- updates the timer every 1ms. If you need even more timestamp
670-- precision at the cost of performance, consider setting
606-- precision at the cost of performance, consider setting
671-- '_logEnvTimer' with 'getCurrentTime'.
607-- '_logEnvTimer' with 'getCurrentTime'.
@@ -686,9 +622,7 @@ initLogEnv an env = LogEnv
686
622
687-------------------------------------------------------------------------------
623-------------------------------------------------------------------------------
688-- | Add a scribe to the list. All future log calls will go to this
624-- | Add a scribe to the list. All future log calls will go to this
689−-- scribe in addition to the others. Writes will be buffered per the
625+-- scribe in addition to the others.
690−-- ScribeSettings to prevent slow scribes from slowing down
691−-- logging. Writes will be dropped if the buffer fills.
692registerScribe
626registerScribe
693 :: Text
627 :: Text
694 -- ^ Name the scribe
628 -- ^ Name the scribe
@@ -697,7 +631,7 @@ registerScribe
697 -> LogEnv
631 -> LogEnv
698 -> IO LogEnv
632 -> IO LogEnv
699registerScribe nm scribe ScribeSettings {..} le = do
633registerScribe nm scribe ScribeSettings {..} le = do
700− queue <- atomically (BQ.newTBQueue (fromIntegral _scribeBufferSize))
634+ queue <- atomically (BQ.newTBQueue _scribeBufferSize)
701 worker <- spawnScribeWorker scribe queue
635 worker <- spawnScribeWorker scribe queue
702 let fin = do
636 let fin = do
703 atomically (BQ.writeTBQueue queue PoisonPill)
637 atomically (BQ.writeTBQueue queue PoisonPill)
@@ -712,7 +646,7 @@ registerScribe nm scribe ScribeSettings {..} le = do
712
646
713-------------------------------------------------------------------------------
647-------------------------------------------------------------------------------
714spawnScribeWorker :: Scribe -> BQ.TBQueue WorkerMessage -> IO (Async.Async ())
648spawnScribeWorker :: Scribe -> BQ.TBQueue WorkerMessage -> IO (Async.Async ())
715−spawnScribeWorker (Scribe write _ _) queue = Async.async go
649+spawnScribeWorker (Scribe write _) queue = Async.async go
716 where
650 where
717 go = do
651 go = do
718 newCmd <- atomically (BQ.readTBQueue queue)
652 newCmd <- atomically (BQ.readTBQueue queue)
@@ -741,7 +675,7 @@ defaultScribeSettings = ScribeSettings 4096
741
675
742
676
743-------------------------------------------------------------------------------
677-------------------------------------------------------------------------------
744−-- | Remove a scribe from the environment. This does __not__ finalize
678+-- | Remove a scribe from the environment. This does *not* finalize
745-- the scribe. This mainly only makes sense to use with something like
679-- the scribe. This mainly only makes sense to use with something like
746-- MonadReader's @local@ function to temporarily disavow a single
680-- MonadReader's @local@ function to temporarily disavow a single
747-- logger for a block of code.
681-- logger for a block of code.
@@ -754,7 +688,7 @@ unregisterScribe nm = logEnvScribes %~ M.delete nm
754
688
755
689
756-------------------------------------------------------------------------------
690-------------------------------------------------------------------------------
757−-- | Unregister __all__ scribes. Note that this is __not__ for closing or
691+-- | Unregister *all* scribes. Note that this is *not* for closing or
758-- finalizing scribes, use 'closeScribes' for that. This mainly only
692-- finalizing scribes, use 'closeScribes' for that. This mainly only
759-- makes sense to use with something like MonadReader's @local@
693-- makes sense to use with something like MonadReader's @local@
760-- function to temporarily disavow any loggers for a block of code.
694-- function to temporarily disavow any loggers for a block of code.
@@ -766,10 +700,9 @@ clearScribes = logEnvScribes .~ mempty
766
700
767-------------------------------------------------------------------------------
701-------------------------------------------------------------------------------
768-- | Finalize a scribe. The scribe is removed from the environment,
702-- | Finalize a scribe. The scribe is removed from the environment,
769−-- its finalizer is called so that it can never be written to again
703+-- its finalizer is called and it can never be written to again. Note
770−-- and all pending writes are flushed. Note that this will throw any
771−-- exceptions yoru finalizer will throw, and that LogEnv is immutable,
704+-- that this will throw any exceptions yoru finalizer will throw, and
772−-- so it will not be removed in that case.
705+-- that LogEnv is immutable, so it will not be removed in that case.
773closeScribe
706closeScribe
774 :: Text
707 :: Text
775 -- ^ Name of the scribe
708 -- ^ Name of the scribe
@@ -880,8 +813,7 @@ instance (Katip m) => Katip (ResourceT m) where
880-- opposed to implementing 'Katip' for your monad.
813-- opposed to implementing 'Katip' for your monad.
881newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }
814newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }
882 deriving ( Functor, Applicative, Monad, MonadIO
815 deriving ( Functor, Applicative, Monad, MonadIO
883− , MonadMask, MonadCatch, MonadThrow, MonadResource, MonadTrans
816+ , MonadMask, MonadCatch, MonadThrow, MonadTrans, MonadBase b)
884− , MonadBase b)
885
817
886
818
887instance MonadIO m => Katip (KatipT m) where
819instance MonadIO m => Katip (KatipT m) where
@@ -903,20 +835,9 @@ instance (MonadBaseControl b m) => MonadBaseControl b (KatipT m) where
903 restoreM = defaultRestoreM
835 restoreM = defaultRestoreM
904
836
905instance MonadUnliftIO m => MonadUnliftIO (KatipT m) where
837instance MonadUnliftIO m => MonadUnliftIO (KatipT m) where
906−#if MIN_VERSION_unliftio_core(0, 2, 0)
907− withRunInIO inner = KatipT $ ReaderT $ \le -> withRunInIO $ \run ->
908− inner (run . runKatipT le)
909−#else
910 askUnliftIO = KatipT $
838 askUnliftIO = KatipT $
911− withUnliftIO $ \u ->
839+ withUnliftIO $ \u ->
912− pure (UnliftIO (unliftIO u . unKatipT))
840+ pure (UnliftIO (unliftIO u . unKatipT))
913−#endif
914−
915−#if MIN_VERSION_base(4, 9, 0)
916−instance MF.MonadFail m => MF.MonadFail (KatipT m) where
917− fail msg = lift (MF.fail msg)
918− {-# INLINE fail #-}
919−#endif
920
841
921-------------------------------------------------------------------------------
842-------------------------------------------------------------------------------
922-- | Execute 'KatipT' on a log env.
843-- | Execute 'KatipT' on a log env.
@@ -948,32 +869,21 @@ logItem
948 -> m ()
869 -> m ()
949logItem a ns loc sev msg = do
870logItem a ns loc sev msg = do
950 LogEnv{..} <- getLogEnv
871 LogEnv{..} <- getLogEnv
951− logKatipItem =<< liftIO
872+ liftIO $ do
873+ item <- Item
952− (Item <$> pure _logEnvApp
874+ <$> pure _logEnvApp
953− <*> pure _logEnvEnv
875+ <*> pure _logEnvEnv
954− <*> pure sev
876+ <*> pure sev
955− <*> (mkThreadIdText <$> myThreadId)
877+ <*> (mkThreadIdText <$> myThreadId)
956− <*> pure _logEnvHost
878+ <*> pure _logEnvHost
957− <*> pure _logEnvPid
879+ <*> pure _logEnvPid
958− <*> pure a
880+ <*> pure a
959− <*> pure msg
881+ <*> pure msg
960− <*> _logEnvTimer
882+ <*> _logEnvTimer
961− <*> pure (_logEnvApp <> ns)
883+ <*> pure (_logEnvApp <> ns)
962− <*> pure loc)
884+ <*> pure loc
963−
964−-- | Log already constructed 'Item'. This is the lowest level function that other log*
965−-- functions use.
966−-- It can be useful when implementing centralised logging services.
967−logKatipItem
968− :: (A.Applicative m, LogItem a, Katip m)
969− => Item a
970− -> m ()
971−logKatipItem item = do
972− LogEnv{..} <- getLogEnv
973− liftIO $
974− FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> do
975− whenM (scribePermitItem shScribe item) $
976− void $ atomically (tryWriteTBQueue shChan (NewItem item))
885+ FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> atomically (tryWriteTBQueue shChan (NewItem item))
886+
977
887
978-------------------------------------------------------------------------------
888-------------------------------------------------------------------------------
979tryWriteTBQueue
889tryWriteTBQueue
@@ -986,7 +896,6 @@ tryWriteTBQueue q a = do
986 unless full (writeTBQueue q a)
896 unless full (writeTBQueue q a)
987 return (not full)
897 return (not full)
988
898
989−
990-------------------------------------------------------------------------------
899-------------------------------------------------------------------------------
991-- | Log with full context, but without any code location.
900-- | Log with full context, but without any code location.
992logF
901logF
@@ -1019,7 +928,7 @@ logException
1019logException a ns sev action = action `catchAny` \e -> f e >> throwM e
928logException a ns sev action = action `catchAny` \e -> f e >> throwM e
1020 where
929 where
1021 f e = logF a ns sev (msg e)
930 f e = logF a ns sev (msg e)
1022− msg e = ls (T.pack "An exception has occurred: ") <> showLS e
931+ msg e = ls (T.pack "An exception has occured: ") <> showLS e
1023
932
1024
933
1025-------------------------------------------------------------------------------
934-------------------------------------------------------------------------------
@@ -1073,15 +982,11 @@ liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
1073-- fill the 'Maybe Loc' gap in 'logF' of this module, and relies on implicit
982-- fill the 'Maybe Loc' gap in 'logF' of this module, and relies on implicit
1074-- callstacks when available (GHC > 7.8).
983-- callstacks when available (GHC > 7.8).
1075#if MIN_VERSION_base(4, 8, 0)
984#if MIN_VERSION_base(4, 8, 0)
1076−getLoc :: HasCallStack => Maybe Loc
985+getLoc :: (?loc :: CallStack) => Maybe Loc
1077−getLoc = case getCallStack callStack of
986+getLoc = case getCallStack ?loc of
1078 [] -> Nothing
987 [] -> Nothing
1079− xs -> Just . toLoc . head $ filter filterKatip xs
988+ xs -> Just . toLoc . last $ xs
1080 where
989 where
1081− filterKatip :: (String, SrcLoc) -> Bool
1082− filterKatip (_, srcloc) = not $
1083− "katip-" `isPrefixOf` srcLocPackage srcloc
1084−
1085 toLoc :: (String, SrcLoc) -> Loc
990 toLoc :: (String, SrcLoc) -> Loc
1086 toLoc (_, l) = Loc {
991 toLoc (_, l) = Loc {
1087 loc_filename = srcLocFile l
992 loc_filename = srcLocFile l
@@ -1112,7 +1017,7 @@ logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |]
1112
1017
1113
1018
1114-------------------------------------------------------------------------------
1019-------------------------------------------------------------------------------
1115−-- | 'Loc'-tagged logging using 'GHC.Stack' when available.
1020+-- | 'Loc'-tagged logging using implicit-callstacks when available.
1116--
1021--
1117-- This function does not require template-haskell as it
1022-- This function does not require template-haskell as it
1118-- automatically uses <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>
1023-- automatically uses <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>
@@ -1123,7 +1028,7 @@ logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |]
1123--
1028--
1124-- @logLoc obj mempty InfoS "Hello world"@
1029-- @logLoc obj mempty InfoS "Hello world"@
1125#if MIN_VERSION_base(4, 8, 0)
1030#if MIN_VERSION_base(4, 8, 0)
1126−logLoc :: (Applicative m, LogItem a, Katip m, HasCallStack)
1031+logLoc :: (Applicative m, LogItem a, Katip m, ?loc :: CallStack)
1127#else
1032#else
1128logLoc :: (Applicative m, LogItem a, Katip m)
1033logLoc :: (Applicative m, LogItem a, Katip m)
1129#endif
1034#endif
katip/src/Katip/Monadic.hs+15−44
@@ -44,9 +44,6 @@ import Control.Applicative
44import Control.Exception.Safe
44import Control.Exception.Safe
45import Control.Monad.Base
45import Control.Monad.Base
46import Control.Monad.Error.Class
46import Control.Monad.Error.Class
47−#if MIN_VERSION_base(4, 9, 0)
48−import qualified Control.Monad.Fail as MF
49−#endif
50import Control.Monad.IO.Class
47import Control.Monad.IO.Class
51import Control.Monad.IO.Unlift
48import Control.Monad.IO.Unlift
52import Control.Monad.Reader
49import Control.Monad.Reader
@@ -58,8 +55,7 @@ import Control.Monad.Trans.Either (EitherT, mapEitherT)
58import Control.Monad.Trans.Except (ExceptT, mapExceptT)
55import Control.Monad.Trans.Except (ExceptT, mapExceptT)
59import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
56import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
60import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
57import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
61−import Control.Monad.Trans.Resource (MonadResource,
58+import Control.Monad.Trans.Resource (ResourceT, transResourceT)
62− ResourceT, transResourceT)
63import Control.Monad.Trans.RWS (RWST, mapRWST)
59import Control.Monad.Trans.RWS (RWST, mapRWST)
64import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
60import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
65import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
61import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
@@ -72,12 +68,6 @@ import qualified Data.HashMap.Strict as HM
72import Data.Semigroup as Semi
68import Data.Semigroup as Semi
73import Data.Sequence as Seq
69import Data.Sequence as Seq
74import Data.Text (Text)
70import Data.Text (Text)
75−#if MIN_VERSION_base(4, 8, 0)
76−#if !MIN_VERSION_base(4, 9, 0)
77−import GHC.SrcLoc
78−#endif
79−import GHC.Stack
80−#endif
81import Language.Haskell.TH
71import Language.Haskell.TH
82-------------------------------------------------------------------------------
72-------------------------------------------------------------------------------
83import Katip.Core
73import Katip.Core
@@ -245,7 +235,7 @@ deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)
245-- very low level and you typically can use 'logTM' in its
235-- very low level and you typically can use 'logTM' in its
246-- place. Automatically supplies payload and namespace.
236-- place. Automatically supplies payload and namespace.
247logItemM
237logItemM
248− :: (Applicative m, KatipContext m, HasCallStack)
238+ :: (Applicative m, KatipContext m)
249 => Maybe Loc
239 => Maybe Loc
250 -> Severity
240 -> Severity
251 -> LogStr
241 -> LogStr
@@ -282,21 +272,20 @@ logTM = [| logItemM (Just $(getLocTH)) |]
282
272
283
273
284-------------------------------------------------------------------------------
274-------------------------------------------------------------------------------
285−-- | 'Loc'-tagged logging when using 'GHC.Stack.getCallStack' implicit-callstacks>.
275+-- | 'Loc'-tagged logging when using template-haskell. Automatically
286−-- Automatically supplies payload and namespace.
276+-- supplies payload and namespace.
287--
277--
288-- Same consideration as `logLoc` applies.
278-- Same consideration as `logLoc` applies.
289--
279--
290−-- Location will be logged from the module that invokes 'logLocM' so
291−-- be aware that wrapping 'logLocM' will make location reporting useless.
292−--
293−-- This function does not require template-haskell. Using GHC <= 7.8 will result
280+-- This function does not require template-haskell as it
281+-- automatically uses <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>
282+-- when the code is compiled using GHC > 7.8. Using an older version of the
294−-- in the emission of a log line without any location information.
283+-- compiler will result in the emission of a log line without any location information,
295−-- Users using GHC <= 7.8 may want to use the template-haskell function
284+-- so be aware of it. Users using GHC <= 7.8 may want to use the template-haskell function
296-- `logTM` for maximum compatibility.
285-- `logTM` for maximum compatibility.
297--
286--
298-- @logLocM InfoS "Hello world"@
287-- @logLocM InfoS "Hello world"@
299−logLocM :: (Applicative m, KatipContext m, HasCallStack)
288+logLocM :: (Applicative m, KatipContext m)
300 => Severity
289 => Severity
301 -> LogStr
290 -> LogStr
302 -> m ()
291 -> m ()
@@ -316,7 +305,7 @@ logExceptionM
316logExceptionM action sev = action `catchAny` \e -> f e >> throwM e
305logExceptionM action sev = action `catchAny` \e -> f e >> throwM e
317 where
306 where
318 f e = logFM sev (msg e)
307 f e = logFM sev (msg e)
319− msg e = ls ("An exception has occurred: " :: Text) Semi.<> showLS e
308+ msg e = ls ("An exception has occured: " :: Text) Semi.<> showLS e
320
309
321
310
322-------------------------------------------------------------------------------
311-------------------------------------------------------------------------------
@@ -350,7 +339,6 @@ newtype KatipContextT m a = KatipContextT {
350 , MonadWriter w
339 , MonadWriter w
351 , MonadError e
340 , MonadError e
352 , MonadPlus
341 , MonadPlus
353− , MonadResource
354 , Alternative
342 , Alternative
355 , MonadFix
343 , MonadFix
356 , MonadTrans
344 , MonadTrans
@@ -397,21 +385,10 @@ instance (MonadIO m) => KatipContext (KatipContextT m) where
397 localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m
385 localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m
398
386
399instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where
387instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where
400−#if MIN_VERSION_unliftio_core(0, 2, 0)
401− withRunInIO inner = KatipContextT $ ReaderT $ \lts -> withRunInIO $ \run ->
402− inner (run . runKatipContextT (ltsLogEnv lts) (ltsContext lts) (ltsNamespace lts))
403−#else
404 askUnliftIO = KatipContextT $
388 askUnliftIO = KatipContextT $
405− withUnliftIO $ \u ->
389+ withUnliftIO $ \u ->
406− pure (UnliftIO (unliftIO u . unKatipContextT))
390+ pure (UnliftIO (unliftIO u . unKatipContextT))
407−#endif
408−
409
391
410−#if MIN_VERSION_base(4, 9, 0)
411−instance MF.MonadFail m => MF.MonadFail (KatipContextT m) where
412− fail msg = lift (MF.fail msg)
413− {-# INLINE fail #-}
414−#endif
415
392
416-------------------------------------------------------------------------------
393-------------------------------------------------------------------------------
417runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a
394runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a
@@ -490,15 +467,9 @@ instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where
490 restoreM = NoLoggingT . restoreM
467 restoreM = NoLoggingT . restoreM
491
468
492instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where
469instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where
493−#if MIN_VERSION_unliftio_core(0, 2, 0)
494− withRunInIO inner = NoLoggingT $ withRunInIO $ \run ->
495− inner (run . runNoLoggingT)
496−#else
497 askUnliftIO = NoLoggingT $
470 askUnliftIO = NoLoggingT $
498− withUnliftIO $ \u ->
471+ withUnliftIO $ \u ->
499− pure (UnliftIO (unliftIO u . runNoLoggingT))
472+ pure (UnliftIO (unliftIO u . runNoLoggingT))
500−#endif
501−
502
473
503instance MonadIO m => Katip (NoLoggingT m) where
474instance MonadIO m => Katip (NoLoggingT m) where
504 getLogEnv = liftIO (initLogEnv "NoLoggingT" "no-logging")
475 getLogEnv = liftIO (initLogEnv "NoLoggingT" "no-logging")
katip/src/Katip/Scribes/Handle.hs+23−32
@@ -4,6 +4,7 @@ module Katip.Scribes.Handle where
4import Control.Applicative as A
4import Control.Applicative as A
5import Control.Concurrent
5import Control.Concurrent
6import Control.Exception (bracket_, finally)
6import Control.Exception (bracket_, finally)
7+import Control.Monad
7import Data.Aeson
8import Data.Aeson
8import Data.Text.Lazy (toStrict)
9import Data.Text.Lazy (toStrict)
9import Data.Text.Lazy.Encoding (decodeUtf8)
10import Data.Text.Lazy.Encoding (decodeUtf8)
@@ -56,13 +57,13 @@ data ColorStrategy
56-- and other information will be flattened out into bracketed
57-- and other information will be flattened out into bracketed
57-- fields. For example:
58-- fields. For example:
58--
59--
59−-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
60+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
60−-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
61+-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
61−-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
62+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
62--
63--
63-- Returns the newly-created `Scribe`. The finalizer flushes the
64-- Returns the newly-created `Scribe`. The finalizer flushes the
64-- handle. Handle mode is set to 'LineBuffering' automatically.
65-- handle. Handle mode is set to 'LineBuffering' automatically.
65−mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
66+mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe
66mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
67mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
67
68
68-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
69-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
@@ -70,22 +71,17 @@ mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
70--
71--
71-- Returns the newly-created `Scribe`. The finalizer flushes the
72-- Returns the newly-created `Scribe`. The finalizer flushes the
72-- handle. Handle mode is set to 'LineBuffering' automatically.
73-- handle. Handle mode is set to 'LineBuffering' automatically.
73−mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
74+mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a) -> ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe
74− -> ColorStrategy
75− -> Handle
76− -> PermitFunc
77− -> Verbosity
78− -> IO Scribe
79−mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
75+mkHandleScribeWithFormatter formatItem cs h sev verb = do
80 hSetBuffering h LineBuffering
76 hSetBuffering h LineBuffering
81 colorize <- case cs of
77 colorize <- case cs of
82 ColorIfTerminal -> hIsTerminalDevice h
78 ColorIfTerminal -> hIsTerminalDevice h
83 ColorLog b -> return b
79 ColorLog b -> return b
84 lock <- newMVar ()
80 lock <- newMVar ()
85 let logger i@Item{..} = do
81 let logger i@Item{..} = do
86− bracket_ (takeMVar lock) (putMVar lock ()) $
82+ when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $
87− T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i
83+ T.hPutStrLn h $ toLazyText $ formatItem colorize verb i
88− return $ Scribe logger (hFlush h) permitF
84+ return $ Scribe logger (hFlush h)
89
85
90
86
91-------------------------------------------------------------------------------
87-------------------------------------------------------------------------------
@@ -94,11 +90,11 @@ mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
94-- 'AppendMode' and will close the file handle on
90-- 'AppendMode' and will close the file handle on
95-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
91-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
96-- to 'LineBuffering' mode.
92-- to 'LineBuffering' mode.
97−mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
93+mkFileScribe :: FilePath -> Severity -> Verbosity -> IO Scribe
98−mkFileScribe f permitF verb = do
94+mkFileScribe f sev verb = do
99 h <- openFile f AppendMode
95 h <- openFile f AppendMode
100− Scribe logger finalizer permit <- mkHandleScribe (ColorLog False) h permitF verb
96+ Scribe logger finalizer <- mkHandleScribe (ColorLog False) h sev verb
101− return (Scribe logger (finalizer `finally` hClose h) permit)
97+ return (Scribe logger (finalizer `finally` hClose h))
102
98
103
99
104-------------------------------------------------------------------------------
100-------------------------------------------------------------------------------
@@ -109,25 +105,20 @@ mkFileScribe f permitF verb = do
109-- See `bracketFormat` and `jsonFormat` for examples.
105-- See `bracketFormat` and `jsonFormat` for examples.
110type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder
106type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder
111
107
112−
113−formatItem :: LogItem a => ItemFormatter a
114−formatItem = bracketFormat
115−{-# DEPRECATED formatItem "Use bracketFormat instead" #-}
116−
117-- | A traditional 'bracketed' log format. Contexts and other information will
108-- | A traditional 'bracketed' log format. Contexts and other information will
118-- be flattened out into bracketed fields. For example:
109-- be flattened out into bracketed fields. For example:
119--
110--
120−-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
111+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
121−-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
112+-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
122−-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
113+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
123bracketFormat :: LogItem a => ItemFormatter a
114bracketFormat :: LogItem a => ItemFormatter a
124bracketFormat withColor verb Item{..} =
115bracketFormat withColor verb Item{..} =
125 brackets nowStr <>
116 brackets nowStr <>
126 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
117 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
127 brackets (fromText (renderSeverity' _itemSeverity)) <>
118 brackets (fromText (renderSeverity' _itemSeverity)) <>
128 brackets (fromString _itemHost) <>
119 brackets (fromString _itemHost) <>
129− brackets ("PID " <> fromString (show _itemProcess)) <>
120+ brackets (fromString (show _itemProcess)) <>
130− brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
121+ brackets (fromText (getThreadIdText _itemThread)) <>
131 mconcat ks <>
122 mconcat ks <>
132 maybe mempty (brackets . fromString . locationToString) _itemLoc <>
123 maybe mempty (brackets . fromString . locationToString) _itemLoc <>
133 fromText " " <> (unLogStr _itemMessage)
124 fromText " " <> (unLogStr _itemMessage)
@@ -140,7 +131,7 @@ bracketFormat withColor verb Item{..} =
140-- | Logs items as JSON. This can be useful in circumstances where you already
131-- | Logs items as JSON. This can be useful in circumstances where you already
141-- have infrastructure that is expecting JSON to be logged to a standard stream
132-- have infrastructure that is expecting JSON to be logged to a standard stream
142-- or file. For example:
133-- or file. For example:
143−--
134+
144-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Started","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":44},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
135-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Started","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":44},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
145-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}
136-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}
146-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
137-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
@@ -173,8 +164,8 @@ colorBySeverity withColor severity msg = case severity of
173-- stdout. This is a decent example of how to build a LogEnv and is
164-- stdout. This is a decent example of how to build a LogEnv and is
174-- best for scripts that just need a quick, reasonable set up to log
165-- best for scripts that just need a quick, reasonable set up to log
175-- to stdout.
166-- to stdout.
176−ioLogEnv :: PermitFunc -> Verbosity -> IO LogEnv
167+ioLogEnv :: Severity -> Verbosity -> IO LogEnv
177−ioLogEnv permit verb = do
168+ioLogEnv sev verb = do
178 le <- initLogEnv "io" "io"
169 le <- initLogEnv "io" "io"
179− lh <- mkHandleScribe ColorIfTerminal stdout permit verb
170+ lh <- mkHandleScribe ColorIfTerminal stdout sev verb
180 registerScribe "stdout" lh defaultScribeSettings le
171 registerScribe "stdout" lh defaultScribeSettings le
katip/test/Katip/Tests.hs+2−16
@@ -42,8 +42,6 @@ tests = testGroup "Katip"
42 [
42 [
43 testProperty "JSON cycle Item" $ \(i :: Item ()) ->
43 testProperty "JSON cycle Item" $ \(i :: Item ()) ->
44 prop_json_cycle i
44 prop_json_cycle i
45− , testProperty "JSON cycle verbosity" $ \(v :: Verbosity) ->
46− prop_json_cycle v
47 , eqItemTests
45 , eqItemTests
48 , testProperty "renderSeverity/textToSeverity cycle" $ \sev ->
46 , testProperty "renderSeverity/textToSeverity cycle" $ \sev ->
49 textToSeverity(renderSeverity sev) === Just sev
47 textToSeverity(renderSeverity sev) === Just sev
@@ -126,13 +124,6 @@ loggingTests = testGroup "logging"
126 , (baseNS <> "added" <> "namespace", baseCtx, "with namespaces")
124 , (baseNS <> "added" <> "namespace", baseCtx, "with namespaces")
127 , (baseNS <> "added", HM.insert "additional" (Bool True) baseCtx, "additional context")
125 , (baseNS <> "added", HM.insert "additional" (Bool True) baseCtx, "additional context")
128 ]
126 ]
129− , testCase "Katip.Monadic.logLocM" $ do
130− (le, items) <- recordingEnv
131− runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ logLocM InfoS "basic log"
132− _ <- closeScribes le
133− loggedItems <- readTVarIO items
134− let loc = _itemLoc (head loggedItems)
135− fmap loc_module loc @?= Just "Katip.Tests"
136 ]
127 ]
137 where
128 where
138 recordingEnv :: IO (LogEnv, TVar [Item Object])
129 recordingEnv :: IO (LogEnv, TVar [Item Object])
@@ -141,7 +132,6 @@ loggingTests = testGroup "logging"
141 let scribe = Scribe
132 let scribe = Scribe
142 { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i]))
133 { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i]))
143 , scribeFinalizer = return ()
134 , scribeFinalizer = return ()
144− , scribePermitItem = permitItem DebugS
145 }
135 }
146 le1 <- initLogEnv "tests" "test"
136 le1 <- initLogEnv "tests" "test"
147 le2 <- registerScribe "recorder" scribe defaultScribeSettings le1
137 le2 <- registerScribe "recorder" scribe defaultScribeSettings le1
@@ -155,7 +145,7 @@ trivialScribe :: IO (Scribe, TVar Bool)
155trivialScribe = do
145trivialScribe = do
156 finalizerCalled <- newTVarIO False
146 finalizerCalled <- newTVarIO False
157 let finalizer = atomically (writeTVar finalizerCalled True)
147 let finalizer = atomically (writeTVar finalizerCalled True)
158− return (Scribe (const (return ())) finalizer (permitItem DebugS), finalizerCalled)
148+ return (Scribe (const (return ())) finalizer, finalizerCalled)
159
149
160
150
161-------------------------------------------------------------------------------
151-------------------------------------------------------------------------------
@@ -165,7 +155,7 @@ brokenScribe scribeNum = do
165 let finalizer = do
155 let finalizer = do
166 atomically (writeTVar finalizerCalled True)
156 atomically (writeTVar finalizerCalled True)
167 throw (ScribeBroken scribeNum)
157 throw (ScribeBroken scribeNum)
168− return (Scribe (const (return ())) finalizer (permitItem DebugS), finalizerCalled)
158+ return (Scribe (const (return ())) finalizer, finalizerCalled)
169
159
170
160
171-------------------------------------------------------------------------------
161-------------------------------------------------------------------------------
@@ -269,10 +259,6 @@ instance Arbitrary Loc where
269 return $ Loc f p m s s
259 return $ Loc f p m s s
270
260
271
261
272−-------------------------------------------------------------------------------
273−instance Arbitrary Verbosity where
274− arbitrary = oneof $ map pure [V0, V1, V2, V3]
275−
276-------------------------------------------------------------------------------
262-------------------------------------------------------------------------------
277instance Arbitrary Severity where
263instance Arbitrary Severity where
278 arbitrary = oneof $ map pure [ DebugS
264 arbitrary = oneof $ map pure [ DebugS
katip/test/Katip/Tests/Scribes/Handle-text.golden+38−38
@@ -1,40 +1,40 @@
1−[2016-06-12 12:34:56][foo][Debug][example][PID 7331][ThreadId 1337][note.deep:some note] message
1+[2016-06-12 12:34:56][foo][Debug][example][7331][1337][note.deep:some note] message
2−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
2+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
3−[2016-06-12 12:34:56][foo][Notice][example][PID 7331][ThreadId 1337][note.deep:some note] message
3+[2016-06-12 12:34:56][foo][Notice][example][7331][1337][note.deep:some note] message
4−[2016-06-12 12:34:56][foo][Warning][example][PID 7331][ThreadId 1337][note.deep:some note] message
4+[2016-06-12 12:34:56][foo][Warning][example][7331][1337][note.deep:some note] message
5−[2016-06-12 12:34:56][foo][Error][example][PID 7331][ThreadId 1337][note.deep:some note] message
5+[2016-06-12 12:34:56][foo][Error][example][7331][1337][note.deep:some note] message
6−[2016-06-12 12:34:56][foo][Critical][example][PID 7331][ThreadId 1337][note.deep:some note] message
6+[2016-06-12 12:34:56][foo][Critical][example][7331][1337][note.deep:some note] message
7−[2016-06-12 12:34:56][foo][Alert][example][PID 7331][ThreadId 1337][note.deep:some note] message
7+[2016-06-12 12:34:56][foo][Alert][example][7331][1337][note.deep:some note] message
8−[2016-06-12 12:34:56][foo][Emergency][example][PID 7331][ThreadId 1337][note.deep:some note] message
8+[2016-06-12 12:34:56][foo][Emergency][example][7331][1337][note.deep:some note] message
9−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 0][note.deep:some note] message
9+[2016-06-12 12:34:56][foo][Info][example][7331][0][note.deep:some note] message
10−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1][note.deep:some note] message
10+[2016-06-12 12:34:56][foo][Info][example][7331][1][note.deep:some note] message
11−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
11+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
12−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 2147483647][note.deep:some note] message
12+[2016-06-12 12:34:56][foo][Info][example][7331][2147483647][note.deep:some note] message
13−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
13+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
14−[2016-06-12 12:34:56][foo][Info][www.example.com][PID 7331][ThreadId 1337][note.deep:some note] message
14+[2016-06-12 12:34:56][foo][Info][www.example.com][7331][1337][note.deep:some note] message
15−[2016-06-12 12:34:56][foo][Info][127.0.0.1][PID 7331][ThreadId 1337][note.deep:some note] message
15+[2016-06-12 12:34:56][foo][Info][127.0.0.1][7331][1337][note.deep:some note] message
16−[2016-06-12 12:34:56][foo][Info][example][PID 0][ThreadId 1337][note.deep:some note] message
16+[2016-06-12 12:34:56][foo][Info][example][0][1337][note.deep:some note] message
17−[2016-06-12 12:34:56][foo][Info][example][PID 1][ThreadId 1337][note.deep:some note] message
17+[2016-06-12 12:34:56][foo][Info][example][1][1337][note.deep:some note] message
18−[2016-06-12 12:34:56][foo][Info][example][PID 1337][ThreadId 1337][note.deep:some note] message
18+[2016-06-12 12:34:56][foo][Info][example][1337][1337][note.deep:some note] message
19−[2016-06-12 12:34:56][foo][Info][example][PID 2147483647][ThreadId 1337][note.deep:some note] message
19+[2016-06-12 12:34:56][foo][Info][example][2147483647][1337][note.deep:some note] message
20−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
20+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
21−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
21+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
22with newline
22with newline
23−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message
23+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message
24−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] сообщение
24+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] сообщение
25−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] 哈囉世界
25+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] 哈囉世界
26−[2000-01-01 00:00:00][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
26+[2000-01-01 00:00:00][foo][Info][example][7331][1337][note.deep:some note] message
27−[2123-12-31 23:59:59][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
27+[2123-12-31 23:59:59][foo][Info][example][7331][1337][note.deep:some note] message
28−[2016-10-10 01:01:05][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
28+[2016-10-10 01:01:05][foo][Info][example][7331][1337][note.deep:some note] message
29−[2100-12-31 12:59:10][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
29+[2100-12-31 12:59:10][foo][Info][example][7331][1337][note.deep:some note] message
30−[1982-01-01 12:30:00][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
30+[1982-01-01 12:30:00][foo][Info][example][7331][1337][note.deep:some note] message
31−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
31+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
32−[2016-06-12 12:34:56][foo.bar][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
32+[2016-06-12 12:34:56][foo.bar][Info][example][7331][1337][note.deep:some note] message
33−[2016-06-12 12:34:56][фу.бар][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
33+[2016-06-12 12:34:56][фу.бар][Info][example][7331][1337][note.deep:some note] message
34[2016-06-12 12:34:56][with
34[2016-06-12 12:34:56][with
35−newline][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
35+newline][Info][example][7331][1337][note.deep:some note] message
36−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message
36+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message
37−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note][main:Some.Module path/Some/Module.hs:30:1] message
37+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note][main:Some.Module path/Some/Module.hs:30:1] message
38−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note][main:Some.Module путь/Some/Module.hs:3000:9000] message
38+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note][main:Some.Module путь/Some/Module.hs:3000:9000] message
39−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][sub:null][text:][num:0][float:0] message
39+[2016-06-12 12:34:56][foo][Info][example][7331][1337][sub:null][text:][num:0][float:0] message
40−[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][sub.note.deep:some note][text:note][num:10][float:5.5] message
40+[2016-06-12 12:34:56][foo][Info][example][7331][1337][sub.note.deep:some note][text:note][num:10][float:5.5] message
katip/test/Katip/Tests/Scribes/Handle.hs+4−4
@@ -39,7 +39,7 @@ tests = testGroup "Katip.Scribes.Handle"
39 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"
39 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"
40 hClose h
40 hClose h
41 res <- readFile path
41 res <- readFile path
42− let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
42+ let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
43 let matches = res =~ pat
43 let matches = res =~ pat
44 assertBool (show res M.<> " did not match") matches
44 assertBool (show res M.<> " did not match") matches
45 , withResource setupFile (const (return ())) $ \setupScribe -> testCase "logs correct data to a file" $ do
45 , withResource setupFile (const (return ())) $ \setupScribe -> testCase "logs correct data to a file" $ do
@@ -48,7 +48,7 @@ tests = testGroup "Katip.Scribes.Handle"
48 fin
48 fin
49 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"
49 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"
50 res <- readFile path
50 res <- readFile path
51− let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
51+ let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String
52 let matches = res =~ pat
52 let matches = res =~ pat
53 assertBool (show res <> " did not match") matches
53 assertBool (show res <> " did not match") matches
54 , withResource setupTempFile teardownTempFile $ \setupFn ->
54 , withResource setupTempFile teardownTempFile $ \setupFn ->
@@ -92,7 +92,7 @@ setup :: IO (FilePath, Handle, IO (), LogEnv)
92setup = do
92setup = do
93 tempDir <- getTemporaryDirectory
93 tempDir <- getTemporaryDirectory
94 (fp, h) <- openTempFile tempDir "katip.log"
94 (fp, h) <- openTempFile tempDir "katip.log"
95− s <- mkHandleScribe (ColorLog False) h (permitItem DebugS) V3
95+ s <- mkHandleScribe (ColorLog False) h DebugS V3
96 le <- initLogEnv "katip-test" "test"
96 le <- initLogEnv "katip-test" "test"
97 le' <- registerScribe "handle" s defaultScribeSettings le
97 le' <- registerScribe "handle" s defaultScribeSettings le
98 return (fp, h, void (closeScribes le'), le')
98 return (fp, h, void (closeScribes le'), le')
@@ -111,7 +111,7 @@ setupFile = do
111 tempDir <- getTemporaryDirectory
111 tempDir <- getTemporaryDirectory
112 (fp, h) <- openTempFile tempDir "katip.log"
112 (fp, h) <- openTempFile tempDir "katip.log"
113 hClose h
113 hClose h
114− s <- mkFileScribe fp (permitItem DebugS) V3
114+ s <- mkFileScribe fp DebugS V3
115 le <- initLogEnv "katip-test" "test"
115 le <- initLogEnv "katip-test" "test"
116 le' <- registerScribe "handle" s defaultScribeSettings le
116 le' <- registerScribe "handle" s defaultScribeSettings le
117 return (fp, void (closeScribes le'), le')
117 return (fp, void (closeScribes le'), le')
stack.yaml+3−11
@@ -1,20 +1,12 @@
1−resolver: lts-16.18
1+resolver: lts-11.14
2packages:
2packages:
3 - katip
3 - katip
4 - katip-elasticsearch
4 - katip-elasticsearch
5− - katip-datadog
6− - katip-logzio
7extra-deps:
5extra-deps:
8− # ghc 8.8 support
9− - github: wireapp/bloodhound
6+ - bloodhound-0.16.0.0
10− commit: b409f52b518f20a4c20651b5893c31b7b85cb9b1
7+ - unliftio-core-0.1.1.0
11−allow-newer: true
12flags:
8flags:
13 katip:
9 katip:
14 lib-Werror: true
10 lib-Werror: true
15 katip-elasticsearch:
11 katip-elasticsearch:
16 lib-Werror: true
12 lib-Werror: true
17− katip-datadog:
18− lib-Werror: true
19− katip-logzio:
20− lib-Werror: true