git.iko.soy/typeable/katip
on master help sign in
Export parsable Item type
7d33ad0Michael Xavier
katip/katip.cabal+24−1
compare with master
unifiedsplit
@@ -11,6 +11,10 @@ category: Data, Text, Logging
11build-type: Simple
11build-type: Simple
12cabal-version: >=1.10
12cabal-version: >=1.10
13
13
14+flag lib-Werror
15+ default: False
16+ manual: True
17+
14library
18library
15 exposed-modules:
19 exposed-modules:
16 Katip
20 Katip
@@ -55,6 +59,23 @@ library
55 hs-source-dirs: src
59 hs-source-dirs: src
56 default-language: Haskell2010
60 default-language: Haskell2010
57 ghc-options: -Wall
61 ghc-options: -Wall
62+ if flag(lib-Werror)
63+ ghc-options: -Werror
64+
65+test-suite test
66+ type: exitcode-stdio-1.0
67+ main-is: Main.hs
68+ hs-source-dirs: test
69+ default-language: Haskell2010
70+ build-depends: base
71+ , katip
72+ , aeson
73+ , tasty
74+ , tasty-quickcheck
75+ , quickcheck-instances
76+ , template-haskell
77+ , text
78+ , time
58
79
59
80
60benchmark bench
81benchmark bench
@@ -62,7 +83,9 @@ benchmark bench
62 main-is: Main.hs
83 main-is: Main.hs
63 hs-source-dirs: bench
84 hs-source-dirs: bench
64 default-language: Haskell2010
85 default-language: Haskell2010
65− ghc-options: -O2
86+ ghc-options: -O2 -Wall
87+ if flag(lib-Werror)
88+ ghc-options: -Werror
66 build-depends:
89 build-depends:
67 base
90 base
68 , aeson
91 , aeson
katip/src/Katip.hs+2
@@ -10,6 +10,8 @@ module Katip
10 , Verbosity (..)
10 , Verbosity (..)
11 , ToObject (..)
11 , ToObject (..)
12 , LogItem (..)
12 , LogItem (..)
13+ , Item(..)
14+ , ThreadIdText(..)
13 , PayloadSelection (..)
15 , PayloadSelection (..)
14 , Scribe (..)
16 , Scribe (..)
15 , LogEnv (..)
17 , LogEnv (..)
katip/src/Katip/Core.hs+107−8
@@ -26,7 +26,8 @@ import Control.Monad.Trans.Reader
26import Control.Monad.Trans.Resource
26import Control.Monad.Trans.Resource
27import Control.Monad.Trans.State
27import Control.Monad.Trans.State
28import Control.Monad.Trans.Writer
28import Control.Monad.Trans.Writer
29−import Data.Aeson (ToJSON (..), object)
29+import Data.Aeson (FromJSON (..), ToJSON (..),
30+ object)
30import qualified Data.Aeson as A
31import qualified Data.Aeson as A
31import Data.Foldable (foldMap)
32import Data.Foldable (foldMap)
32import qualified Data.HashMap.Strict as HM
33import qualified Data.HashMap.Strict as HM
@@ -49,7 +50,7 @@ import System.Posix
49
50
50-------------------------------------------------------------------------------
51-------------------------------------------------------------------------------
51newtype Namespace = Namespace { unNamespace :: [Text] }
52newtype Namespace = Namespace { unNamespace :: [Text] }
52− deriving (Eq,Show,Read,Ord,Generic,ToJSON,Monoid)
53+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Monoid)
53
54
54instance IsString Namespace where
55instance IsString Namespace where
55 fromString s = Namespace [fromString s]
56 fromString s = Namespace [fromString s]
@@ -64,7 +65,7 @@ intercalateNs (Namespace xs) = intersperse "." xs
64-------------------------------------------------------------------------------
65-------------------------------------------------------------------------------
65-- | Application environment, like @prod@, @devel@, @testing@.
66-- | Application environment, like @prod@, @devel@, @testing@.
66newtype Environment = Environment { getEnvironment :: Text }
67newtype Environment = Environment { getEnvironment :: Text }
67− deriving (Eq,Show,Read,Ord,Generic,ToJSON,IsString)
68+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,IsString)
68
69
69
70
70-------------------------------------------------------------------------------
71-------------------------------------------------------------------------------
@@ -106,8 +107,37 @@ renderSeverity s = case s of
106
107
107
108
108-------------------------------------------------------------------------------
109-------------------------------------------------------------------------------
110+severityText :: Prism' Text Severity
111+severityText = prism fromSev toSev
112+ where
113+ fromSev DebugS = "Debug"
114+ fromSev InfoS = "Info"
115+ fromSev NoticeS = "Notice"
116+ fromSev WarningS = "Warning"
117+ fromSev ErrorS = "Error"
118+ fromSev CriticalS = "Critical"
119+ fromSev AlertS = "Alert"
120+ fromSev EmergencyS = "Emergency"
121+ toSev "Debug" = Right DebugS
122+ toSev "Info" = Right InfoS
123+ toSev "Notice" = Right NoticeS
124+ toSev "Warning" = Right WarningS
125+ toSev "Error" = Right ErrorS
126+ toSev "Critical" = Right CriticalS
127+ toSev "Alert" = Right AlertS
128+ toSev "Emergency" = Right EmergencyS
129+ toSev x = Left x
130+
109instance ToJSON Severity where
131instance ToJSON Severity where
110− toJSON s = A.String (renderSeverity s)
132+ toJSON s = A.String (s ^. re severityText)
133+
134+
135+instance FromJSON Severity where
136+ parseJSON = A.withText "Severity" parseSeverity
137+ where
138+ parseSeverity t = case t ^? severityText of
139+ Just x -> return x
140+ Nothing -> fail $ "Invalid Severity " ++ toS t
111
141
112
142
113-------------------------------------------------------------------------------
143-------------------------------------------------------------------------------
@@ -122,6 +152,11 @@ instance Monoid LogStr where
122 mappend (LogStr a) (LogStr b) = LogStr (a `mappend` b)
152 mappend (LogStr a) (LogStr b) = LogStr (a `mappend` b)
123 mempty = LogStr mempty
153 mempty = LogStr mempty
124
154
155+instance FromJSON LogStr where
156+ parseJSON = A.withText "LogStr" parseLogStr
157+ where
158+ parseLogStr = return . LogStr . B.fromText
159+
125-------------------------------------------------------------------------------
160-------------------------------------------------------------------------------
126-- | Pack any string-like thing into a 'LogStr'. This will
161-- | Pack any string-like thing into a 'LogStr'. This will
127-- automatically work on 'String', 'ByteString, 'Text' and any of the
162-- automatically work on 'String', 'ByteString, 'Text' and any of the
@@ -141,13 +176,22 @@ showLS :: Show a => a -> LogStr
141showLS = ls . show
176showLS = ls . show
142
177
143
178
179+-------------------------------------------------------------------------------
180+newtype ThreadIdText = ThreadIdText {
181+ getThreadIdText :: Text
182+ } deriving (ToJSON, FromJSON, Show, Eq, Ord)
183+
184+
185+mkThreadIdText :: ThreadId -> ThreadIdText
186+mkThreadIdText = ThreadIdText . T.pack . show
187+
144-------------------------------------------------------------------------------
188-------------------------------------------------------------------------------
145-- | This has everything each log message will contain.
189-- | This has everything each log message will contain.
146data Item a = Item {
190data Item a = Item {
147 _itemApp :: Namespace
191 _itemApp :: Namespace
148 , _itemEnv :: Environment
192 , _itemEnv :: Environment
149 , _itemSeverity :: Severity
193 , _itemSeverity :: Severity
150− , _itemThread :: ThreadId
194+ , _itemThread :: ThreadIdText
151 , _itemHost :: HostName
195 , _itemHost :: HostName
152 , _itemProcess :: ProcessID
196 , _itemProcess :: ProcessID
153 , _itemPayload :: a
197 , _itemPayload :: a
@@ -164,9 +208,9 @@ instance ToJSON a => ToJSON (Item a) where
164 [ "app" A..= _itemApp
208 [ "app" A..= _itemApp
165 , "env" A..= _itemEnv
209 , "env" A..= _itemEnv
166 , "sev" A..= _itemSeverity
210 , "sev" A..= _itemSeverity
167− , "thread" A..= show _itemThread
211+ , "thread" A..= getThreadIdText _itemThread
168 , "host" A..= _itemHost
212 , "host" A..= _itemHost
169− , "pid" A..= A.String (toS (show _itemProcess))
213+ , "pid" A..= ProcessIDJs _itemProcess
170 , "data" A..= _itemPayload
214 , "data" A..= _itemPayload
171 , "msg" A..= (B.toLazyText $ unLogStr _itemMessage)
215 , "msg" A..= (B.toLazyText $ unLogStr _itemMessage)
172 , "at" A..= _itemTime
216 , "at" A..= _itemTime
@@ -187,6 +231,61 @@ instance ToJSON LocJs where
187 ]
231 ]
188
232
189
233
234+instance FromJSON LocJs where
235+ parseJSON = A.withObject "LocJs" parseLocJs
236+ where
237+ parseLocJs o = do
238+ fn <- o A..: "loc_fn"
239+ p <- o A..: "loc_pkg"
240+ m <- o A..: "loc_mod"
241+ l <- o A..: "loc_ln"
242+ c <- o A..: "loc_col"
243+ return $ LocJs $ Loc fn p m (l, c) (l, c)
244+
245+
246+instance FromJSON a => FromJSON (Item a) where
247+ parseJSON = A.withObject "Item" parseItem
248+ where --TODO: match these up with the serialize
249+ parseItem o = Item
250+ <$> o A..: "app"
251+ <*> o A..: "env"
252+ <*> o A..: "sev"
253+ <*> o A..: "thread"
254+ <*> o A..: "host"
255+ <*> (getProcessIDJs <$> o A..: "pid")
256+ <*> o A..: "data"
257+ <*> o A..: "msg"
258+ <*> o A..: "at"
259+ <*> o A..: "ns"
260+ <*> (fmap getLocJs <$> o A..: "loc")
261+
262+
263+processIDText :: Prism' Text ProcessID
264+processIDText = prism fromProcessID toProcessID
265+ where
266+ fromProcessID = toS . show
267+ toProcessID t = case toS t ^? _Show of
268+ Just i -> Right i
269+ Nothing -> Left t
270+
271+
272+newtype ProcessIDJs = ProcessIDJs {
273+ getProcessIDJs :: ProcessID
274+ }
275+
276+
277+instance ToJSON ProcessIDJs where
278+ toJSON (ProcessIDJs p) = A.String (p ^. re processIDText)
279+
280+
281+instance FromJSON ProcessIDJs where
282+ parseJSON = A.withText "ProcessID" parseProcessID
283+ where
284+ parseProcessID t = case t ^? processIDText of
285+ Just p -> return $ ProcessIDJs p
286+ Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t
287+
288+
190-------------------------------------------------------------------------------
289-------------------------------------------------------------------------------
191-- | Field selector by verbosity within JSON payload.
290-- | Field selector by verbosity within JSON payload.
192data PayloadSelection
291data PayloadSelection
@@ -411,7 +510,7 @@ logItem a ns loc sev msg = do
411 <$> pure _logEnvNs
510 <$> pure _logEnvNs
412 <*> pure _logEnvEnv
511 <*> pure _logEnvEnv
413 <*> pure sev
512 <*> pure sev
414− <*> liftIO myThreadId
513+ <*> liftIO (mkThreadIdText <$> myThreadId)
415 <*> pure _logEnvHost
514 <*> pure _logEnvHost
416 <*> pure _logEnvPid
515 <*> pure _logEnvPid
417 <*> pure a
516 <*> pure a
katip/test/Katip/Tests.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE StandaloneDeriving #-}
4+{-# OPTIONS_GHC -fno-warn-orphans #-}
5+module Katip.Tests
6+ ( tests
7+ ) where
8+
9+
10+-------------------------------------------------------------------------------
11+import Control.Applicative
12+import Data.Aeson
13+import qualified Data.Text.Lazy.Builder as B
14+import Data.Time
15+import Data.Time.Clock.POSIX
16+import Language.Haskell.TH
17+import System.Posix.Types
18+import Test.QuickCheck.Instances ()
19+import Test.Tasty
20+import Test.Tasty.QuickCheck
21+-------------------------------------------------------------------------------
22+import Katip
23+-------------------------------------------------------------------------------
24+
25+
26+tests :: TestTree
27+tests = testGroup "Katip"
28+ [
29+ testProperty "JSON cycle Item" $ \(i :: Item ()) ->
30+ prop_json_cycle i
31+ ]
32+
33+
34+-------------------------------------------------------------------------------
35+prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property
36+prop_json_cycle a = eitherDecode (encode a) === Right a
37+
38+
39+-------------------------------------------------------------------------------
40+instance Arbitrary a => Arbitrary (Item a) where
41+ arbitrary = Item
42+ <$> arbitrary
43+ <*> arbitrary
44+ <*> arbitrary
45+ <*> arbitrary
46+ <*> arbitrary
47+ <*> arbitrary
48+ <*> arbitrary
49+ <*> arbitrary
50+ <*> (getCleanUTCTime <$> arbitrary)
51+ <*> arbitrary
52+ <*> arbitrary
53+
54+
55+-------------------------------------------------------------------------------
56+newtype CleanUTCTime = CleanUTCTime {
57+ getCleanUTCTime :: UTCTime
58+ }
59+
60+
61+-------------------------------------------------------------------------------
62+-- Work around time parsing precision issues in aeson
63+instance Arbitrary CleanUTCTime where
64+ arbitrary = CleanUTCTime . posixSecondsToUTCTime . fromInteger <$> arbitrary
65+
66+
67+-------------------------------------------------------------------------------
68+deriving instance Arbitrary Namespace
69+deriving instance Arbitrary Environment
70+deriving instance Arbitrary ThreadIdText
71+deriving instance Arbitrary CPid
72+deriving instance Eq Loc
73+deriving instance Eq LogStr
74+deriving instance Show Loc
75+deriving instance Show LogStr
76+deriving instance (Eq a) => Eq (Item a)
77+deriving instance (Show a) => Show (Item a)
78+
79+
80+-------------------------------------------------------------------------------
81+instance Arbitrary Loc where
82+ arbitrary = do
83+ f <- arbitrary
84+ p <- arbitrary
85+ m <- arbitrary
86+ s <- arbitrary
87+ return $ Loc f p m s s
88+
89+
90+-------------------------------------------------------------------------------
91+instance Arbitrary Severity where
92+ arbitrary = oneof $ map pure [ DebugS
93+ , InfoS
94+ , NoticeS
95+ , WarningS
96+ , ErrorS
97+ , CriticalS
98+ , AlertS
99+ , EmergencyS
100+ ]
101+
102+
103+-------------------------------------------------------------------------------
104+instance Arbitrary LogStr where
105+ arbitrary = LogStr . B.fromText <$> arbitrary
katip/test/Main.hsnew file+17
@@ -0,0 +1,17 @@
1+module Main (main) where
2+
3+-------------------------------------------------------------------------------
4+import Test.Tasty
5+-------------------------------------------------------------------------------
6+import Katip.Tests
7+-------------------------------------------------------------------------------
8+
9+
10+main :: IO ()
11+main = defaultMain testSuite
12+
13+testSuite :: TestTree
14+testSuite = testGroup "katip"
15+ [
16+ Katip.Tests.tests
17+ ]