0d00101 · typeable/katip

git.iko.soy/typeable/katip

on master help sign in

Merge branch 'master' of github.com:Soostone/katip

0d00101Ozgun Ataman10 years ago

.travis.yml+6−5

compare with master

unifiedsplit

@@ -14,9 +14,10 @@ addons:

14# change flags or use --stack-yaml to point to a different file.

15env:

16- ARGS=""

17−- ARGS="--resolver lts-3"

17+- ARGS="--stack-yaml=stack-lts-2.yaml"

18+- ARGS="--resolver=lts-3"

18−- ARGS="--resolver lts"

19+- ARGS="--resolver=lts"

19−- ARGS="--resolver nightly"

20+- ARGS="--stack-yaml=stack-nightly.yaml"

21before_install:

22before_install:

22# Download and unpack the stack executable

23# Download and unpack the stack executable

@@ -35,9 +36,9 @@ install:

35# around some quirks in Travis's terminal implementation.

36# around some quirks in Travis's terminal implementation.

36script:

37script:

37 - stack $ARGS setup

38 - stack $ARGS setup

38− - stack $ARGS --no-terminal test --haddock --no-haddock-deps

39+ - stack $ARGS test $BUILDFLAGS --no-terminal --haddock --no-haddock-deps

39 - stack $ARGS bench

40 - stack $ARGS bench

40− - stack $ARGS build

41+ - stack $ARGS build $BUILDFLAGS

41 - for f in katip/examples/*.hs; do stack $ARGS ghc -- -Wall -Werror $f -o /dev/null; done

42 - for f in katip/examples/*.hs; do stack $ARGS ghc -- -Wall -Werror $f -o /dev/null; done

42 - stack $ARGS sdist

43 - stack $ARGS sdist

README.md+3−3

@@ -2,7 +2,7 @@

3Katip is a structured logging framework for Haskell.

5−![Katip](./katip/katip.jpg)

5+![Katip](https://github.com/Soostone/katip/blob/master/katip/katip.jpg)

7Kâtip (pronounced kah-tip) is the Turkish word for scribe.

@@ -11,11 +11,11 @@ Kâtip (pronounced kah-tip) is the Turkish word for scribe.

11This is the core katip logging library. It includes a file handle

12logger.

14−See [katip's README](./katip/README.md) for more details.

14+See [katip's README](https://github.com/Soostone/katip/blob/master/katip/README.md) for more details.

17## katip-elasticsearch

19ElasticSearch backend for katip using the `bloodhound` package.

21−See [katip-elasticsearch's README](./katip-elasticsearch/README.md) for more details.

21+See [katip-elasticsearch's README](https://github.com/Soostone/katip/blob/master/katip-elasticsearch/README.md) for more details.

katip-elasticsearch/changelog.md+47−1

@@ -1,4 +1,50 @@

1+0.3.0.0

2+==============

3+* Added zero padding to date-based indices. This shouldn't negatively

4+ impact most users but to be safe, this was put behind a breaking

5+ version number. Previously, you may see indices

6+ `log-index-prefix-2016-1-2`. That index will now be

7+ `log-index-prefix-2016-01-02`, so at worst when you deploy, the day

8+ of the change will have 2 indices: one zero-padded and one not. If

9+ you are using custom index sharding, you will not be affected by

10+ this. The reasoning here is that most existing elasticsearch tools

11+ such as `curator` expects date indices to be zero padded. By

12+ switching to the standard, users can easily get log rotation and

13+ other features from `curator` rather than having to roll their own

14+ or add them to Katip.

15+

16+0.2.1.0

17+==============

18+

19+* Drop direct dependency on random, upgrade uuid to >= 1.3.12 for

20+ safer id generation. Previously, UUID was using randomIO, which uses

21+ the system clock as a seed. So if multiple nodes happened to start

22+ at the same time, they would produce conflicting UUID sequences.

23+

24+0.2.0.0

25+==============

26+

27+* Default index sharding policy to daily. Previously it was no

28+ sharding. The reasoning here is that no sharding creates very large

29+ indices which become very difficult to manage in

30+ production. Rotating data out on a time basis is very slow compared

31+ to deleting date-based indices.

32+

33+ Upgrade note: if you were using the defaults before and switch to

34+ daily, rather than having the index name of `my-index`, you'll start

35+ seeing `my-index-2016-3-14`. The good news is that whatever you're

36+ using to use to search against your logs (such as kibana) will

37+ support index patterns, so just use the pattern of `my-index*` to

38+ get everything. Eventually if you have a retention period, you can

39+ manually delete the `my-index` index without disruption.

40+

41+

42+0.1.1.0

43+==============

44+

45+* Set upper bounds for a few dependencies.

46+

10.1.0.0

470.1.0.0

2==============

48==============

4−Initial release

50+* Initial release

katip-elasticsearch/katip-elasticsearch.cabal+13−13

@@ -1,11 +1,11 @@

1name: katip-elasticsearch

2synopsis: ElasticSearch scribe for the Katip logging framework.

3description: See README.md for more details.

4−version: 0.1.0.0

4+version: 0.3.0.0

5license: BSD3

6license-file: LICENSE

7−author: Ozgun Ataman

7+author: Ozgun Ataman, Michael Xavier

8−maintainer: ozgun.ataman@soostone.com

8+maintainer: michael.xavier@soostone.com

9copyright: Soostone Inc, 2015-2016

10category: Data

11build-type: Simple

@@ -15,6 +15,7 @@ extra-source-files:

15 changelog.md

16 bench/Main.hs

17 test/Main.hs

18+tested-with: GHC == 7.8.4, GHC== 7.10.3

19flag lib-Werror

20flag lib-Werror

20 default: False

21 default: False

@@ -26,24 +27,23 @@ library

26 Katip.Scribes.ElasticSearch.Annotations

27 Katip.Scribes.ElasticSearch.Annotations

27 build-depends:

28 build-depends:

28 base >=4.6 && <5

29 base >=4.6 && <5

29− , katip >= 0.1.0.0 && < 0.2

30+ , katip >= 0.2.0.0 && < 0.4

30 , bloodhound >= 0.11.0.0 && < 0.12

31 , bloodhound >= 0.11.0.0 && < 0.12

31− , random >= 1.0 && < 1.2

32− , uuid >= 1.3 && < 1.4

32+ , uuid >= 1.3.12 && < 1.4

33 , aeson >=0.6 && <0.12

34 , stm >= 2.4.3 && < 2.5

35 , stm-chans >= 3.0.0.2 && < 3.1

36 , async >= 2.0.1.0 && < 2.2

37 , enclosed-exceptions >= 1.0.0 && < 1.1

38− , http-client

38+ , http-client >= 0.3 && < 0.5

39− , text

39+ , text >= 0.11 && < 1.3

40 , retry >= 0.7 && < 0.8

41 , exceptions

42− , scientific

42+ , scientific >= 0.3.0.0 && < 0.4

43− , unordered-containers

43+ , unordered-containers >= 0.1.0.0 && < 0.3

44− , transformers

44+ , transformers >= 0.2 && < 0.6

45− , http-types

45+ , http-types >= 0.8 && < 0.10

46− , time

46+ , time >= 1 && < 1.7

47 hs-source-dirs: src

48 default-language: Haskell2010

49 hs-source-dirs: src

katip-elasticsearch/src/Katip/Scribes/ElasticSearch.hs+31−10

@@ -3,6 +3,24 @@

3{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6+-- | Includes a scribe that can be used to log structured, JSON log

7+-- messages to ElasticSearch. These logs can be explored easily using

8+-- <https://www.elastic.co/products/kibana kibana> or your tool of

9+-- choice.

10+--

11+-- == __Important Note on Index Settings__

12+--

13+-- 'defaultEsScribeCfg' inherits a set of default index settings from

14+-- the @bloodhound@ package. These settings at this time of writing

15+-- set the indices up to have 3 shards and 2 replicas. This is an

16+-- arguably reasonable default setting for production but may cause

17+-- problems for development. In development, your cluster may be

18+-- configured to seek a write quorum greater than 1. If you're running

19+-- ElasticSearch on a single node, this could cause your writes to

20+-- wait for a bit and then fail due to a lack of quorum. __For development, we recommend setting your replica count to 0 or modifying your write quorum settings__. For production, we recommend reading the

21+-- <https://www.elastic.co/guide/en/elasticsearch/guide/current/scale.html ElasticSearch Scaling Guide> and choosing the appropriate settings,

22+-- keeping in mind that you can chage replica counts on a live index

23+-- but that changing shard counts requires recreating the index.

6module Katip.Scribes.ElasticSearch

24module Katip.Scribes.ElasticSearch

7 (-- * Building a scribe

25 (-- * Building a scribe

8 mkEsScribe

26 mkEsScribe

@@ -53,10 +71,11 @@ import Data.Time

53import Data.Time.Calendar.WeekDate

71import Data.Time.Calendar.WeekDate

54import Data.Typeable

72import Data.Typeable

55import Data.UUID

73import Data.UUID

74+import qualified Data.UUID.V4 as UUID4

56import Database.Bloodhound

75import Database.Bloodhound

57import Network.HTTP.Client

76import Network.HTTP.Client

58import Network.HTTP.Types.Status

77import Network.HTTP.Types.Status

59−import System.Random

78+import Text.Printf (printf)

60-------------------------------------------------------------------------------

79-------------------------------------------------------------------------------

61import Katip.Core

80import Katip.Core

62import Katip.Scribes.ElasticSearch.Annotations

81import Katip.Scribes.ElasticSearch.Annotations

@@ -64,13 +83,13 @@ import Katip.Scribes.ElasticSearch.Annotations

66data EsScribeCfg = EsScribeCfg {

85data EsScribeCfg = EsScribeCfg {

67− essRetryPolicy :: RetryPolicy

86+ essRetryPolicy :: RetryPolicy

68 -- ^ Retry policy when there are errors sending logs to the server

87 -- ^ Retry policy when there are errors sending logs to the server

69− , essQueueSize :: EsQueueSize

88+ , essQueueSize :: EsQueueSize

70 -- ^ Maximum size of the bounded log queue

89 -- ^ Maximum size of the bounded log queue

71− , essPoolSize :: EsPoolSize

90+ , essPoolSize :: EsPoolSize

72 -- ^ Worker pool size limit for sending data to the

91 -- ^ Worker pool size limit for sending data to the

73− , essAnnotateTypes :: Bool

92+ , essAnnotateTypes :: Bool

74 -- ^ Different payload items coexist in the "data" attribute in

93 -- ^ Different payload items coexist in the "data" attribute in

75 -- ES. It is possible for different payloads to have different

94 -- ES. It is possible for different payloads to have different

76 -- types for the same key, e.g. an "id" key that is sometimes a

95 -- types for the same key, e.g. an "id" key that is sometimes a

@@ -83,8 +102,8 @@ data EsScribeCfg = EsScribeCfg {

83 -- exposes a querying API, we will try to make deserialization and

102 -- exposes a querying API, we will try to make deserialization and

84 -- querying transparently remove the type annotations if this is

103 -- querying transparently remove the type annotations if this is

85 -- enabled.

104 -- enabled.

86− , essIndexSettings :: IndexSettings

105+ , essIndexSettings :: IndexSettings

87− , essIndexSharding :: IndexShardingPolicy

106+ , essIndexSharding :: IndexShardingPolicy

88 } deriving (Typeable)

107 } deriving (Typeable)

108

109

@@ -213,8 +232,10 @@ chooseIxn (IndexName ixn) p i =

213

232

214

233

215-------------------------------------------------------------------------------

234-------------------------------------------------------------------------------

216−sis :: Show a => a -> IndexNameSegment

235+sis :: Integral a => a -> IndexNameSegment

217−sis = IndexNameSegment . T.pack . show

236+sis = IndexNameSegment . T.pack . fmt

237+ where

238+ fmt = printf "%02d" . toInteger

218

239

219

240

220-------------------------------------------------------------------------------

241-------------------------------------------------------------------------------

@@ -322,7 +343,7 @@ esDateFormat = "yyyy-MM-dd'T'HH:mm:ssZ||yyyy-MM-dd'T'HH:mm:ss.SSSZ||yyyy-MM-dd'T

322

343

323-------------------------------------------------------------------------------

344-------------------------------------------------------------------------------

324mkDocId :: IO DocId

345mkDocId :: IO DocId

325−mkDocId = (DocId . T.decodeUtf8 . toASCIIBytes) `fmap` randomIO

346+mkDocId = (DocId . T.decodeUtf8 . toASCIIBytes) `fmap` UUID4.nextRandom

326

347

327

348

328-------------------------------------------------------------------------------

349-------------------------------------------------------------------------------

katip-elasticsearch/src/Katip/Scribes/ElasticSearch/Annotations.hs+2−1

@@ -31,7 +31,8 @@ instance ToJSON a => ToJSON (TypeAnnotated a) where

31 toJSON = annotateValue . toJSON . typeAnnotatedValue

34−instance ToObject a => ToObject (TypeAnnotated a)

34+instance ToObject a => ToObject (TypeAnnotated a) where

35+ toObject = annotateKeys . toObject . typeAnnotatedValue

37instance FromJSON a => FromJSON (TypeAnnotated a) where

38instance FromJSON a => FromJSON (TypeAnnotated a) where

katip-elasticsearch/test/Main.hs+41−27

@@ -100,8 +100,8 @@ esTests = testGroup "elasticsearch scribe"

100 $(logT) (ExampleCtx True) mempty InfoS "tomorrow"

101 liftIO $ do

102 void done

103− todayLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-1-2")

103+ todayLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-01-02")

104− tomorrowLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-1-3")

104+ tomorrowLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-01-03")

105 assertBool ("todayLogs has " <> show (length todayLogs) <> " items") (length todayLogs == 1)

106 assertBool ("tomorrowLogs has " <> show (length tomorrowLogs) <> " items") (length tomorrowLogs == 1)

107 let logToday = head todayLogs

@@ -118,8 +118,8 @@ esTests = testGroup "elasticsearch scribe"

118 $(logT) (ExampleCtx True) mempty InfoS "tomorrow"

119 liftIO $ do

120 void done

121− todayLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-2-28") -- rounds back to previous sunday

121+ todayLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-02-28") -- rounds back to previous sunday

122− tomorrowLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-3-6") -- is on sunday, so uses current date

122+ tomorrowLogs <- getLogsByIndex (IndexName "katip-elasticsearch-tests-2016-03-06") -- is on sunday, so uses current date

123 assertBool ("todayLogs has " <> show (length todayLogs) <> " items") (length todayLogs == 1)

124 assertBool ("tomorrowLogs has " <> show (length tomorrowLogs) <> " items") (length tomorrowLogs == 1)

125 let logToday = head todayLogs

@@ -163,12 +163,18 @@ instance LogItem ExampleCtx where

163typeAnnotatedTests :: TestTree

164typeAnnotatedTests = testGroup "TypeAnnotated"

165 [

166− testCase "annotates values on toJSON" $ do

166+ testCase "annotates values on toJSON" $

167 toJSON (TypeAnnotated exampleValue) @?= annotatedExampleValue

168+

169+ , testCase "annotates values on toObject" $

170+ toObject (TypeAnnotated exampleObject) @?= annotatedExampleObject

171+

168− , testCase "deannotates on parseJSON" $ do

172+ , testCase "deannotates on parseJSON" $

169 parseEither parseJSON (toJSON exampleValue) @?= Right exampleValue

173 parseEither parseJSON (toJSON exampleValue) @?= Right exampleValue

174+

170 , testProperty "roundtrips the same as raw" $ \(v :: Value) ->

175 , testProperty "roundtrips the same as raw" $ \(v :: Value) ->

176+ let res = typeAnnotatedValue

171− let res = typeAnnotatedValue <$> (parseEither parseJSON (toJSON (TypeAnnotated v)))

177+ <$> parseEither parseJSON (toJSON (TypeAnnotated v))

172 in res === Right v

178 in res === Right v

173 ]

179 ]

174

180

@@ -187,33 +193,41 @@ roundToSundayTests = testGroup "roundToSunday"

187 where

193 where

188 getDOW = view _3 . toWeekDate

194 getDOW = view _3 . toWeekDate

189

195

196+

197+-------------------------------------------------------------------------------

198+exampleObject :: Object

199+exampleObject = HM.fromList

200+ [ ("a bool", Bool False)

201+ , ("a long", Number 24)

202+ , ("a double", Number 52.3)

203+ , ("a string", String "s")

204+ , ("a null", Null)

205+ , ("a map", Object (HM.singleton "baz" (Bool True)))

206+ ]

207+

208+

209+-------------------------------------------------------------------------------

210+annotatedExampleObject :: Object

211+annotatedExampleObject = HM.fromList

212+ [ ("a map",Object $ HM.fromList [("baz::b", Bool True)])

213+ , ("a bool::b", Bool False)

214+ , ("a null::n", Null)

215+ , ("a string::s", String "s")

216+ , ("a double::d", Number 52.3)

217+ , ("a long::l", Number 24.0)

218+ ]

219+

220+

190-------------------------------------------------------------------------------

221-------------------------------------------------------------------------------

191exampleValue :: Value

222exampleValue :: Value

192−exampleValue = Array $ V.fromList [Null, Object ob]

223+exampleValue = Array $ V.fromList [Null, Object exampleObject]

193− where

194− ob = HM.fromList [ ("a bool", Bool False)

195− , ("a long", Number 24)

196− , ("a double", Number 52.3)

197− , ("a string", String "s")

198− , ("a null", Null)

199− , ("a map", Object (HM.singleton "baz" (Bool True)))

200− ]

201

224

202

225

203-------------------------------------------------------------------------------

226-------------------------------------------------------------------------------

204annotatedExampleValue :: Value

227annotatedExampleValue :: Value

205annotatedExampleValue = Array $ V.fromList

228annotatedExampleValue = Array $ V.fromList

206− [

207− Null

229+ [ Null

208− , Object $ HM.fromList

230+ , Object annotatedExampleObject

209− [

210− ("a map",Object $ HM.fromList [("baz::b", Bool True)])

211− , ("a bool::b", Bool False)

212− , ("a null::n", Null)

213− , ("a string::s", String "s")

214− , ("a double::d", Number 52.3)

215− , ("a long::l", Number 24.0)

216− ]

217 ]

231 ]

218

232

219

233

katip/README.md+7−3

@@ -2,7 +2,7 @@

3Katip is a structured logging framework for Haskell.

5−![Katip](./katip.jpg)

5+![Katip](https://github.com/Soostone/katip/blob/master/katip/katip.jpg)

7Kâtip (pronounced kah-tip) is the Turkish word for scribe.

@@ -69,8 +69,11 @@ Kâtip (pronounced kah-tip) is the Turkish word for scribe.

71## Examples

72+

72−Be sure to look in the [examples](./examples) directory for some examples of how

73+Be sure to look in the

74+[examples](https://github.com/Soostone/katip/blob/master/katip/examples)

73−to integrate Katip into your own stack.

75+directory for some examples of how to integrate Katip into your own

76+stack.

76## Contributors

79## Contributors

@@ -78,3 +81,4 @@ to integrate Katip into your own stack.

78* [Ozgun Ataman](https://github.com/ozataman)

81* [Ozgun Ataman](https://github.com/ozataman)

79* [Michael Xavier](https://github.com/MichaelXavier)

82* [Michael Xavier](https://github.com/MichaelXavier)

80* [Doug Beardsley](https://github.com/mightybyte)

83* [Doug Beardsley](https://github.com/mightybyte)

84+* [Leonid Onokhov](https://github.com/sopvop)

katip/bench/Main.hs+7−4

@@ -12,7 +12,7 @@ import Control.Concurrent

12import Control.DeepSeq

13import Criterion.Main

14import Data.Aeson

15−import Data.Monoid as M

15+import Data.Monoid as M

16import Data.Time.Calendar

17import Data.Time.Clock

18import System.IO

@@ -31,12 +31,15 @@ main = defaultMain [

31-------------------------------------------------------------------------------

32handleScribeBench :: Benchmark

33handleScribeBench = bgroup "Katip.Scribes.Handle" [

34− env setupEnv $ \ ~(Scribe push, tid) ->

34+ env setupHandleEnv $ \ ~(Scribe push, tid) ->

35 bench "Bytestring Builder" $

36 whnfIO $ push $ exItem tid

37 ]

38− where

38+

39− setupEnv = do

39+

40+-------------------------------------------------------------------------------

41+setupHandleEnv :: IO (Scribe, ThreadIdText)

42+setupHandleEnv = do

40 scribe <- setup

43 scribe <- setup

41 tid <- myThreadId

44 tid <- myThreadId

42 return (scribe, mkThreadIdText tid)

45 return (scribe, mkThreadIdText tid)

katip/changelog.md+42−1

@@ -1,4 +1,45 @@

1+0.3.1.0

2+=======

3+* Add support for aeson 1.0.x

4+* Add Katip.Format.Time module and use much more efficient time formatting code in the Handle scribe.

6+0.3.0.0

7+=======

8+* Switch from `regex-tdfa-rc` to `regex-tdfa`.

9+* Add `katipNoLogging` combinator.

10+* Add `Semigroup` instances.

11+* Drop `ToJSON` superclass requirement fro `ToObject`. Instead,

12+ `ToObject` will provide a default instance for types with an

13+ instance for `ToJSON`. This gets us to the same place as before

14+ without having to add a broader instance for something that's only

15+ going to show up in logs as an Object.

16+* Add a simple MVar lock for file handle scribes to avoid interleaved

17+ log lines from concurrent inputs.

18+

19+0.2.0.0

20+=======

21+

22+* Add GHC implicit callstack support, add logLoc.

23+* Drop lens in favor of type-compatible, lighter microlens.

24+* Renamed `logEnvNs` to clearer `logEnvApp`

25+* Added `katipAddNamespace` and `katipAddContext`

26+* Fixed nested objects not rendering in Handle scribe.

27+* LogContexts Monoid instance is now right-biased rather than left

28+ biased. This better fits the use case. For instance `ctx1 <> ctx2`

29+ will prefer keys in `ctx2` if there are conflicts. This makes the

30+ most sense because functions like `katipAddContext` will `mappend`

31+ on the right side.

32+* LogContext internally uses a `Seq` instead of a list for better

33+ complexity on context add.

34+* Improved documentation.

35+

36+0.1.1.0

37+==============

38+

39+* Set upper bounds for a few dependencies.

40+* Add ExceptT instance for Katip typeclass

41+

10.1.0.0

420.1.0.0

2==============

43==============

4−Initial release

45+* Initial release

katip/examples/add_context_loop.hsnew file+69

@@ -0,0 +1,69 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+-- | This executable is a test which runs addContext with

3+-- key-compatible log contexts in a tight loop. At time of writing, I

4+-- suspect this will result in a memory leak as we just naively

5+-- concatenate it into a sequence. If instead we eagerly merge the log

6+-- objects, each loop will overwrite the previous context and there

7+-- will be no memory leak. You can pass a numeric argument to this

8+-- executable to specify how many loops to do. -1 goes infinite.

9+--

10+-- If we didn't have to retain the log context and could eagerly merge

11+-- it, this wouldn't be an issue, but unfortunately we don't know

12+-- which keys to keep until log time, not context add time. Further,

13+-- we couldn't accumulate and compose key retention functions for the

14+-- same reason.

15+module Main

16+ ( main

17+ ) where

18+

19+

20+-------------------------------------------------------------------------------

21+import Control.Monad (unless, forever)

22+import qualified Data.Aeson as A

23+import qualified Data.HashMap.Strict as HM

24+import qualified Data.String.Conv as SC

25+import qualified System.Environment as SE

26+-------------------------------------------------------------------------------

27+import qualified Katip as K

28+-------------------------------------------------------------------------------

29+

30+

31+main :: IO ()

32+main = do

33+ args <- SE.getArgs

34+ le <- K.initLogEnv "add_context_loop" "test"

35+ K.runKatipContextT le () "loop" $ case args of

36+ [] -> run (Just 1000000)

37+ ns:_ -> let n = read ns

38+ in if n < 0

39+ then run Nothing

40+ else run (Just n)

41+

42+

43+-------------------------------------------------------------------------------

44+-- | Semantically, each loop adds more context on. If we were using

45+-- something like forever, unfoldM, etc, which is probably what we

46+-- actually want, it would add the same context each time,

47+-- non-redundantly and thus no leak.

48+run :: Maybe Int -> K.KatipContextT IO ()

49+run mlim = go 0

50+ where

51+ go n = do

52+ K.katipAddContext (SomeContext 1000) $ do

53+ K.logFM K.InfoS "loop"

54+ unless (done n) $ go (n + 1)

55+ done n = case mlim of

56+ Nothing -> False

57+ Just lim -> n >= lim

58+

59+

60+-------------------------------------------------------------------------------

61+data SomeContext = SomeContext Int

62+

63+

64+instance K.ToObject SomeContext where

65+ toObject (SomeContext sz) = HM.fromList [ SC.toS (show n) A..= () | n <- [0..sz]]

66+

67+

68+instance K.LogItem SomeContext where

69+ payloadKeys _ _ = K.AllKeys

katip/examples/example.hs+38−4

@@ -1,18 +1,24 @@

1{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE TemplateHaskell #-}

6{-# LANGUAGE TemplateHaskell #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE UndecidableInstances #-}

6module Main

9module Main

7 ( main

10 ( main

8 ) where

11 ) where

11-------------------------------------------------------------------------------

14-------------------------------------------------------------------------------

15+import qualified Control.Applicative as A

16+import Control.Monad.Base

12import Control.Monad.Reader

17import Control.Monad.Reader

18+import Control.Monad.Trans.Control

13import Data.Aeson

19import Data.Aeson

14−import Data.Monoid as M

20+import Data.Monoid as M

15−import System.IO (stdout)

21+import System.IO (stdout)

16-------------------------------------------------------------------------------

22-------------------------------------------------------------------------------

17import Katip

23import Katip

18-------------------------------------------------------------------------------

24-------------------------------------------------------------------------------

@@ -22,7 +28,7 @@ import Katip

22-- lens_example for a slightly cleaner and more general pattern.

28-- lens_example for a slightly cleaner and more general pattern.

23main :: IO ()

29main :: IO ()

24main = do

30main = do

25− le <- initLogEnv "main" "production"

31+ le <- initLogEnv "MyApp" "production"

26 -- We'll set up a scribe that logs to stdout and will only log item

32 -- We'll set up a scribe that logs to stdout and will only log item

27 -- fields permitted for Verbosity 2 and will throw out Debug

33 -- fields permitted for Verbosity 2 and will throw out Debug

28 -- messages entirely. Note that katip provides facilities like

34 -- messages entirely. Note that katip provides facilities like

@@ -44,6 +50,8 @@ main = do

44 $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"

50 $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"

45 confrabulateWidgets

51 confrabulateWidgets

46 $(logTM) InfoS "Namespace and context are back to normal"

52 $(logTM) InfoS "Namespace and context are back to normal"

53+ noLogging $

54+ $(logTM) DebugS "You'll never see this log message!"

49-------------------------------------------------------------------------------

57-------------------------------------------------------------------------------

@@ -77,7 +85,27 @@ data MyState = MyState {

77-------------------------------------------------------------------------------

85-------------------------------------------------------------------------------

78newtype MyStack m a = MyStack {

86newtype MyStack m a = MyStack {

79 unStack :: ReaderT MyState m a

87 unStack :: ReaderT MyState m a

80− } deriving (MonadReader MyState, Functor, Applicative, Monad, MonadIO)

88+ } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)

89+

90+

91+-- MonadBase, MonadTransControl, and MonadBaseControl aren't strictly

92+-- needed for this example, but they are commonly required and

93+-- MonadTransControl/MonadBaseControl are a pain to implement, so I've

94+-- included them. Note that KatipT and KatipContextT already do this work for you.

95+instance MonadBase b m => MonadBase b (MyStack m) where

96+ liftBase = liftBaseDefault

97+

98+

99+instance MonadTransControl MyStack where

100+ type StT MyStack a = StT (ReaderT Int) a

101+ liftWith = defaultLiftWith MyStack unStack

102+ restoreT = defaultRestoreT MyStack

103+

104+

105+instance MonadBaseControl b m => MonadBaseControl b (MyStack m) where

106+ type StM (MyStack m) a = ComposeSt MyStack m a

107+ liftBaseWith = defaultLiftBaseWith

108+ restoreM = defaultRestoreM

109

110

83instance (MonadIO m) => Katip (MyStack m) where

111instance (MonadIO m) => Katip (MyStack m) where

@@ -103,6 +131,12 @@ addNamespace :: (MonadReader MyState m) => Namespace -> m a -> m a

103addNamespace ns = local (\r -> r { msKNamespace = msKNamespace r <> ns })

131addNamespace ns = local (\r -> r { msKNamespace = msKNamespace r <> ns })

104

132

105

133

134+-------------------------------------------------------------------------------

135+-- | Disable all log output temporarily

136+noLogging :: (MonadReader MyState m) => m a -> m a

137+noLogging = local (\r -> r { msLogEnv = clearScribes (msLogEnv r)})

138+

139+

106-------------------------------------------------------------------------------

140-------------------------------------------------------------------------------

107runStack :: MyState -> MyStack m a -> m a

141runStack :: MyState -> MyStack m a -> m a

108runStack s f = runReaderT (unStack f) s

142runStack s f = runReaderT (unStack f) s

katip/examples/example_lens.hs+38−5

@@ -1,19 +1,25 @@

1{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE TemplateHaskell #-}

6{-# LANGUAGE TemplateHaskell #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE UndecidableInstances #-}

6module Main

9module Main

7 ( main

10 ( main

8 ) where

11 ) where

11-------------------------------------------------------------------------------

14-------------------------------------------------------------------------------

12−import Control.Lens hiding ((.=))

15+import Control.Applicative as A

16+import Control.Lens hiding ((.=))

17+import Control.Monad.Base

13import Control.Monad.Reader

18import Control.Monad.Reader

19+import Control.Monad.Trans.Control

14import Data.Aeson

20import Data.Aeson

15−import Data.Monoid as M

21+import Data.Monoid as M

16−import System.IO (stdout)

22+import System.IO (stdout)

17-------------------------------------------------------------------------------

23-------------------------------------------------------------------------------

18import Katip

24import Katip

19-------------------------------------------------------------------------------

25-------------------------------------------------------------------------------

@@ -38,7 +44,7 @@ makeClassy ''MyState

38-- lens_example for a slightly cleaner and more general pattern.

44-- lens_example for a slightly cleaner and more general pattern.

39main :: IO ()

45main :: IO ()

40main = do

46main = do

41− le <- initLogEnv "main" "production"

47+ le <- initLogEnv "MyApp" "production"

42 -- We'll set up a scribe that logs to stdout and will only log item

48 -- We'll set up a scribe that logs to stdout and will only log item

43 -- fields permitted for Verbosity 2 and will throw out Debug

49 -- fields permitted for Verbosity 2 and will throw out Debug

44 -- messages entirely. Note that katip provides facilities like

50 -- messages entirely. Note that katip provides facilities like

@@ -60,6 +66,8 @@ main = do

60 $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"

66 $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"

61 confrabulateWidgets

67 confrabulateWidgets

62 $(logTM) InfoS "Namespace and context are back to normal"

68 $(logTM) InfoS "Namespace and context are back to normal"

69+ noLogging $

70+ $(logTM) DebugS "You'll never see this log message!"

65-------------------------------------------------------------------------------

73-------------------------------------------------------------------------------

@@ -85,9 +93,28 @@ confrabulateWidgets = return ()

85-------------------------------------------------------------------------------

93-------------------------------------------------------------------------------

86newtype MyStack m a = MyStack {

94newtype MyStack m a = MyStack {

87 unStack :: ReaderT MyState m a

95 unStack :: ReaderT MyState m a

88− } deriving (MonadReader MyState, Functor, Applicative, Monad, MonadIO)

96+ } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)

99+-- MonadBase, MonadTransControl, and MonadBaseControl aren't strictly

100+-- needed for this example, but they are commonly required and

101+-- MonadTransControl/MonadBaseControl are a pain to implement, so I've

102+-- included them. Note that KatipT and KatipContextT already do this work for you.

103+instance MonadBase b m => MonadBase b (MyStack m) where

104+ liftBase = liftBaseDefault

105+

106+

107+instance MonadTransControl MyStack where

108+ type StT MyStack a = StT (ReaderT Int) a

109+ liftWith = defaultLiftWith MyStack unStack

110+ restoreT = defaultRestoreT MyStack

111+

112+

113+instance MonadBaseControl b m => MonadBaseControl b (MyStack m) where

114+ type StM (MyStack m) a = ComposeSt MyStack m a

115+ liftBaseWith = defaultLiftBaseWith

116+ restoreM = defaultRestoreM

117+

91instance (MonadIO m) => Katip (MyStack m) where

118instance (MonadIO m) => Katip (MyStack m) where

92 getLogEnv = view msLogEnv

119 getLogEnv = view msLogEnv

120

@@ -111,6 +138,12 @@ addNamespace :: (MonadReader r m, HasMyState r) => Namespace -> m a -> m a

111addNamespace ns = local (\r -> r & msKNamespace <>~ ns)

138addNamespace ns = local (\r -> r & msKNamespace <>~ ns)

112

139

113

140

141+-------------------------------------------------------------------------------

142+-- | Disable all log output temporarily

143+noLogging :: (MonadReader r m, HasMyState r) => m a -> m a

144+noLogging = local (\r -> r & msLogEnv %~ clearScribes)

145+

146+

114-------------------------------------------------------------------------------

147-------------------------------------------------------------------------------

115runStack :: MyState -> MyStack m a -> m a

148runStack :: MyState -> MyStack m a -> m a

116runStack s f = runReaderT (unStack f) s

149runStack s f = runReaderT (unStack f) s

katip/katip.cabal+29−16

@@ -1,15 +1,17 @@

1name: katip

2−version: 0.1.0.0

2+version: 0.3.1.0

3synopsis: A structured logging framework.

4description:

5 Katip is a structured logging framework. See README.md for more details.

7license: BSD3

8license-file: LICENSE

9−author: Ozgun Ataman

9+author: Ozgun Ataman, Michael Xavier

10−maintainer: ozgun.ataman@soostone.com

10+maintainer: michael.xavier@soostone.com

11copyright: Soostone Inc, 2015-2016

12category: Data, Text, Logging

13+homepage: https://github.com/Soostone/katip

14+bug-reports: https://github.com/Soostone/katip/issues

13build-type: Simple

15build-type: Simple

14cabal-version: >=1.10

16cabal-version: >=1.10

15extra-source-files:

17extra-source-files:

@@ -21,6 +23,11 @@ extra-source-files:

21 test/Main.hs

23 test/Main.hs

22 test/Katip/Tests.hs

24 test/Katip/Tests.hs

23 test/Katip/Tests/Scribes/Handle.hs

25 test/Katip/Tests/Scribes/Handle.hs

26+tested-with: GHC == 7.8.4, GHC== 7.10.3

27+

28+source-repository head

29+ type: git

30+ location: https://github.com/Soostone/katip.git

25flag lib-Werror

32flag lib-Werror

26 default: False

33 default: False

@@ -30,6 +37,7 @@ library

30 exposed-modules:

37 exposed-modules:

31 Katip

38 Katip

32 Katip.Core

39 Katip.Core

40+ Katip.Format.Time

33 Katip.Monadic

41 Katip.Monadic

34 Katip.Scribes.Handle

42 Katip.Scribes.Handle

@@ -44,29 +52,29 @@ library

44 OverloadedStrings

52 OverloadedStrings

46 build-depends: base >=4.5 && <5

54 build-depends: base >=4.5 && <5

47− , aeson >=0.6 && <0.12

55+ , aeson >=0.6 && <1.1

48 , auto-update >= 0.1 && < 0.2

56 , auto-update >= 0.1 && < 0.2

49 , bytestring >= 0.9 && < 0.11

57 , bytestring >= 0.9 && < 0.11

50 , containers >=0.4 && <0.6

58 , containers >=0.4 && <0.6

51 , either >= 4 && < 4.5

59 , either >= 4 && < 4.5

52 , exceptions >= 0.5 && < 0.9

60 , exceptions >= 0.5 && < 0.9

53 , hostname >=1.0 && <1.1

61 , hostname >=1.0 && <1.1

54− , lens >= 4.4 && <4.14

55− , lens-aeson < 1.1

56 , old-locale >= 1.0 && < 1.1

62 , old-locale >= 1.0 && < 1.1

57 , string-conv >= 0.1 && < 0.2

63 , string-conv >= 0.1 && < 0.2

58− , template-haskell >= 2.8 && < 2.11

64+ , template-haskell >= 2.8 && < 2.12

59 , text >= 0.11 && <1.3

65 , text >= 0.11 && <1.3

60− , time >= 1 && < 1.6

66+ , time >= 1 && < 1.7

61− , time-locale-compat >= 0.1.0.1 && < 0.2

62− , transformers >= 0.3 && < 0.5

67+ , transformers >= 0.3 && < 0.6

63 , transformers-compat

68 , transformers-compat

64 , unix >= 2.5 && < 2.8

69 , unix >= 2.5 && < 2.8

65 , unordered-containers >= 0.2 && < 0.3

70 , unordered-containers >= 0.2 && < 0.3

66 , monad-control >= 1.0 && < 1.1

71 , monad-control >= 1.0 && < 1.1

67− , mtl

72+ , mtl >= 2.0 && < 2.3

68− , transformers-base

73+ , transformers-base >= 0.3 && < 0.6

69− , resourcet

74+ , resourcet >= 1.1 && < 1.2

75+ , microlens >= 0.2.0.0 && < 0.5

76+ , microlens-th >= 0.1.0.0 && < 0.5

77+ , semigroups

71 hs-source-dirs: src

79 hs-source-dirs: src

72 default-language: Haskell2010

80 default-language: Haskell2010

@@ -82,24 +90,28 @@ test-suite test

82 build-depends: base

90 build-depends: base

83 , katip

91 , katip

84 , aeson

92 , aeson

93+ , bytestring

85 , tasty >= 0.10.1.2

94 , tasty >= 0.10.1.2

95+ , tasty-golden

86 , tasty-hunit

96 , tasty-hunit

87 , tasty-quickcheck

97 , tasty-quickcheck

88 , quickcheck-instances

98 , quickcheck-instances

89 , template-haskell

99 , template-haskell

90 , text

100 , text

91 , time

101 , time

102+ , time-locale-compat >= 0.1.0.1 && < 0.2

92 , temporary

103 , temporary

93 , directory

104 , directory

94− , regex-tdfa-rc

105+ , regex-tdfa

95−

106+ , unordered-containers

107+ , microlens

108

97benchmark bench

109benchmark bench

98 type: exitcode-stdio-1.0

110 type: exitcode-stdio-1.0

99 main-is: Main.hs

111 main-is: Main.hs

100 hs-source-dirs: bench

112 hs-source-dirs: bench

101 default-language: Haskell2010

113 default-language: Haskell2010

102− ghc-options: -O2 -Wall

114+ ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N

103 if flag(lib-Werror)

115 if flag(lib-Werror)

104 ghc-options: -Werror

116 ghc-options: -Werror

105 build-depends:

117 build-depends:

@@ -113,3 +125,4 @@ benchmark bench

113 , time

125 , time

114 , transformers

126 , transformers

115 , deepseq

127 , deepseq

128+ , async

katip/src/Katip.hs+109−13

@@ -26,17 +26,22 @@ module Katip

26 (

28 -- * Framework Types

29−

30− Katip (..)

31− , Namespace (..)

29+ Namespace (..)

32 , Environment (..)

30 , Environment (..)

33 , Severity (..)

31 , Severity (..)

34 , renderSeverity

32 , renderSeverity

35− , severityText

33+ , textToSeverity

36 , Verbosity (..)

34 , Verbosity (..)

37 , ToObject (..)

35 , ToObject (..)

38 , LogItem (..)

36 , LogItem (..)

39 , Item(..)

37 , Item(..)

38+ , ThreadIdText(..)

39+ , PayloadSelection (..)

40+ , Scribe (..)

41+ , LogEnv (..)

42+ , SimpleLogPayload, sl

43+

44+ -- ** @lens@-compatible Lenses

40 , itemApp

45 , itemApp

41 , itemEnv

46 , itemEnv

42 , itemSeverity

47 , itemSeverity

@@ -48,20 +53,12 @@ module Katip

48 , itemTime

53 , itemTime

49 , itemNamespace

54 , itemNamespace

50 , itemLoc

55 , itemLoc

51− , ThreadIdText(..)

52− , PayloadSelection (..)

53− , Scribe (..)

54− , LogEnv (..)

55 , logEnvHost

56 , logEnvHost

56 , logEnvPid

57 , logEnvPid

57− , logEnvNs

58+ , logEnvApp

58 , logEnvEnv

59 , logEnvEnv

59 , logEnvTimer

60 , logEnvTimer

60 , logEnvScribes

61 , logEnvScribes

61− , KatipContext(..)

62− , AnyLogContext

63− , LogContexts, liftPayload

64− , SimpleLogPayload, sl

66 -- * A Built-in Monad For Logging

63 -- * A Built-in Monad For Logging

67 , KatipT (..)

64 , KatipT (..)

@@ -77,15 +74,23 @@ module Katip

77 , LogStr (..)

74 , LogStr (..)

78 , logStr, ls, showLS

75 , logStr, ls, showLS

77+ -- ** 'Katip' LoggingFunctions

78+ -- $katiplogging

79+ , Katip (..)

80 , logF

81 , logMsg

82 , logT

83 , logItem

84 , logException

85+ -- ** 'KatipContext' Logging Functions

86+ -- $katipcontextlogging

87+ , KatipContext (..)

85 , logFM

88 , logFM

86 , logTM

89 , logTM

87 , logItemM

90 , logItemM

88 , logExceptionM

91 , logExceptionM

92+ , AnyLogContext

93+ , LogContexts, liftPayload

90 -- * Included Scribes

95 -- * Included Scribes

91 , mkHandleScribe

96 , mkHandleScribe

@@ -99,6 +104,9 @@ module Katip

99 -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances

104 -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances

100 , KatipContextT

105 , KatipContextT

101 , runKatipContextT

106 , runKatipContextT

107+ , katipAddNamespace

108+ , katipAddContext

109+ , katipNoLogging

102 ) where

110 ) where

103

111

104-------------------------------------------------------------------------------

112-------------------------------------------------------------------------------

@@ -106,3 +114,91 @@ import Katip.Core

106import Katip.Monadic

114import Katip.Monadic

107import Katip.Scribes.Handle

115import Katip.Scribes.Handle

108-------------------------------------------------------------------------------

116-------------------------------------------------------------------------------

117+

118+

119+{- $katiplogging

120+

121+ These logging functions use the basic 'Katip' constraint and thus

122+will require varying degrees of explicit detail such as 'Namespace'

123+and individual log items to be passed in. These can be described as

124+the primitives of Katip logging. If you find yourself making multiple

125+log statements within a logical logging context for your app, you may

126+want to look into the 'KatipContext' family of logging functions like

127+'logFM' and 'logTM'. 'KatipContext' in most applications should be

128+considered the default. Here's an example of the pain point:

129+

130+@

131+doDatabaseThings = do

132+ connId <- getConnectionId

133+ logF (ConnectionIDContext connId) "database" InfoS "Doing database stuff"

134+ \-\- ...

135+ logF (ConnectionIDContext connId) "database" InfoS "Wow, passing in the same context is getting tedious"

136+@

137+

138+Another pain point to look out for is nesting actions that log in

139+eachother. Let's say you were writing a web app. You want to capture

140+some detail such as the user's ID in the logs, but you also want that

141+info to show up in doDatabaseThings' logs so you can associate those

142+two pieces of information:

143+

144+

145+@

146+webRequestHandler = do

147+ uid <- getUserId

148+ logF (UserIDContext uid) "web" InfoS "Starting web request"

149+ doDatabaseThings

150+@

151+

152+In the above example, doDatabaseThings would overwrite that

153+UderIDContext with its own context and namespace. Sometimes this is

154+what you want and that's why 'logF' and other functions which only

155+require 'Katip' exist. If you are interested in combining log

156+contexts and namespaces, see 'KatipContext'.

157+-}

158+

159+

160+{- $katipcontextlogging

161+

162+ These logging functions use the 'KatipContext' constraint which is a

163+superclass of 'Katip' that also has a mechanism for keeping track of

164+the current context and namespace. This means a few things:

165+

166+1. Functions that use 'KatipContext' like 'logFM' and 'logTM' do not

167+require you to pass in 'LogItem's or 'Namespaces', they pull them from

168+the monadic environment.

169+

170+2. It becomes easy to add functions which add namespaces and/or

171+contexts to the current stack of them. You can (and should) make that

172+action scoped to a monadic action so that when it finishes, the

173+previous context and namespace will be automatically restored.

174+

175+

176+'KatipContextT' provides a simple, 'ReaderT'-based implementation of

177+the 'KatipContext' typeclass, and provides 'katipAddContext' and

178+'katipAddNamespace' functions to append to the context for the

179+duration of a block:

180+

181+

182+@

183+main = do

184+ le <- initLogEnv "MyApp" "production"

185+ \-\- set up scribes here

186+ runKatipContext le () "main" $ do

187+ katipAddNamespace "nextlevel" $ do

188+ $(logTM) InfoS "Logs here will have namespace MyApp.main.nextlevel"

189+

190+ katipAddContext TrivialContext $ do

191+ $(logTM) InfoS "Logs here will have context from TrivialContext"

192+

193+ katipAddContext AnotherContext $ do

194+ $(logTM) InfoS "Logs here will have context from TrivialContext *merged with* context from AnotherContext!"

195+

196+ $(logTM) InfoS "Log context restored to () and namespace to MyApp.main"

197+@

198+

199+'katipAddNamespace' and 'katipAddContext' are one-liners, implemented

200+in terms of 'local' from 'MonadReader'. If you have a custom monad

201+transformer stack and want to add your own version of these, check out

202+<https://github.com/Soostone/katip/tree/master/katip/examples these

203+examples>.

204+-}

katip/src/Katip/Core.hs+154−52

@@ -1,9 +1,12 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DefaultSignatures #-}

1{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9+{-# LANGUAGE ImplicitParams #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RankNTypes #-}

@@ -11,14 +14,17 @@

11{-# LANGUAGE TemplateHaskell #-}

14{-# LANGUAGE TemplateHaskell #-}

12{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE UndecidableInstances #-}

16{-# LANGUAGE UndecidableInstances #-}

17+#if MIN_VERSION_base(4, 9, 0)

18+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

19+#endif

20+-- | This module is not meant to be imported directly and may contain

21+-- internal mechanisms that will change without notice.

14module Katip.Core where

22module Katip.Core where

16-------------------------------------------------------------------------------

24-------------------------------------------------------------------------------

17import Control.Applicative as A

25import Control.Applicative as A

18import Control.AutoUpdate

26import Control.AutoUpdate

19import Control.Concurrent

27import Control.Concurrent

20−import Control.Lens

21−import Control.Monad

22import Control.Monad.Base

28import Control.Monad.Base

23import Control.Monad.Catch

29import Control.Monad.Catch

24import Control.Monad.IO.Class

30import Control.Monad.IO.Class

@@ -38,7 +44,7 @@ import Data.Foldable as FT

38import qualified Data.HashMap.Strict as HM

44import qualified Data.HashMap.Strict as HM

39import Data.List

45import Data.List

40import qualified Data.Map.Strict as M

46import qualified Data.Map.Strict as M

41−import Data.Monoid

47+import Data.Semigroup

42import Data.String

48import Data.String

43import Data.String.Conv

49import Data.String.Conv

44import Data.Text (Text)

50import Data.Text (Text)

@@ -46,13 +52,28 @@ import qualified Data.Text as T

46import qualified Data.Text.Lazy.Builder as B

52import qualified Data.Text.Lazy.Builder as B

47import Data.Time

53import Data.Time

48import GHC.Generics hiding (to)

54import GHC.Generics hiding (to)

55+#if MIN_VERSION_base(4, 8, 0)

56+#if !MIN_VERSION_base(4, 9, 0)

57+import GHC.SrcLoc

58+#endif

59+import GHC.Stack

60+#endif

49import Language.Haskell.TH

61import Language.Haskell.TH

50import qualified Language.Haskell.TH.Syntax as TH

62import qualified Language.Haskell.TH.Syntax as TH

63+import Lens.Micro

64+import Lens.Micro.TH

51import Network.HostName

65import Network.HostName

52import System.Posix

66import System.Posix

53-------------------------------------------------------------------------------

67-------------------------------------------------------------------------------

70+readMay :: Read a => String -> Maybe a

71+readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of

72+ [x] -> Just x

73+ [] -> Nothing -- no parse

74+ _ -> Nothing -- Ambiguous parse

75+

76+

56-------------------------------------------------------------------------------

77-------------------------------------------------------------------------------

57-- | Represents a heirarchy of namespaces going from general to

78-- | Represents a heirarchy of namespaces going from general to

58-- specific. For instance: ["processname", "subsystem"]. Note that

79-- specific. For instance: ["processname", "subsystem"]. Note that

@@ -60,7 +81,7 @@ import System.Posix

60-- IsString/OverloadedStrings, so "foo" will result in Namespace

81-- IsString/OverloadedStrings, so "foo" will result in Namespace

61-- ["foo"].

82-- ["foo"].

62newtype Namespace = Namespace { unNamespace :: [Text] }

83newtype Namespace = Namespace { unNamespace :: [Text] }

63− deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Monoid)

84+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Semigroup,Monoid)

65instance IsString Namespace where

86instance IsString Namespace where

66 fromString s = Namespace [fromString s]

87 fromString s = Namespace [fromString s]

@@ -117,27 +138,25 @@ renderSeverity s = case s of

117

138

118

139

119-------------------------------------------------------------------------------

140-------------------------------------------------------------------------------

120−severityText :: Prism' Text Severity

141+textToSeverity :: Text -> Maybe Severity

121−severityText = prism renderSeverity toSev

122− where

123− toSev "Debug" = Right DebugS

142+textToSeverity "Debug" = Just DebugS

124− toSev "Info" = Right InfoS

143+textToSeverity "Info" = Just InfoS

125− toSev "Notice" = Right NoticeS

144+textToSeverity "Notice" = Just NoticeS

126− toSev "Warning" = Right WarningS

145+textToSeverity "Warning" = Just WarningS

127− toSev "Error" = Right ErrorS

146+textToSeverity "Error" = Just ErrorS

128− toSev "Critical" = Right CriticalS

147+textToSeverity "Critical" = Just CriticalS

129− toSev "Alert" = Right AlertS

148+textToSeverity "Alert" = Just AlertS

130− toSev "Emergency" = Right EmergencyS

149+textToSeverity "Emergency" = Just EmergencyS

131− toSev x = Left x

150+textToSeverity _ = Nothing

132

151

133−instance ToJSON Severity where

134− toJSON s = A.String (s ^. re severityText)

135

152

153+instance ToJSON Severity where

154+ toJSON s = A.String (renderSeverity s)

136

155

137instance FromJSON Severity where

156instance FromJSON Severity where

138 parseJSON = A.withText "Severity" parseSeverity

157 parseJSON = A.withText "Severity" parseSeverity

139 where

158 where

140− parseSeverity t = case t ^? severityText of

159+ parseSeverity t = case textToSeverity t of

141 Just x -> return x

160 Just x -> return x

142 Nothing -> fail $ "Invalid Severity " ++ toS t

161 Nothing -> fail $ "Invalid Severity " ++ toS t

143

162

@@ -150,10 +169,16 @@ newtype LogStr = LogStr { unLogStr :: B.Builder }

150instance IsString LogStr where

169instance IsString LogStr where

151 fromString = LogStr . B.fromString

170 fromString = LogStr . B.fromString

152

171

172+

173+instance Semigroup LogStr where

174+ (LogStr a) <> (LogStr b) = LogStr (a <> b)

175+

176+

153instance Monoid LogStr where

177instance Monoid LogStr where

154− mappend (LogStr a) (LogStr b) = LogStr (a `mappend` b)

178+ mappend = (<>)

155 mempty = LogStr mempty

179 mempty = LogStr mempty

156

180

181+

157instance FromJSON LogStr where

182instance FromJSON LogStr where

158 parseJSON = A.withText "LogStr" parseLogStr

183 parseJSON = A.withText "LogStr" parseLogStr

159 where

184 where

@@ -290,13 +315,12 @@ instance FromJSON a => FromJSON (Item a) where

290 <*> (fmap getLocJs <$> o A..: "loc")

315 <*> (fmap getLocJs <$> o A..: "loc")

291

316

292

317

293−processIDText :: Prism' Text ProcessID

318+processIDToText :: ProcessID -> Text

294−processIDText = prism fromProcessID toProcessID

319+processIDToText = toS . show

295− where

320+

296− fromProcessID = toS . show

321+

297− toProcessID t = case toS t ^? _Show of

322+textToProcessID :: Text -> Maybe ProcessID

298− Just i -> Right i

323+textToProcessID = readMay . toS

299− Nothing -> Left t

300

324

301

325

302newtype ProcessIDJs = ProcessIDJs {

326newtype ProcessIDJs = ProcessIDJs {

@@ -305,13 +329,13 @@ newtype ProcessIDJs = ProcessIDJs {

305

329

306

330

307instance ToJSON ProcessIDJs where

331instance ToJSON ProcessIDJs where

308− toJSON (ProcessIDJs p) = A.String (p ^. re processIDText)

332+ toJSON (ProcessIDJs p) = A.String (processIDToText p)

309

333

310

334

311instance FromJSON ProcessIDJs where

335instance FromJSON ProcessIDJs where

312 parseJSON = A.withText "ProcessID" parseProcessID

336 parseJSON = A.withText "ProcessID" parseProcessID

313 where

337 where

314− parseProcessID t = case t ^? processIDText of

338+ parseProcessID t = case textToProcessID t of

315 Just p -> return $ ProcessIDJs p

339 Just p -> return $ ProcessIDJs p

316 Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t

340 Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t

317

341

@@ -321,12 +345,17 @@ instance FromJSON ProcessIDJs where

321data PayloadSelection

345data PayloadSelection

322 = AllKeys

346 = AllKeys

323 | SomeKeys [Text]

347 | SomeKeys [Text]

348+ deriving (Show, Eq)

349+

350+instance Semigroup PayloadSelection where

351+ AllKeys <> _ = AllKeys

352+ _ <> AllKeys = AllKeys

353+ SomeKeys as <> SomeKeys bs = SomeKeys (as <> bs)

354+

324

355

325instance Monoid PayloadSelection where

356instance Monoid PayloadSelection where

326 mempty = SomeKeys []

357 mempty = SomeKeys []

327− mappend AllKeys _ = AllKeys

358+ mappend = (<>)

328− mappend _ AllKeys = AllKeys

329− mappend (SomeKeys as) (SomeKeys bs) = SomeKeys (as++bs)

330

359

331

360

332-------------------------------------------------------------------------------

361-------------------------------------------------------------------------------

@@ -339,8 +368,9 @@ instance Monoid PayloadSelection where

339-- a ToJSON instance like:

368-- a ToJSON instance like:

340--

369--

341-- > instance ToObject Foo

370-- > instance ToObject Foo

342−class ToJSON a => ToObject a where

371+class ToObject a where

343 toObject :: a -> A.Object

372 toObject :: a -> A.Object

373+ default toObject :: ToJSON a => a -> A.Object

344 toObject v = case toJSON v of

374 toObject v = case toJSON v of

345 A.Object o -> o

375 A.Object o -> o

346 _ -> mempty

376 _ -> mempty

@@ -389,15 +419,22 @@ instance ToJSON SimpleLogPayload where

389 toJSON (SimpleLogPayload as) = object $ map go as

419 toJSON (SimpleLogPayload as) = object $ map go as

390 where go (k, AnyLogPayload v) = k A..= v

420 where go (k, AnyLogPayload v) = k A..= v

391

421

422+

392instance ToObject SimpleLogPayload

423instance ToObject SimpleLogPayload

393

424

425+

394instance LogItem SimpleLogPayload where

426instance LogItem SimpleLogPayload where

395 payloadKeys V0 _ = SomeKeys []

427 payloadKeys V0 _ = SomeKeys []

396 payloadKeys _ _ = AllKeys

428 payloadKeys _ _ = AllKeys

397

429

430+

431+instance Semigroup SimpleLogPayload where

432+ SimpleLogPayload a <> SimpleLogPayload b = SimpleLogPayload (a <> b)

433+

434+

398instance Monoid SimpleLogPayload where

435instance Monoid SimpleLogPayload where

399 mempty = SimpleLogPayload []

436 mempty = SimpleLogPayload []

400− SimpleLogPayload a `mappend` SimpleLogPayload b = SimpleLogPayload (a `mappend` b)

437+ mappend = (<>)

401

438

402

439

403-------------------------------------------------------------------------------

440-------------------------------------------------------------------------------

@@ -412,7 +449,7 @@ sl a b = SimpleLogPayload [(a, AnyLogPayload b)]

412payloadObject :: LogItem a => Verbosity -> a -> A.Object

449payloadObject :: LogItem a => Verbosity -> a -> A.Object

413payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of

450payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of

414 AllKeys -> toObject a

451 AllKeys -> toObject a

415− SomeKeys ks -> HM.filterWithKey (\ k _ -> k `elem` ks) $ toObject a

452+ SomeKeys ks -> HM.filterWithKey (\ k _ -> k `FT.elem` ks) $ toObject a

416

453

417

454

418-------------------------------------------------------------------------------

455-------------------------------------------------------------------------------

@@ -459,11 +496,15 @@ data Scribe = Scribe {

459 }

496 }

460

497

461

498

499+instance Semigroup Scribe where

500+ (Scribe a) <> (Scribe b) = Scribe $ \ item -> do

501+ a item

502+ b item

503+

504+

462instance Monoid Scribe where

505instance Monoid Scribe where

463 mempty = Scribe $ const $ return ()

506 mempty = Scribe $ const $ return ()

464− mappend (Scribe a) (Scribe b) = Scribe $ \ item -> do

507+ mappend = (<>)

465− a item

466− b item

467

508

468

509

469-------------------------------------------------------------------------------

510-------------------------------------------------------------------------------

@@ -476,12 +517,18 @@ permitItem sev i = _itemSeverity i >= sev

476data LogEnv = LogEnv {

517data LogEnv = LogEnv {

477 _logEnvHost :: HostName

518 _logEnvHost :: HostName

478 , _logEnvPid :: ProcessID

519 , _logEnvPid :: ProcessID

479− , _logEnvNs :: Namespace

520+ , _logEnvApp :: Namespace

521+ -- ^ Name of application. This will typically never change. This

522+ -- field gets prepended to the namespace of your individual log

523+ -- messages. For example, if your app is MyApp and you write a log

524+ -- using "logItem" and the namespace "WebServer", the final

525+ -- namespace will be "MyApp.WebServer"

480 , _logEnvEnv :: Environment

526 , _logEnvEnv :: Environment

481 , _logEnvTimer :: IO UTCTime

527 , _logEnvTimer :: IO UTCTime

482 -- ^ Action to fetch the timestamp. You can use something like

528 -- ^ Action to fetch the timestamp. You can use something like

483 -- 'AutoUpdate' for high volume logs but note that this may cause

529 -- 'AutoUpdate' for high volume logs but note that this may cause

484− -- some output forms to display logs out of order.

530+ -- some output forms to display logs out of order. Alternatively,

531+ -- you could just use 'getCurrentTime'.

485 , _logEnvScribes :: M.Map Text Scribe

532 , _logEnvScribes :: M.Map Text Scribe

486 }

533 }

487makeLenses ''LogEnv

534makeLenses ''LogEnv

@@ -516,7 +563,7 @@ registerScribe

516 -> Scribe

563 -> Scribe

517 -> LogEnv

564 -> LogEnv

518 -> LogEnv

565 -> LogEnv

519−registerScribe nm h = logEnvScribes . at nm .~ Just h

566+registerScribe nm h = logEnvScribes %~ M.insert nm h

520

567

521

568

522-------------------------------------------------------------------------------

569-------------------------------------------------------------------------------

@@ -527,12 +574,15 @@ unregisterScribe

527 -- ^ Name of the scribe

574 -- ^ Name of the scribe

528 -> LogEnv

575 -> LogEnv

529 -> LogEnv

576 -> LogEnv

530−unregisterScribe nm = logEnvScribes . at nm .~ Nothing

577+unregisterScribe nm = logEnvScribes %~ M.delete nm

531

578

532

579

533-------------------------------------------------------------------------------

580-------------------------------------------------------------------------------

534-- | Unregister *all* scribes. Logs will go off into space from this

581-- | Unregister *all* scribes. Logs will go off into space from this

535−-- point onward until new scribes are added.

582+-- point onward until new scribes are added. Note that you could use

583+-- this with `local` if you're using a Reader based stack to

584+-- temporarily disable log output. See `katipNoLogging` for an

585+-- example.

536clearScribes

586clearScribes

537 :: LogEnv

587 :: LogEnv

538 -> LogEnv

588 -> LogEnv

@@ -540,8 +590,16 @@ clearScribes = logEnvScribes .~ mempty

540

590

541

591

542-------------------------------------------------------------------------------

592-------------------------------------------------------------------------------

543−-- | Monads where katip logging actions can be performed

593+-- | Monads where katip logging actions can be performed. Katip is the

594+-- most basic logging monad. You will typically use this directly if

595+-- you either don't want to use namespaces/contexts heavily or if you

596+-- want to pass in specific contexts and/or namespaces at each log site.

597+--

598+-- For something more powerful, look at the docs for 'KatipContext',

599+-- which keeps a namespace and merged context. You can write simple

600+-- functions that add additional namespacing and merges additional

601+-- context on the fly.

544−class MonadIO m => Katip m where

602+class MonadIO m => Katip m where

545 getLogEnv :: m LogEnv

603 getLogEnv :: m LogEnv

546

604

547

605

@@ -616,7 +674,7 @@ logItem a ns loc sev msg = do

616 LogEnv{..} <- getLogEnv

674 LogEnv{..} <- getLogEnv

617 liftIO $ do

675 liftIO $ do

618 item <- Item

676 item <- Item

619− <$> pure _logEnvNs

677+ <$> pure _logEnvApp

620 <*> pure _logEnvEnv

678 <*> pure _logEnvEnv

621 <*> pure sev

679 <*> pure sev

622 <*> (mkThreadIdText <$> myThreadId)

680 <*> (mkThreadIdText <$> myThreadId)

@@ -625,9 +683,9 @@ logItem a ns loc sev msg = do

625 <*> pure a

683 <*> pure a

626 <*> pure msg

684 <*> pure msg

627 <*> _logEnvTimer

685 <*> _logEnvTimer

628− <*> pure (_logEnvNs <> ns)

686+ <*> pure (_logEnvApp <> ns)

629 <*> pure loc

687 <*> pure loc

630− forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item

688+ FT.forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item

631

689

632

690

633-------------------------------------------------------------------------------

691-------------------------------------------------------------------------------

@@ -713,9 +771,33 @@ liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc

713

771

714-------------------------------------------------------------------------------

772-------------------------------------------------------------------------------

715-- | For use when you want to include location in your logs. This will

773-- | For use when you want to include location in your logs. This will

716−-- fill the 'Maybe Loc' gap in 'logF' of this module.

774+-- fill the 'Maybe Loc' gap in 'logF' of this module, and relies on implicit

717−getLoc :: Q Exp

775+-- callstacks when available (GHC > 7.8).

776+#if MIN_VERSION_base(4, 8, 0)

777+getLoc :: (?loc :: CallStack) => Maybe Loc

778+getLoc = case getCallStack ?loc of

779+ [] -> Nothing

780+ xs -> Just . toLoc . last $ xs

781+ where

782+ toLoc :: (String, SrcLoc) -> Loc

783+ toLoc (_, l) = Loc {

784+ loc_filename = srcLocFile l

785+ , loc_package = srcLocPackage l

786+ , loc_module = srcLocModule l

787+ , loc_start = (srcLocStartLine l, srcLocStartCol l)

788+ , loc_end = (srcLocEndLine l, srcLocEndCol l)

789+ }

790+#else

791+getLoc :: Maybe Loc

792+getLoc = Nothing

793+#endif

794+

795+

796+-------------------------------------------------------------------------------

797+-- Like `getLoc`, but uses template-haskell and works with older versions of

798+-- the compiler (GHC 7.8 or older).

799+getLocTH :: ExpQ

718−getLoc = [| $(location >>= liftLoc) |]

800+getLocTH = [| $(location >>= liftLoc) |]

719

801

720

802

721-------------------------------------------------------------------------------

803-------------------------------------------------------------------------------

@@ -723,7 +805,27 @@ getLoc = [| $(location >>= liftLoc) |]

723--

805--

724-- @$(logT) obj mempty InfoS "Hello world"@

806-- @$(logT) obj mempty InfoS "Hello world"@

725logT :: ExpQ

807logT :: ExpQ

726−logT = [| \ a ns sev msg -> logItem a ns (Just $(getLoc)) sev msg |]

808+logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |]

809+

810+

811+-------------------------------------------------------------------------------

812+-- | 'Loc'-tagged logging using implicit-callstacks when available.

813+--

814+-- This function does not require template-haskell as it

815+-- automatically uses <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>

816+-- when the code is compiled using GHC > 7.8. Using an older version of the

817+-- compiler will result in the emission of a log line without any location information,

818+-- so be aware of it. Users using GHC <= 7.8 may want to use the template-haskell function

819+-- `logT` for maximum compatibility.

820+--

821+-- @logLoc obj mempty InfoS "Hello world"@

822+logLoc :: (Applicative m, LogItem a, Katip m)

823+ => a

824+ -> Namespace

825+ -> Severity

826+ -> LogStr

827+ -> m ()

828+logLoc a ns = logItem a ns getLoc

727

829

728

830

729-- taken from the file-location package

831-- taken from the file-location package

katip/src/Katip/Format/Time.hsnew file+213

@@ -0,0 +1,213 @@

1+-- | Time and memory efficient time encoding helper functions.

2+--

3+module Katip.Format.Time

4+ ( formatAsLogTime

5+ , formatAsIso8601

6+ ) where

8+import Control.Monad.ST (ST)

10+import Data.Int (Int64)

11+import qualified Data.Text.Array as TA

12+import Data.Text (Text)

13+import Data.Text.Internal (Text(..))

14+import Data.Time (UTCTime(..), toGregorian, Day, DiffTime)

15+import Data.Word (Word16)

16+import Unsafe.Coerce (unsafeCoerce)

17+

18+-- Note: All functions here are optimized to never allocate anything

19+-- on heap. At least on ghc 8.0.1 no extra strictness annotations are

20+-- seem to be needed.

21+--

22+-- Exported functions are INLINEABLE

23+

24+

25+-- | Format 'UTCTime' into a short human readable format.

26+--

27+-- >>> formatAsLogTime $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012

28+-- "2016-01-23 01:23:45"

29+--

30+formatAsLogTime :: UTCTime -> Text

31+formatAsLogTime (UTCTime day time) = toText $ TA.run2 $ do

32+ buf <- TA.new 19 -- length "2016-10-20 12:34:56"

33+ _ <- writeDay buf 0 day

34+ TA.unsafeWrite buf 10 0x20 -- space

35+ _ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)

36+ return (buf, 19)

37+ where

38+ toText (arr, len) = Text arr 0 len

39+

40+{-# INLINEABLE formatAsLogTime #-}

41+

42+-- | Format 'UTCTime' into a Iso8601 format.

43+--

44+-- Note that this function may overcommit up to 12*2 bytes, depending

45+-- on sub-second precision. If this is an issue, make a copy with a

46+-- 'Data.Text.copy'.

47+--

48+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012

49+-- "2016-11-23T01:23:45.123456789012Z"

50+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123

51+-- "2016-01-23T01:23:45.123Z"

52+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025

53+-- "2016-01-23T01:23:45Z"

54+

55+--

56+formatAsIso8601 :: UTCTime -> Text

57+formatAsIso8601 (UTCTime day time) = toText $ TA.run2 $ do

58+ buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"

59+ _ <- writeDay buf 0 day

60+ TA.unsafeWrite buf 10 0x54 -- T

61+ next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)

62+ TA.unsafeWrite buf next 0x5A -- Z

63+ return (buf, next+1)

64+ where

65+ toText (arr, len) = Text arr 0 len

66+

67+{-# INLINEABLE formatAsIso8601 #-}

68+

69+-- | Writes the @YYYY-MM-DD@ part of timestamp

70+writeDay :: TA.MArray s -> Int -> Day -> ST s Int

71+writeDay buf off day =

72+ do

73+ TA.unsafeWrite buf (off + 0) (digit y1)

74+ TA.unsafeWrite buf (off + 1) (digit y2)

75+ TA.unsafeWrite buf (off + 2) (digit y3)

76+ TA.unsafeWrite buf (off + 3) (digit y4)

77+ TA.unsafeWrite buf (off + 4) 0x2d -- dash

78+ TA.unsafeWrite buf (off + 5) m1

79+ TA.unsafeWrite buf (off + 6) m2

80+ TA.unsafeWrite buf (off + 7) 0x2d -- dash

81+ TA.unsafeWrite buf (off + 8) d1

82+ TA.unsafeWrite buf (off + 9) d2

83+ return (off + 10)

84+ where

85+ (yr,m,d) = toGregorian day

86+ (y1, ya) = fromIntegral (abs yr) `quotRem` 1000

87+ (y2, yb) = ya `quotRem` 100

88+ (y3, y4) = yb `quotRem` 10

89+ T m1 m2 = twoDigits m

90+ T d1 d2 = twoDigits d

91+{-# INLINE writeDay #-}

92+

93+-- | Write time of day, optionally with sub seconds

94+writeTimeOfDay :: Bool -> TA.MArray s -> Int -> TimeOfDay64 -> ST s Int

95+writeTimeOfDay doSubSeconds buf off (TOD hh mm ss) =

96+ do

97+

98+ TA.unsafeWrite buf off h1

99+ TA.unsafeWrite buf (off + 1) h2

100+ TA.unsafeWrite buf (off + 2) 0x3A -- colon

101+ TA.unsafeWrite buf (off + 3) m1

102+ TA.unsafeWrite buf (off + 4) m2

103+ TA.unsafeWrite buf (off + 5) 0x3A -- colon

104+ TA.unsafeWrite buf (off + 6) s1

105+ TA.unsafeWrite buf (off + 7) s2

106+ if doSubSeconds && frac /= 0

107+ then writeFracSeconds buf (off + 8) frac

108+ else return (off + 8)

109+ where

110+ T h1 h2 = twoDigits hh

111+ T m1 m2 = twoDigits mm

112+ T s1 s2 = twoDigits (fromIntegral real)

113+ (real,frac) = ss `quotRem` pico

114+ pico = 1000000000000 -- number of picoseconds in 1 second

115+

116+

117+writeFracSeconds :: TA.MArray s -> Int -> Int64 -> ST s Int

118+writeFracSeconds buf off frac =

119+ do

120+ TA.unsafeWrite buf off 0x2e -- period

121+ if mills == 0

122+ then do

123+ writeTrunc6 buf (off + 1) (fromIntegral mics)

124+ else do

125+ writeDigit6 buf (off + 1) (fromIntegral mics)

126+ writeTrunc6 buf (off + 7) (fromIntegral mills)

127+

128+ where

129+ (mics, mills) = frac `quotRem` micro

130+ micro = 1000000 -- number of microseconds in 1 second

131+

132+

133+writeDigit6 :: TA.MArray s -> Int -> Int -> ST s ()

134+writeDigit6 buf off i =

135+ do

136+ writeDigit3 buf off f1

137+ writeDigit3 buf (off+3) f2

138+ where

139+ (f1, f2) = i `quotRem` 1000

140+

141+{-# INLINE writeDigit6 #-}

142+

143+writeDigit3 :: TA.MArray s -> Int -> Int -> ST s ()

144+writeDigit3 buf off i =

145+ do

146+ TA.unsafeWrite buf off (digit d1)

147+ TA.unsafeWrite buf (off+1) (digit d2)

148+ TA.unsafeWrite buf (off+2) (digit d3)

149+ where

150+ (d1, d) = i `quotRem` 100

151+ (d2, d3) = d `quotRem` 10

152+

153+{-# INLINE writeDigit3 #-}

154+

155+writeTrunc6 :: TA.MArray s -> Int -> Int -> ST s Int

156+writeTrunc6 buf off i =

157+ if f2 == 0

158+ then writeTrunc3 buf off f1

159+ else do

160+ writeDigit3 buf off f1

161+ writeTrunc3 buf (off+3) f2

162+ where

163+ (f1, f2) = i `quotRem` 1000

164+

165+{-# INLINE writeTrunc6 #-}

166+

167+

168+writeTrunc3 :: TA.MArray s -> Int -> Int -> ST s Int

169+writeTrunc3 buf off i

170+ | d == 0 = do

171+ TA.unsafeWrite buf off (digit d1)

172+ return (off+1)

173+ | d3 == 0 = do

174+ TA.unsafeWrite buf off (digit d1)

175+ TA.unsafeWrite buf (off+1) (digit d2)

176+ return (off+2)

177+

178+ | otherwise = do

179+ TA.unsafeWrite buf off (digit d1)

180+ TA.unsafeWrite buf (off+1) (digit d2)

181+ TA.unsafeWrite buf (off+2) (digit d3)

182+ return (off+3)

183+ where

184+ (d1, d) = i `quotRem` 100

185+ (d2, d3) = d `quotRem` 10

186+

187+{-# INLINE writeTrunc3 #-}

188+

189+

190+-- Following code was adapted from aeson package.

191+--

193+-- License: BSD3

194+

195+data T = T {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16

196+

197+twoDigits :: Int -> T

198+twoDigits a = T (digit hi) (digit lo)

199+ where (hi,lo) = a `quotRem` 10

200+

201+digit :: Int -> Word16

202+digit x = fromIntegral (x + 48)

203+

204+

205+data TimeOfDay64 = TOD {-# UNPACK #-} !Int

206+ {-# UNPACK #-} !Int

207+ {-# UNPACK #-} !Int64

208+

209+diffTimeOfDay64 :: DiffTime -> TimeOfDay64

210+diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s

211+ where (h,mp) = fromIntegral pico `quotRem` 3600000000000000

212+ (m,s) = mp `quotRem` 60000000000000

213+ pico = unsafeCoerce t :: Integer

katip/src/Katip/Monadic.hs+98−10

@@ -7,7 +7,9 @@

7{-# LANGUAGE TemplateHaskell #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE UndecidableInstances #-}

10−

10+#if MIN_VERSION_base(4, 9, 0)

11+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

12+#endif

11-- | Provides support for treating payloads and namespaces as

13-- | Provides support for treating payloads and namespaces as

12-- composable contexts. The common pattern would be to provide a

14-- composable contexts. The common pattern would be to provide a

13-- 'KatipContext' instance for your base monad.

15-- 'KatipContext' instance for your base monad.

@@ -16,6 +18,7 @@ module Katip.Monadic

16 -- * Monadic variants of logging functions from "Katip.Core"

18 -- * Monadic variants of logging functions from "Katip.Core"

17 logFM

19 logFM

18 , logTM

20 , logTM

21+ , logLocM

19 , logItemM

22 , logItemM

20 , logExceptionM

23 , logExceptionM

@@ -28,6 +31,9 @@ module Katip.Monadic

28 -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances

31 -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances

29 , KatipContextT(..)

32 , KatipContextT(..)

30 , runKatipContextT

33 , runKatipContextT

34+ , katipAddNamespace

35+ , katipAddContext

36+ , katipNoLogging

31 , KatipContextTState(..)

37 , KatipContextTState(..)

32 ) where

38 ) where

@@ -53,8 +59,10 @@ import qualified Control.Monad.Trans.State.Strict as Strict (StateT)

53import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)

59import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)

54import Control.Monad.Writer

60import Control.Monad.Writer

55import Data.Aeson

61import Data.Aeson

62+import qualified Data.Foldable as FT

56import qualified Data.HashMap.Strict as HM

63import qualified Data.HashMap.Strict as HM

57import Data.Monoid as M

64import Data.Monoid as M

65+import Data.Sequence as Seq

58import Data.Text (Text)

66import Data.Text (Text)

59import Language.Haskell.TH

67import Language.Haskell.TH

60-------------------------------------------------------------------------------

68-------------------------------------------------------------------------------

@@ -72,17 +80,29 @@ data AnyLogContext where

72-- 'LogContext' instance for combining multiple payload policies. This

80-- 'LogContext' instance for combining multiple payload policies. This

73-- is critical for log contexts deep down in a stack to be able to

81-- is critical for log contexts deep down in a stack to be able to

74-- inject their own context without worrying about other context that

82-- inject their own context without worrying about other context that

75−-- has already been set.

83+-- has already been set. Also note that contexts are treated as a

84+-- sequence and '<>' will be appended to the right hand side of the

85+-- sequence. If there are conflicting keys in the contexts, the /right

86+-- side will take precedence/, which is counter to how monoid works

87+-- for 'Map' and 'HashMap', so bear that in mind. The reasoning is

88+-- that if the user is /sequentially/ adding contexts to the right

89+-- side of the sequence, on conflict the intent is to overwrite with

90+-- the newer value (i.e. the rightmost value).

91+--

92+-- Additional note: you should not mappend LogContexts in any sort of

93+-- infinite loop, as it retains all data, so that would be a memory

94+-- leak.

76−newtype LogContexts = LogContexts [AnyLogContext] deriving (Monoid)

95+newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid)

78instance ToJSON LogContexts where

97instance ToJSON LogContexts where

79 toJSON (LogContexts cs) =

98 toJSON (LogContexts cs) =

99+ -- flip mappend to get right-biased merge

80− Object $ mconcat $ map (\(AnyLogContext v) -> toObject v) cs

100+ Object $ FT.foldr (flip mappend) mempty $ fmap (\(AnyLogContext v) -> toObject v) cs

101

82instance ToObject LogContexts

102instance ToObject LogContexts

103

84instance LogItem LogContexts where

104instance LogItem LogContexts where

85− payloadKeys verb (LogContexts vs) = mconcat $ map payloadKeys' vs

105+ payloadKeys verb (LogContexts vs) = FT.foldr (flip mappend) mempty $ fmap payloadKeys' vs

86 where

106 where

87 -- To ensure AllKeys doesn't leak keys from other values when

107 -- To ensure AllKeys doesn't leak keys from other values when

88 -- combined, we resolve AllKeys to its equivalent SomeKeys

108 -- combined, we resolve AllKeys to its equivalent SomeKeys

@@ -96,7 +116,7 @@ instance LogItem LogContexts where

96-- | Lift a log context into the generic wrapper so that it can

116-- | Lift a log context into the generic wrapper so that it can

97-- combine with the existing log context.

117-- combine with the existing log context.

98liftPayload :: (LogItem a) => a -> LogContexts

118liftPayload :: (LogItem a) => a -> LogContexts

99−liftPayload = LogContexts . (:[]) . AnyLogContext

119+liftPayload = LogContexts . Seq.singleton . AnyLogContext

100

120

101

121

102-------------------------------------------------------------------------------

122-------------------------------------------------------------------------------

@@ -139,7 +159,7 @@ deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)

139-- very low level and you typically can use 'logTM' in its

159-- very low level and you typically can use 'logTM' in its

140-- place. Automaticallysupplies payload and namespace.

160-- place. Automaticallysupplies payload and namespace.

141logItemM

161logItemM

142− :: (Applicative m, KatipContext m, Katip m)

162+ :: (Applicative m, KatipContext m)

143 => Maybe Loc

163 => Maybe Loc

144 -> Severity

164 -> Severity

145 -> LogStr

165 -> LogStr

@@ -155,7 +175,7 @@ logItemM loc sev msg = do

155-- | Log with full context, but without any code

175-- | Log with full context, but without any code

156-- location. Automatically supplies payload and namespace.

176-- location. Automatically supplies payload and namespace.

157logFM

177logFM

158− :: (Applicative m, KatipContext m, Katip m)

178+ :: (Applicative m, KatipContext m)

159 => Severity

179 => Severity

160 -- ^ Severity of the message

180 -- ^ Severity of the message

161 -> LogStr

181 -> LogStr

@@ -171,9 +191,30 @@ logFM sev msg = do

171-- | 'Loc'-tagged logging when using template-haskell. Automatically

191-- | 'Loc'-tagged logging when using template-haskell. Automatically

172-- supplies payload and namespace.

192-- supplies payload and namespace.

173--

193--

174−-- @$(logt) InfoS "Hello world"@

194+-- @$(logTM) InfoS "Hello world"@

175logTM :: ExpQ

195logTM :: ExpQ

176−logTM = [| logItemM (Just $(getLoc)) |]

196+logTM = [| logItemM (Just $(getLocTH)) |]

197+

198+

199+-------------------------------------------------------------------------------

200+-- | 'Loc'-tagged logging when using template-haskell. Automatically

201+-- supplies payload and namespace.

202+--

203+-- Same consideration as `logLoc` applies.

204+--

205+-- This function does not require template-haskell as it

206+-- automatically uses <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>

207+-- when the code is compiled using GHC > 7.8. Using an older version of the

208+-- compiler will result in the emission of a log line without any location information,

209+-- so be aware of it. Users using GHC <= 7.8 may want to use the template-haskell function

210+-- `logTM` for maximum compatibility.

211+--

212+-- @logLocM InfoS "Hello world"@

213+logLocM :: (Applicative m, KatipContext m)

214+ => Severity

215+ -> LogStr

216+ -> m ()

217+logLocM = logItemM getLoc

177

218

178

219

179-------------------------------------------------------------------------------

220-------------------------------------------------------------------------------

@@ -270,3 +311,50 @@ runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a

270runKatipContextT le ctx ns = flip runReaderT lts . unKatipContextT

311runKatipContextT le ctx ns = flip runReaderT lts . unKatipContextT

271 where

312 where

272 lts = KatipContextTState le (liftPayload ctx) ns

313 lts = KatipContextTState le (liftPayload ctx) ns

314+

315+

316+-------------------------------------------------------------------------------

317+-- | Append a namespace segment to the current namespace for the given

318+-- monadic action, then restore the previous state

319+-- afterwards.

320+katipAddNamespace

321+ :: (Monad m)

322+ => Namespace

323+ -> KatipContextT m a

324+ -> KatipContextT m a

325+katipAddNamespace ns (KatipContextT f) =

326+ KatipContextT (local (\r -> r { ltsNamespace = (ltsNamespace r) <> ns}) f)

327+

328+

329+-------------------------------------------------------------------------------

330+-- | Append some context to the current context for the given monadic

331+-- action, then restore the previous state afterwards. Important note:

332+-- be careful using this in a loop. If you're using something like

333+-- 'forever' or 'replicateM_' that does explicit sharing to avoid a

334+-- memory leak, youll be fine as it will *sequence* calls to

335+-- 'katipAddNamespace', so each loop will get the same context

336+-- added. If you instead roll your own recursion and you're recursing

337+-- in the action you provide, you'll instead accumulate tons of

338+-- redundant contexts and even if they all merge on log, they are

339+-- stored in a sequence and will leak memory.

340+katipAddContext

341+ :: ( LogItem i

342+ , Monad m

343+ )

344+ => i

345+ -> KatipContextT m a

346+ -> KatipContextT m a

347+katipAddContext i (KatipContextT f) =

348+ KatipContextT (local (\r -> r { ltsContext = (ltsContext r) <> liftPayload i}) f)

349+

350+

351+-------------------------------------------------------------------------------

352+-- | Disable all scribes for the given monadic action, then restore

353+-- them afterwards.

354+katipNoLogging

355+ :: ( Monad m

356+ )

357+ => KatipContextT m a

358+ -> KatipContextT m a

359+katipNoLogging (KatipContextT f) =

360+ KatipContextT (local (\r -> r { ltsLogEnv = clearScribes (ltsLogEnv r)}) f)

katip/src/Katip/Scribes/Handle.hs+26−18

@@ -3,19 +3,21 @@

3module Katip.Scribes.Handle where

5-------------------------------------------------------------------------------

6−import Control.Lens

6+import Control.Applicative as A

7+import Control.Concurrent

8+import Control.Exception (bracket_)

7import Control.Monad

9import Control.Monad

8−import Data.Aeson.Lens

10+import Data.Aeson

9import qualified Data.HashMap.Strict as HM

11import qualified Data.HashMap.Strict as HM

10import Data.Monoid

12import Data.Monoid

13+import Data.Text (Text)

11import Data.Text.Lazy.Builder

14import Data.Text.Lazy.Builder

12import Data.Text.Lazy.IO as T

15import Data.Text.Lazy.IO as T

13−import Data.Time

14−import qualified Data.Time.Locale.Compat as LC

15import System.IO

16import System.IO

16import System.IO.Unsafe (unsafePerformIO)

17import System.IO.Unsafe (unsafePerformIO)

17-------------------------------------------------------------------------------

18-------------------------------------------------------------------------------

18import Katip.Core

19import Katip.Core

20+import Katip.Format.Time (formatAsLogTime)

19-------------------------------------------------------------------------------

21-------------------------------------------------------------------------------

@@ -26,18 +28,17 @@ brackets m = fromText "[" <> m <> fromText "]"

27-------------------------------------------------------------------------------

29-------------------------------------------------------------------------------

28getKeys :: LogItem s => Verbosity -> s -> [Builder]

30getKeys :: LogItem s => Verbosity -> s -> [Builder]

29−getKeys verb a = payloadObject verb a ^..

31+getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))

30− to HM.toList . traverse . to rendPair

31 where

32 where

32− rendPair (k,v) = fromText k <> fromText ":" <> (v ^. _Primitive . to renderPrim)

33+ renderPair :: (Text, Value) -> [Builder]

33−

34+ renderPair (k,v) =

34−

35+ case v of

35−-------------------------------------------------------------------------------

36+ Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]

36−renderPrim :: Primitive -> Builder

37+ String t -> [fromText (k <> ":" <> t)]

37−renderPrim (StringPrim t) = fromText t

38−renderPrim (NumberPrim s) = fromString (show s)

38+ Number n -> [fromText (k <> ":") <> fromString (show n)]

39−renderPrim (BoolPrim b) = fromString (show b)

39+ Bool b -> [fromText (k <> ":") <> fromString (show b)]

40−renderPrim NullPrim = fromText "null"

40+ Null -> [fromText (k <> ":null")]

41+ _ -> mempty -- Can't think of a sensible way to handle arrays

43-------------------------------------------------------------------------------

44-------------------------------------------------------------------------------

@@ -49,15 +50,22 @@ data ColorStrategy

51-------------------------------------------------------------------------------

52-------------------------------------------------------------------------------

52−-- | Logs to a file handle such as stdout, stderr, or a file.

53+-- | Logs to a file handle such as stdout, stderr, or a file. Contexts

54+-- and other information will be flattened out into bracketed

55+-- fields. For example:

56+--

57+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started

58+-- > [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

59+-- > [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

53mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe

60mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe

54mkHandleScribe cs h sev verb = do

61mkHandleScribe cs h sev verb = do

55 hSetBuffering h LineBuffering

62 hSetBuffering h LineBuffering

56 colorize <- case cs of

63 colorize <- case cs of

57 ColorIfTerminal -> hIsTerminalDevice h

64 ColorIfTerminal -> hIsTerminalDevice h

58 ColorLog b -> return b

65 ColorLog b -> return b

66+ lock <- newMVar ()

59 return $ Scribe $ \ i@Item{..} -> do

67 return $ Scribe $ \ i@Item{..} -> do

60− when (permitItem sev i) $

68+ when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $

61 T.hPutStrLn h $ toLazyText $ formatItem colorize verb i

69 T.hPutStrLn h $ toLazyText $ formatItem colorize verb i

@@ -74,7 +82,7 @@ formatItem withColor verb Item{..} =

74 maybe mempty (brackets . fromString . locationToString) _itemLoc <>

82 maybe mempty (brackets . fromString . locationToString) _itemLoc <>

75 fromText " " <> (unLogStr _itemMessage)

83 fromText " " <> (unLogStr _itemMessage)

76 where

84 where

77− nowStr = fromString $ formatTime LC.defaultTimeLocale "%Y-%m-%d %H:%M:%S" _itemTime

85+ nowStr = fromText (formatAsLogTime _itemTime)

78 ks = map brackets $ getKeys verb _itemPayload

86 ks = map brackets $ getKeys verb _itemPayload

79 renderSeverity' s = case s of

87 renderSeverity' s = case s of

80 EmergencyS -> red $ renderSeverity s

88 EmergencyS -> red $ renderSeverity s

katip/test/Katip/Tests.hs+58−1

@@ -1,4 +1,7 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE StandaloneDeriving #-}

6{-# LANGUAGE StandaloneDeriving #-}

4{-# OPTIONS_GHC -fno-warn-orphans #-}

7{-# OPTIONS_GHC -fno-warn-orphans #-}

@@ -10,6 +13,9 @@ module Katip.Tests

10-------------------------------------------------------------------------------

13-------------------------------------------------------------------------------

11import Control.Applicative

14import Control.Applicative

12import Data.Aeson

15import Data.Aeson

16+import qualified Data.HashMap.Strict as HM

17+import Data.Monoid

18+import Data.Text (Text)

13import qualified Data.Text.Lazy.Builder as B

19import qualified Data.Text.Lazy.Builder as B

14import Data.Time

20import Data.Time

15import Data.Time.Clock.POSIX

21import Data.Time.Clock.POSIX

@@ -17,9 +23,11 @@ import Language.Haskell.TH

17import System.Posix.Types

23import System.Posix.Types

18import Test.QuickCheck.Instances ()

24import Test.QuickCheck.Instances ()

19import Test.Tasty

25import Test.Tasty

26+import Test.Tasty.HUnit

20import Test.Tasty.QuickCheck

27import Test.Tasty.QuickCheck

21-------------------------------------------------------------------------------

28-------------------------------------------------------------------------------

22import Katip

29import Katip

30+import Katip.Core

23-------------------------------------------------------------------------------

31-------------------------------------------------------------------------------

@@ -27,10 +35,56 @@ tests :: TestTree

27tests = testGroup "Katip"

35tests = testGroup "Katip"

28 [

36 [

29 testProperty "JSON cycle Item" $ \(i :: Item ()) ->

37 testProperty "JSON cycle Item" $ \(i :: Item ()) ->

30− prop_json_cycle i

38+ prop_json_cycle i

39+ , testProperty "renderSeverity/textToSeverity cycle" $ \sev ->

40+ textToSeverity(renderSeverity sev) === Just sev

41+ , testProperty "processIDToText/textToProcessID cycle" $ \pid ->

42+ textToProcessID (processIDToText pid) === Just pid

43+ , testCase "processIDToText is just the number" $ do

44+ processIDToText 123 @?= "123"

45+ , logContextsTests

31 ]

46 ]

49+-------------------------------------------------------------------------------

50+logContextsTests :: TestTree

51+logContextsTests = testGroup "logContexts"

52+ [

53+ testCase "overwrites with the right-hand side (right-bias)" $ do

54+ let l1 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])

55+ l2 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("b" :: Text))])

56+ l3 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("c" :: Text))])

57+ both = l1 <> l2 <> l3

58+ toObject both @?= HM.singleton "foo" (String "c")

59+ , testCase "respects payloadKeys for each constituent payload" $ do

60+ let everything = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])

61+ conservative = liftPayload (ConservativePayload "always" "rarely")

62+ both = everything <> conservative

63+ payloadKeys V2 both @?= SomeKeys ["often_shown", "rarely_shown", "foo"]

64+ payloadKeys V1 both @?= SomeKeys ["often_shown", "foo"]

65+ ]

66+

67+

68+-------------------------------------------------------------------------------

69+data ConservativePayload = ConservativePayload {

70+ oftenShown :: Text

71+ , rarelyShown :: Text

72+ }

73+

74+

75+instance ToJSON ConservativePayload where

76+ toJSON ConservativePayload {..} = object ["often_shown" .= oftenShown

77+ ,"rarely_shown" .= rarelyShown]

78+

79+

80+instance ToObject ConservativePayload

81+

82+

83+instance LogItem ConservativePayload where

84+ payloadKeys V1 _ = SomeKeys ["often_shown"]

85+ payloadKeys V0 _ = SomeKeys []

86+ payloadKeys _ _ = AllKeys

87+

34-------------------------------------------------------------------------------

88-------------------------------------------------------------------------------

35prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property

89prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property

36prop_json_cycle a = eitherDecode (encode a) === Right a

90prop_json_cycle a = eitherDecode (encode a) === Right a

@@ -69,6 +123,9 @@ deriving instance Arbitrary Namespace

69deriving instance Arbitrary Environment

123deriving instance Arbitrary Environment

70deriving instance Arbitrary ThreadIdText

124deriving instance Arbitrary ThreadIdText

71deriving instance Arbitrary CPid

125deriving instance Arbitrary CPid

126+#if !MIN_VERSION_base(4, 8, 0)

127+deriving instance Eq Loc

128+#endif

72deriving instance Eq LogStr

129deriving instance Eq LogStr

73deriving instance (Eq a) => Eq (Item a)

130deriving instance (Eq a) => Eq (Item a)

131

katip/test/Katip/Tests/Format/Time.hsnew file+81

@@ -0,0 +1,81 @@

2+module Katip.Tests.Format.Time

3+ ( tests

4+ ) where

6+import Data.Aeson (toJSON)

7+import qualified Data.Text as Text

8+import Data.Time

9+import Data.Time.Clock.POSIX

10+import qualified Data.Time.Locale.Compat as LC

11+

12+import Test.Tasty

13+import Test.Tasty.HUnit

14+import Test.Tasty.QuickCheck

15+

16+import Katip.Format.Time

17+

18+tests :: TestTree

19+tests = testGroup "Katip.Format.Time"

20+ [ testCase "formatAsLogTime" $ do

21+ assertEqual "time 1" (formatDT t1) (formatAsLogTime t1)

22+ assertEqual "time 2" (formatDT t2) (formatAsLogTime t2)

23+ assertEqual "time 3" (formatDT t3) (formatAsLogTime t3)

24+ assertEqual "time 4" (formatDT t4) (formatAsLogTime t4)

25+ assertEqual "time 5" (formatDT t5) (formatAsLogTime t5)

26+

27+ , testCase "formatAsIso8601" $ do

28+ assertEqual "time 1" (formatDTISO t1) (formatAsIso8601 t1)

29+ assertEqual "time 2" (formatDTISO t2) (formatAsIso8601 t2)

30+ assertEqual "time 3" (formatDTISO t3) (formatAsIso8601 t3)

31+ assertEqual "time 4" (formatDTISO t4) (formatAsIso8601 t4)

32+ assertEqual "time 5" (formatDTISO t5) (formatAsIso8601 t5)

33+

34+ , testCase "formatAsIso8601 Aeson" $ do

35+ assertEqual "time 1" (toJSON t1) (toJSON $ formatAsIso8601 t1)

36+ assertEqual "time 2" (toJSON t2) (toJSON $ formatAsIso8601 t2)

37+ assertEqual "time 3" (toJSON t3) (toJSON $ formatAsIso8601 t3)

38+ assertEqual "time 4" (toJSON t4) (toJSON $ formatAsIso8601 t4)

39+ assertEqual "time 5" (toJSON t5) (toJSON $ formatAsIso8601 t5)

40+

41+

42+ , testProperty "LogTime same as Date.Time" $ \(ArbUTCTime t) ->

43+ prop_format_log t

44+

45+ , testProperty "ISO 8601 same as Date.Time" $ \(ArbUTCTime t) ->

46+ prop_format_iso t

47+

48+ , testProperty "ISO 8601 same as Aeson" $ \(ArbUTCTime t) ->

49+ prop_format_aeson t

50+

51+ ]

52+ where

53+ t1 = UTCTime (fromGregorian 2016 12 34) 5025.123456789012

54+ t2 = UTCTime (fromGregorian 2016 1 23) 5025.123

55+ t3 = UTCTime (fromGregorian 16 12 1) 025

56+ t4 = UTCTime (fromGregorian 2000 1 1) 0.000000000001

57+ t5 = UTCTime (fromGregorian 2000 12 31) 0.100000000001

58+

59+formatDT :: UTCTime -> Text.Text

60+formatDT = Text.pack . formatTime LC.defaultTimeLocale "%0Y-%m-%d %H:%M:%S"

61+

62+formatDTISO :: UTCTime -> Text.Text

63+formatDTISO = Text.pack . formatTime LC.defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%QZ"

64+

65+prop_format_log :: UTCTime -> Property

66+prop_format_log a = formatDT a === formatAsLogTime a

67+

68+prop_format_iso :: UTCTime -> Property

69+prop_format_iso a = formatDTISO a === formatAsIso8601 a

70+

71+prop_format_aeson :: UTCTime -> Property

72+prop_format_aeson a = toJSON a === toJSON (formatAsIso8601 a)

73+

74+

75+newtype ArbUTCTime = ArbUTCTime {

76+ unArbUTCTime :: UTCTime

77+ } deriving (Show)

78+

79+instance Arbitrary ArbUTCTime where

80+ arbitrary = fmap (ArbUTCTime . posixSecondsToUTCTime . fromInteger)

81+ arbitrary

katip/test/Katip/Tests/Scribes/Handle-text.goldennew file+40

@@ -0,0 +1,40 @@

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][7331][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][7331][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][7331][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][7331][1337][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][7331][1][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][7331][2147483647][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][7331][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][0][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][1337][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][7331][1337][note.deep:some note] message

21+[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message

22+with newline

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][7331][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][7331][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][7331][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][7331][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][7331][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

35+newline][Info][example][7331][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][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][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][7331][1337][sub:null][text:][num:0.0][float:0.0] message

40+[2016-06-12 12:34:56][foo][Info][example][7331][1337][sub.note.deep:some note][text:note][num:10.0][float:5.5] message

katip/test/Katip/Tests/Scribes/Handle.hs+166−6

@@ -1,4 +1,4 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE OverloadedStrings #-}

2module Katip.Tests.Scribes.Handle

3 ( tests

4 ) where

@@ -6,16 +6,26 @@ module Katip.Tests.Scribes.Handle

6-------------------------------------------------------------------------------

7import Control.Monad

8import Data.Aeson

9+import qualified Data.ByteString.Lazy as BL

10+import Data.Monoid

9−import Data.Text (Text)

11+import Data.Text (Text)

10−import qualified Data.Text.IO as T

12+import qualified Data.Text as T

13+import qualified Data.Text.IO as T

14+import qualified Data.Text.Lazy as LT

15+import qualified Data.Text.Lazy.Builder as LT

16+import Data.Time

17+import Language.Haskell.TH.Syntax (Loc (..))

18+import Lens.Micro ((.~))

11import System.Directory

19import System.Directory

12import System.IO

20import System.IO

13import System.IO.Temp

21import System.IO.Temp

14import Test.Tasty

22import Test.Tasty

23+import Test.Tasty.Golden

15import Test.Tasty.HUnit

24import Test.Tasty.HUnit

16import Text.Regex.TDFA

25import Text.Regex.TDFA

17-------------------------------------------------------------------------------

26-------------------------------------------------------------------------------

18import Katip

27import Katip

28+import Katip.Scribes.Handle

19-------------------------------------------------------------------------------

29-------------------------------------------------------------------------------

@@ -27,9 +37,13 @@ tests = testGroup "Katip.Scribes.Handle"

27 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"

37 runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"

28 hClose h

38 hClose h

29 res <- readFile path

39 res <- readFile path

30− let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note:some note\\] test message" :: String

40+ 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

31 let matches = res =~ pat

41 let matches = res =~ pat

32− matches @?= True

42+ assertBool (res <> " did not match") matches

43+ , withResource setupTempFile teardownTempFile $ \setup ->

44+ goldenVsString "Text-golden"

45+ "test/Katip/Tests/Scribes/Handle-text.golden"

46+ (setup >>= writeTextLog)

33 ]

47 ]

@@ -40,7 +54,10 @@ data DummyLogItem = DummyLogItem {

42instance ToJSON DummyLogItem where

56instance ToJSON DummyLogItem where

43− toJSON (DummyLogItem n) = object ["note" .= n]

57+ toJSON (DummyLogItem n) = object

58+ [ "note" .= object [ "deep" .= n

59+ ]

60+ ]

46instance ToObject DummyLogItem

63instance ToObject DummyLogItem

@@ -70,3 +87,146 @@ teardown :: (FilePath, Handle, LogEnv) -> IO ()

70teardown (_, h, _) = do

87teardown (_, h, _) = do

71 chk <- hIsOpen h

88 chk <- hIsOpen h

72 when chk $ hClose h

89 when chk $ hClose h

90+

91+

92+

93+-- Following code tests Handle scribe output against a golden file.

94+-- This test will fail on non utf8 locales because golden file is in utf-8.

95+-- It generates all meaningfull variations of Item, and also tests

96+-- writing of payload of different Aeson constructors

97+--

98+-- Note: currently Handle scribe does not write Array items at all

99+-------------------------------------------------------------------------------

100+data AllTypesLogItem = AllTypesLogItem

101+ { atlText :: Text

102+ , atlNum :: Int

103+ , atlFloat :: Float

104+ , atlList :: [Text]

105+ , atlSub :: Maybe DummyLogItem

106+ }

107+

108+

109+instance ToJSON AllTypesLogItem where

110+ toJSON it = object

111+ [ "text" .= atlText it

112+ , "num" .= atlNum it

113+ , "float" .= atlFloat it

114+ , "list" .= atlList it

115+ , "sub" .= atlSub it

116+ ]

117+

118+

119+instance ToObject AllTypesLogItem

120+

121+

122+instance LogItem AllTypesLogItem where

123+ payloadKeys _ _ = AllKeys

124+

125+

126+-------------------------------------------------------------------------------

127+theItem :: Item DummyLogItem

128+theItem = Item (Namespace ["app"])

129+ (Environment "production")

130+ (InfoS)

131+ (ThreadIdText "1337")

132+ "example"

133+ 7331

134+ dummyLogItem

135+ "message"

136+ (mkUTCTime 2016 6 12 12 34 56)

137+ (Namespace ["foo"])

138+ Nothing

139+

140+genItems :: [Item DummyLogItem]

141+genItems = concat $

142+ [ [ itemSeverity .~ s $ theItem

143+ | s <- [minBound .. maxBound]

144+ ]

145+ , [ itemThread .~ (ThreadIdText . T.pack $ show t) $ theItem

146+ | t <- [0, 1, 1337, 2147483647]

147+ ]

148+ , [ itemHost .~ h $ theItem

149+ | h <- ["example", "www.example.com", "127.0.0.1"]

150+ ]

151+ , [ itemProcess .~ p $ theItem

152+ | p <- [0, 1, 1337, 2147483647]

153+ ]

154+ , [ itemMessage .~ LogStr m $ theItem

155+ | m <- [ "message"

156+ , "message\nwith newline"

157+ , LT.fromLazyText (LT.replicate 40 " a really long message")

158+ , "сообщение"

159+ , "哈囉世界"

160+ ]

161+ ]

162+ , [ itemTime .~ t $ theItem

163+ | t <- genDates

164+ ]

165+ , [ itemNamespace .~ Namespace ns $ theItem

166+ | ns <- [ ["foo"]

167+ , ["foo", "bar"]

168+ , ["фу", "бар"]

169+ , ["with\nnewline"] ]

170+ ]

171+ , [ itemLoc .~ l $ theItem | l <- genLocs

172+ ]

173+ ]

174+

175+genDates :: [UTCTime]

176+genDates =

177+ [ mkUTCTime 2000 1 1 0 0 0.0

178+ , mkUTCTime 2123 12 31 23 59 59.999999999999

179+ , mkUTCTime 2016 10 10 1 1 5.0

180+ , mkUTCTime 2100 12 31 12 59 10.1

181+ , mkUTCTime 1982 1 1 12 30 0.000000000001

182+ ]

183+

184+genLocs :: [Maybe Loc]

185+genLocs =

186+ [ Nothing

187+ , Just $ Loc "path/Some/Module.hs"

188+ "main"

189+ "Some.Module"

190+ (30,1) (30,14)

191+ , Just $ Loc "путь/Some/Module.hs"

192+ "main"

193+ "Some.Module"

194+ (3000,9000) (4000,1)

195+ ]

196+

197+genTypedItems :: [Item AllTypesLogItem]

198+genTypedItems =

199+ [ itemPayload .~ p $ theItem

200+ | p <- [ AllTypesLogItem "" 0 0.0 [] Nothing

201+ , AllTypesLogItem "note" 10 5.5 ["one", "two", "three"]

202+ (Just dummyLogItem)

203+ ]

204+ ]

205+

206+mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime

207+mkUTCTime y mt d h mn s = UTCTime day dt

208+ where

209+ day = fromGregorian y mt d

210+ dt = h * 60 * 60 + mn * 60 + s

211+

212+-------------------------------------------------------------------------------

213+writeTextLog :: (FilePath, Handle) -> IO (BL.ByteString)

214+writeTextLog (path, h) = do

215+ mapM_ (T.hPutStrLn h . formatOne) genItems

216+ mapM_ (T.hPutStrLn h . formatOne) genTypedItems

217+ hClose h

218+ BL.readFile path

219+ where

220+ formatOne :: LogItem a => Item a -> Text

221+ formatOne = LT.toStrict . LT.toLazyText . formatItem False V3

222+

223+setupTempFile :: IO (FilePath, Handle)

224+setupTempFile = do

225+ tempDir <- getTemporaryDirectory

226+ (fp, h) <- openBinaryTempFile tempDir "katip.log"

227+ return (fp, h)

228+

229+teardownTempFile :: (FilePath, Handle) -> IO ()

230+teardownTempFile (_, h) = do

231+ chk <- hIsOpen h

232+ when chk $ hClose h

katip/test/Main.hs+2

@@ -4,6 +4,7 @@ module Main (main) where

4import Test.Tasty

5-------------------------------------------------------------------------------

6import qualified Katip.Tests

7+import qualified Katip.Tests.Format.Time

7import qualified Katip.Tests.Scribes.Handle

8import qualified Katip.Tests.Scribes.Handle

8-------------------------------------------------------------------------------

9-------------------------------------------------------------------------------

@@ -15,5 +16,6 @@ testSuite :: TestTree

15testSuite = testGroup "katip"

16testSuite = testGroup "katip"

16 [

17 [

17 Katip.Tests.tests

18 Katip.Tests.tests

19+ , Katip.Tests.Format.Time.tests

18 , Katip.Tests.Scribes.Handle.tests

20 , Katip.Tests.Scribes.Handle.tests

19 ]

21 ]

stack-lts-2.yamlnew file+32

@@ -0,0 +1,32 @@

1+resolver: lts-2.22

2+packages:

3+ - katip

4+ - katip-elasticsearch

5+extra-deps:

6+ - bloodhound-0.11.0.0

7+ - string-conv-0.1

8+ - aeson-0.11.1.0

9+ - criterion-1.1.0.0

10+ - attoparsec-0.13.0.1

11+ - rng-utils-0.2.1

12+ - retry-0.7.4

13+ - tasty-0.11.0.2

14+ - tagged-0.8.3

15+ - fail-4.9.0.0

16+ - uuid-1.3.12

17+ # just for 7.8/lts-2

18+ - microlens-th-0.3.0.1

19+ - microlens-0.4.2.0

20+ - time-1.5.0.1

21+ - lens-aeson-1.0.0.5

22+ - time-locale-compat-0.1.1.1

23+ - cryptonite-0.16

24+ - memory-0.13

25+

26+flags:

27+ katip:

28+ lib-Werror: true

29+ katip-elasticsearch:

30+ lib-Werror: true

31+ time-locale-compat:

32+ old-locale: false

stack-nightly.yamlnew file+23

@@ -0,0 +1,23 @@

1+resolver: nightly-2016-06-01

2+packages:

3+ - katip

4+ - katip-elasticsearch

5+extra-deps:

6+ - bloodhound-0.11.0.0

7+ - string-conv-0.1

8+ - aeson-0.11.1.0

9+ - attoparsec-0.13.0.1

10+ - rng-utils-0.2.1

11+ - retry-0.7.4

12+ - tasty-0.11.0.2

13+ - tagged-0.8.3

14+ - fail-4.9.0.0

15+ - regex-tdfa-rc-1.1.8.3

16+ - turtle-1.2.8

17+ - managed-1.0.5

18+ - optional-args-1.0.1

19+flags:

20+ katip:

21+ lib-Werror: true

22+ katip-elasticsearch:

23+ lib-Werror: true

stack.yaml+4−2

@@ -6,13 +6,15 @@ extra-deps:

6 - bloodhound-0.11.0.0

7 - string-conv-0.1

8 - aeson-0.11.1.0

9− - criterion-1.1.0.0

9+ - criterion-1.1.1.0

10 - attoparsec-0.13.0.1

11 - rng-utils-0.2.1

12− - retry-0.7.1

12+ - retry-0.7.4

13 - tasty-0.11.0.2

14 - tagged-0.8.3

15 - fail-4.9.0.0

16+ - uuid-1.3.12

17+ - regex-tdfa-rc-1.1.8.3

16flags:

18flags:

17 katip:

19 katip:

18 lib-Werror: true

20 lib-Werror: true