875f475 · typeable/katip

git.iko.soy/typeable/katip

on master help sign in

WIP: katip internal queueing

875f475Michael Xavier10 years ago

katip-elasticsearch/test/Main.hs+7−5

compare with master

unifiedsplit

@@ -18,7 +18,6 @@ import Data.Aeson

18import Data.Aeson.Lens

19import Data.Aeson.Types

20import qualified Data.HashMap.Strict as HM

21−import qualified Data.Map as M

22import Data.Monoid

21import Data.Monoid

23import Data.Scientific

22import Data.Scientific

24import Data.Time

23import Data.Time

@@ -254,21 +253,24 @@ bh = withBH defaultManagerSettings svr

254

253

255-------------------------------------------------------------------------------

254-------------------------------------------------------------------------------

256withTestLogging

255withTestLogging

257− :: IO (Scribe, IO a) -> (IO Reply -> KatipT IO b) -> IO b

256+ :: IO (Scribe, IO ()) -> (IO Reply -> KatipT IO b) -> IO b

258withTestLogging = withTestLogging' id

257withTestLogging = withTestLogging' id

259

258

260

259

261-------------------------------------------------------------------------------

260-------------------------------------------------------------------------------

262withTestLogging'

261withTestLogging'

263 :: (LogEnv -> LogEnv)

262 :: (LogEnv -> LogEnv)

264− -> IO (Scribe, IO a)

263+ -> IO (Scribe, IO ())

265 -> (IO Reply -> KatipT IO b)

264 -> (IO Reply -> KatipT IO b)

266 -> IO b

265 -> IO b

267withTestLogging' modEnv setup f = do

266withTestLogging' modEnv setup f = do

268 (scr, done) <- setup

267 (scr, done) <- setup

269 le <- modEnv <$> initLogEnv ns env

268 le <- modEnv <$> initLogEnv ns env

269+ le' <- registerScribe "es" scr (defaultScribeSettings done) le

270+ let done' = do

271+ _ <- clearScribes le'

270− let done' = done >> bh (refreshIndex ixn)

272+ bh (refreshIndex ixn)

271− runKatipT le { _logEnvScribes = M.singleton "es" scr} (f done')

273+ runKatipT le' (f done')

272 where

274 where

273 ns = Namespace ["katip-test"]

275 ns = Namespace ["katip-test"]

274 env = Environment "test"

276 env = Environment "test"

katip/src/Katip.hs+2

@@ -40,6 +40,8 @@ module Katip

40 , Scribe (..)

41 , LogEnv (..)

42 , SimpleLogPayload, sl

43+ , defaultScribeSettings --TODO: lenses and whatnot to avoid breakage

44+ , ScribeSettings(..)

44 -- ** @lens@-compatible Lenses

46 -- ** @lens@-compatible Lenses

45 , itemApp

47 , itemApp

katip/src/Katip/Core.hs+113−45

@@ -5,6 +5,7 @@

5{-# LANGUAGE ExistentialQuantification #-}

6{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE GADTs #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE ImplicitParams #-}

10{-# LANGUAGE ImplicitParams #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE MultiParamTypeClasses #-}

@@ -22,9 +23,12 @@

22module Katip.Core where

23module Katip.Core where

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

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

25−import Control.Applicative as A

26+import Control.Applicative as A

26import Control.AutoUpdate

27import Control.AutoUpdate

27import Control.Concurrent

28import Control.Concurrent

29+import qualified Control.Concurrent.Async as Async

30+import qualified Control.Concurrent.Chan.Unagi.Bounded as UB

31+import Control.Monad (void)

28import Control.Monad.Base

32import Control.Monad.Base

29import Control.Monad.Catch

33import Control.Monad.Catch

30import Control.Monad.IO.Class

34import Control.Monad.IO.Class

@@ -37,21 +41,21 @@ import Control.Monad.Trans.Reader

37import Control.Monad.Trans.Resource

41import Control.Monad.Trans.Resource

38import Control.Monad.Trans.State

42import Control.Monad.Trans.State

39import Control.Monad.Trans.Writer

43import Control.Monad.Trans.Writer

40−import Data.Aeson (FromJSON (..), ToJSON (..),

44+import Data.Aeson (FromJSON (..),

41− object)

45+ ToJSON (..), object)

42−import qualified Data.Aeson as A

46+import qualified Data.Aeson as A

43−import Data.Foldable as FT

47+import Data.Foldable as FT

44−import qualified Data.HashMap.Strict as HM

48+import qualified Data.HashMap.Strict as HM

45import Data.List

49import Data.List

46−import qualified Data.Map.Strict as M

50+import qualified Data.Map.Strict as M

47import Data.Semigroup

51import Data.Semigroup

48import Data.String

52import Data.String

49import Data.String.Conv

53import Data.String.Conv

50−import Data.Text (Text)

54+import Data.Text (Text)

51−import qualified Data.Text as T

55+import qualified Data.Text as T

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

56+import qualified Data.Text.Lazy.Builder as B

53import Data.Time

57import Data.Time

54−import GHC.Generics hiding (to)

58+import GHC.Generics hiding (to)

55#if MIN_VERSION_base(4, 8, 0)

59#if MIN_VERSION_base(4, 8, 0)

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

60#if !MIN_VERSION_base(4, 9, 0)

57import GHC.SrcLoc

61import GHC.SrcLoc

@@ -59,7 +63,7 @@ import GHC.SrcLoc

59import GHC.Stack

63import GHC.Stack

60#endif

64#endif

61import Language.Haskell.TH

65import Language.Haskell.TH

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

66+import qualified Language.Haskell.TH.Syntax as TH

63import Lens.Micro

67import Lens.Micro

64import Lens.Micro.TH

68import Lens.Micro.TH

65import Network.HostName

69import Network.HostName

@@ -75,8 +79,8 @@ import System.Posix

75readMay :: Read a => String -> Maybe a

79readMay :: Read a => String -> Maybe a

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

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

77 [x] -> Just x

81 [x] -> Just x

78− [] -> Nothing -- no parse

82+ [] -> Nothing -- no parse

79− _ -> Nothing -- Ambiguous parse

83+ _ -> Nothing -- Ambiguous parse

82-------------------------------------------------------------------------------

86-------------------------------------------------------------------------------

@@ -132,13 +136,13 @@ data Verbosity = V0 | V1 | V2 | V3

132-------------------------------------------------------------------------------

136-------------------------------------------------------------------------------

133renderSeverity :: Severity -> Text

137renderSeverity :: Severity -> Text

134renderSeverity s = case s of

138renderSeverity s = case s of

135− DebugS -> "Debug"

139+ DebugS -> "Debug"

136− InfoS -> "Info"

140+ InfoS -> "Info"

137− NoticeS -> "Notice"

141+ NoticeS -> "Notice"

138− WarningS -> "Warning"

142+ WarningS -> "Warning"

139− ErrorS -> "Error"

143+ ErrorS -> "Error"

140− CriticalS -> "Critical"

144+ CriticalS -> "Critical"

141− AlertS -> "Alert"

145+ AlertS -> "Alert"

142 EmergencyS -> "Emergency"

146 EmergencyS -> "Emergency"

143

147

144

148

@@ -164,7 +168,7 @@ instance FromJSON Severity where

164 parseJSON = A.withText "Severity" parseSeverity

168 parseJSON = A.withText "Severity" parseSeverity

165 where

169 where

166 parseSeverity t = case textToSeverity t of

170 parseSeverity t = case textToSeverity t of

167− Just x -> return x

171+ Just x -> return x

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

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

169

173

170

174

@@ -343,7 +347,7 @@ instance FromJSON ProcessIDJs where

343 parseJSON = A.withText "ProcessID" parseProcessID

347 parseJSON = A.withText "ProcessID" parseProcessID

344 where

348 where

345 parseProcessID t = case textToProcessID t of

349 parseProcessID t = case textToProcessID t of

346− Just p -> return $ ProcessIDJs p

350+ Just p -> return $ ProcessIDJs p

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

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

348

352

349

353

@@ -380,7 +384,7 @@ class ToObject a where

380 default toObject :: ToJSON a => a -> A.Object

384 default toObject :: ToJSON a => a -> A.Object

381 toObject v = case toJSON v of

385 toObject v = case toJSON v of

382 A.Object o -> o

386 A.Object o -> o

383− _ -> mempty

387+ _ -> mempty

384

388

385instance ToObject ()

389instance ToObject ()

386instance ToObject A.Object

390instance ToObject A.Object

@@ -432,7 +436,7 @@ instance ToObject SimpleLogPayload

432

436

433instance LogItem SimpleLogPayload where

437instance LogItem SimpleLogPayload where

434 payloadKeys V0 _ = SomeKeys []

438 payloadKeys V0 _ = SomeKeys []

435− payloadKeys _ _ = AllKeys

439+ payloadKeys _ _ = AllKeys

436

440

437

441

438instance Semigroup SimpleLogPayload where

442instance Semigroup SimpleLogPayload where

@@ -455,7 +459,7 @@ sl a b = SimpleLogPayload [(a, AnyLogPayload b)]

455-- automatically bubble higher verbosity levels to lower ones.

459-- automatically bubble higher verbosity levels to lower ones.

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

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

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

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

458− AllKeys -> toObject a

462+ AllKeys -> toObject a

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

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

460

464

461

465

@@ -498,9 +502,9 @@ itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb

498-- down gracefully before returning. This can be hooked into your

502-- down gracefully before returning. This can be hooked into your

499-- application's shutdown routine to ensure you never miss any log

503-- application's shutdown routine to ensure you never miss any log

500-- messages on shutdown.

504-- messages on shutdown.

501−data Scribe = Scribe {

505+newtype Scribe = Scribe {

502− liPush :: forall a. LogItem a => Item a -> IO ()

506+ liPush :: forall a. LogItem a => Item a -> IO ()

503− }

507+ }

504

508

505

509

506instance Semigroup Scribe where

510instance Semigroup Scribe where

@@ -514,6 +518,19 @@ instance Monoid Scribe where

514 mappend = (<>)

518 mappend = (<>)

515

519

516

520

521+-------------------------------------------------------------------------------

522+data ScribeHandle = ScribeHandle {

523+ shFinalizer :: IO ()

524+ , shChan :: UB.InChan WorkerMessage

525+ }

526+

527+

528+-------------------------------------------------------------------------------

529+data WorkerMessage where

530+ NewItem :: LogItem a => Item a -> WorkerMessage

531+ PoisonPill :: WorkerMessage

532+

533+

517-------------------------------------------------------------------------------

534-------------------------------------------------------------------------------

518-- | Should this item be logged given the user's maximum severity?

535-- | Should this item be logged given the user's maximum severity?

519permitItem :: Severity -> Item a -> Bool

536permitItem :: Severity -> Item a -> Bool

@@ -536,7 +553,7 @@ data LogEnv = LogEnv {

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

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

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

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

538 -- you could just use 'getCurrentTime'.

555 -- you could just use 'getCurrentTime'.

539− , _logEnvScribes :: M.Map Text Scribe

556+ , _logEnvScribes :: M.Map Text ScribeHandle

540 }

557 }

541makeLenses ''LogEnv

558makeLenses ''LogEnv

542

559

@@ -568,20 +585,70 @@ registerScribe

568 :: Text

585 :: Text

569 -- ^ Name the scribe

586 -- ^ Name the scribe

570 -> Scribe

587 -> Scribe

588+ -> ScribeSettings

571 -> LogEnv

589 -> LogEnv

572− -> LogEnv

590+ -> IO LogEnv

591+registerScribe nm scribe ScribeSettings {..} le = do

592+ (inChan, outChan) <- UB.newChan scribeBufferSize

593+ worker <- spawnScribeWorker scribe outChan

594+ let fin = do

595+ UB.writeChan inChan PoisonPill

596+ -- wait for our worker to finish final write

597+ void (Async.waitCatch worker)

598+ --TODO: safe exceptions

599+ -- wait for scribe to finish final write

600+ scribeFinalizer

601+

602+ let sh = ScribeHandle fin inChan

573−registerScribe nm h = logEnvScribes %~ M.insert nm h

603+ return (le & logEnvScribes %~ M.insert nm sh)

604+

605+

606+-------------------------------------------------------------------------------

607+--TODO: should do some reasonable exception handling in the scribe, don't want to crash the loop

608+spawnScribeWorker :: Scribe -> UB.OutChan WorkerMessage -> IO (Async.Async ())

609+spawnScribeWorker (Scribe write) outChan = Async.async go

610+ where

611+ go = do

612+ newCmd <- UB.readChan outChan

613+ case newCmd of

614+ NewItem a -> do

615+ write a

616+ go

617+ PoisonPill -> return ()

618+

619+

620+-------------------------------------------------------------------------------

621+data ScribeSettings = ScribeSettings {

622+ scribeFinalizer :: IO ()

623+ -- ^ Provide a *blocking* finalizer to call when your scribe is

624+ -- removed. If this is not relevant to your scribe, return () is

625+ -- fine.

626+ , scribeBufferSize :: Int

627+ }

628+

629+

630+--TODO: standardize on american or british spelling of finali{z,s}er

631+-- | Reasonable defaults for a scribe. No-op finalizer and a buffer

632+-- size of 4096.

633+defaultScribeSettings

634+ :: IO ()

635+ -- ^ Finalizer

636+ -> ScribeSettings

637+defaultScribeSettings fin = ScribeSettings fin 4096

574

638

575

639

576-------------------------------------------------------------------------------

640-------------------------------------------------------------------------------

577-- | Remove a scribe from the list. All future log calls will no

641-- | Remove a scribe from the list. All future log calls will no

578−-- longer use this scribe. If the given scribe doesn't exist, its a no-op.

642+-- longer use this scribe. If there is a finalizer, it will be called

643+-- in a blocking manner.

579unregisterScribe

644unregisterScribe

580 :: Text

645 :: Text

581 -- ^ Name of the scribe

646 -- ^ Name of the scribe

582 -> LogEnv

647 -> LogEnv

583− -> LogEnv

648+ -> IO LogEnv

649+unregisterScribe nm le = do

650+ maybe (return ()) shFinalizer (M.lookup nm (_logEnvScribes le))

584−unregisterScribe nm = logEnvScribes %~ M.delete nm

651+ return (le & logEnvScribes %~ M.delete nm)

585

652

586

653

587-------------------------------------------------------------------------------

654-------------------------------------------------------------------------------

@@ -592,8 +659,9 @@ unregisterScribe nm = logEnvScribes %~ M.delete nm

592-- example.

659-- example.

593clearScribes

660clearScribes

594 :: LogEnv

661 :: LogEnv

595− -> LogEnv

662+ -> IO LogEnv

596−clearScribes = logEnvScribes .~ mempty

663+clearScribes le =

664+ foldrM unregisterScribe le (M.keys (_logEnvScribes le))

597

665

598

666

599-------------------------------------------------------------------------------

667-------------------------------------------------------------------------------

@@ -692,7 +760,7 @@ logItem a ns loc sev msg = do

692 <*> _logEnvTimer

760 <*> _logEnvTimer

693 <*> pure (_logEnvApp <> ns)

761 <*> pure (_logEnvApp <> ns)

694 <*> pure loc

762 <*> pure loc

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

763+ FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> UB.tryWriteChan shChan (NewItem item)

696

764

697

765

698-------------------------------------------------------------------------------

766-------------------------------------------------------------------------------

@@ -755,14 +823,14 @@ instance TH.Lift Verbosity where

755

823

756

824

757instance TH.Lift Severity where

825instance TH.Lift Severity where

758− lift DebugS = [| DebugS |]

826+ lift DebugS = [| DebugS |]

759− lift InfoS = [| InfoS |]

827+ lift InfoS = [| InfoS |]

760− lift NoticeS = [| NoticeS |]

828+ lift NoticeS = [| NoticeS |]

761− lift WarningS = [| WarningS |]

829+ lift WarningS = [| WarningS |]

762− lift ErrorS = [| ErrorS |]

830+ lift ErrorS = [| ErrorS |]

763 lift CriticalS = [| CriticalS |]

831 lift CriticalS = [| CriticalS |]

764− lift AlertS = [| AlertS |]

832+ lift AlertS = [| AlertS |]

765− lift EmergencyS = [| EmergencyS |]

833+ lift EmergencyS = [| EmergencyS |]

766

834

767

835

768-- | Lift a location into an Exp.

836-- | Lift a location into an Exp.

katip/src/Katip/Monadic.hs+2−1

@@ -65,6 +65,7 @@ import Data.Monoid as M

65import Data.Sequence as Seq

66import Data.Text (Text)

67import Language.Haskell.TH

68+import Lens.Micro

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

69-------------------------------------------------------------------------------

69import Katip.Core

70import Katip.Core

70-------------------------------------------------------------------------------

71-------------------------------------------------------------------------------

@@ -357,4 +358,4 @@ katipNoLogging

357 => KatipContextT m a

358 => KatipContextT m a

358 -> KatipContextT m a

359 -> KatipContextT m a

359katipNoLogging (KatipContextT f) =

360katipNoLogging (KatipContextT f) =

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

361+ KatipContextT (local (\r -> r { ltsLogEnv = set logEnvScribes mempty (ltsLogEnv r)}) f)

katip/src/Katip/Scribes/Handle.hs+9−8

@@ -50,9 +50,10 @@ data ColorStrategy

50 -- ^ Color if output is a terminal

52-------------------------------------------------------------------------------

53+--TODO: probably drop this stuff since katip does buffering and this isn't doing concurrent writer workers?

53data WorkerCmd =

54data WorkerCmd =

54− NewItem Builder

55+ HNewItem Builder

55− | PoisonPill

56+ | HPoisonPill

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

58-------------------------------------------------------------------------------

58-- | Logs to a file handle such as stdout, stderr, or a file. Contexts

59-- | Logs to a file handle such as stdout, stderr, or a file. Contexts

@@ -74,23 +75,23 @@ mkHandleScribe cs h sev verb = do

74 ColorIfTerminal -> hIsTerminalDevice h

75 ColorIfTerminal -> hIsTerminalDevice h

75 ColorLog b -> return b

76 ColorLog b -> return b

76 let scribe = Scribe $ \i ->

77 let scribe = Scribe $ \i ->

77− when (permitItem sev i) $ void (U.tryWriteChan inChan (NewItem (formatItem colorize verb i)))

78+ when (permitItem sev i) $ void (U.tryWriteChan inChan (HNewItem (formatItem colorize verb i)))

78 return (scribe, stopWorker worker inChan)

79 return (scribe, stopWorker worker inChan)

80 where

81 where

81 stopWorker :: Async () -> U.InChan WorkerCmd -> IO ()

82 stopWorker :: Async () -> U.InChan WorkerCmd -> IO ()

82 stopWorker worker inChan = do

83 stopWorker worker inChan = do

83− U.writeChan inChan PoisonPill

84+ U.writeChan inChan HPoisonPill

84 void $ waitCatch worker

85 void $ waitCatch worker

86 workerLoop :: U.OutChan WorkerCmd -> IO ()

87 workerLoop :: U.OutChan WorkerCmd -> IO ()

87 workerLoop outChan = do

88 workerLoop outChan = do

88 newCmd <- U.readChan outChan

89 newCmd <- U.readChan outChan

89 case newCmd of

90 case newCmd of

90− NewItem b -> do

91+ HNewItem b -> do

91 T.hPutStrLn h $ toLazyText b

92 T.hPutStrLn h $ toLazyText b

92 workerLoop outChan

93 workerLoop outChan

93− PoisonPill -> return ()

94+ HPoisonPill -> return ()

95-------------------------------------------------------------------------------

96-------------------------------------------------------------------------------

96formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder

97formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder

@@ -127,8 +128,8 @@ formatItem withColor verb Item{..} =

127_ioLogEnv :: LogEnv

128_ioLogEnv :: LogEnv

128_ioLogEnv = unsafePerformIO $ do

129_ioLogEnv = unsafePerformIO $ do

129 le <- initLogEnv "io" "io"

130 le <- initLogEnv "io" "io"

130− (lh, _) <- mkHandleScribe ColorIfTerminal stdout DebugS V3

131+ (lh, finalizer) <- mkHandleScribe ColorIfTerminal stdout DebugS V3

131− return $ registerScribe "stdout" lh le

132+ registerScribe "stdout" lh (defaultScribeSettings finalizer) le

132{-# NOINLINE _ioLogEnv #-}

133{-# NOINLINE _ioLogEnv #-}

133

134

135

katip/test/Katip/Tests/Scribes/Handle.hs+3−2

@@ -40,7 +40,7 @@ tests = testGroup "Katip.Scribes.Handle"

40 res <- readFile path

41 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

42 let matches = res =~ pat

43− assertBool (res <> " did not match") matches

43+ assertBool (show res <> " did not match") matches

44 , withResource setupTempFile teardownTempFile $ \setupFn ->

45 goldenVsString "Text-golden"

46 "test/Katip/Tests/Scribes/Handle-text.golden"

@@ -80,7 +80,8 @@ setup = do

80 (fp, h) <- openTempFile tempDir "katip.log"

81 (s, finaliser) <- mkHandleScribe (ColorLog False) h DebugS V3

82 le <- initLogEnv "katip-test" "test"

83− return (fp, h, finaliser, registerScribe "handle" s le)

83+ le' <- registerScribe "handle" s (defaultScribeSettings finaliser) le

84+ return (fp, h, void (clearScribes le'), le')

86-------------------------------------------------------------------------------

87-------------------------------------------------------------------------------