@@ -5,6 +5,7 @@
55{-# LANGUAGE ExistentialQuantification #-}
66{-# LANGUAGE FlexibleContexts #-}
77{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE GADTs #-}
89{-# LANGUAGE GeneralizedNewtypeDeriving #-}
910{-# LANGUAGE ImplicitParams #-}
1011{-# LANGUAGE MultiParamTypeClasses #-}
@@ -22,9 +23,12 @@
2223module Katip.Core where
2324
2425-------------------------------------------------------------------------------
25−import Control.Applicative as A
26+import Control.Applicative as A
2627import Control.AutoUpdate
2728import 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)
2832import Control.Monad.Base
2933import Control.Monad.Catch
3034import Control.Monad.IO.Class
@@ -37,21 +41,21 @@ import Control.Monad.Trans.Reader
3741import Control.Monad.Trans.Resource
3842import Control.Monad.Trans.State
3943import Control.Monad.Trans.Writer
40−import Data.Aeson (FromJSON (..), ToJSON (..),
41− object)
42−import qualified Data.Aeson as A
43−import Data.Foldable as FT
44−import qualified Data.HashMap.Strict as HM
44+import Data.Aeson (FromJSON (..),
45+ ToJSON (..), object)
46+import qualified Data.Aeson as A
47+import Data.Foldable as FT
48+import qualified Data.HashMap.Strict as HM
4549import Data.List
46−import qualified Data.Map.Strict as M
50+import qualified Data.Map.Strict as M
4751import Data.Semigroup
4852import Data.String
4953import Data.String.Conv
50−import Data.Text (Text)
51−import qualified Data.Text as T
52−import qualified Data.Text.Lazy.Builder as B
54+import Data.Text (Text)
55+import qualified Data.Text as T
56+import qualified Data.Text.Lazy.Builder as B
5357import Data.Time
54−import GHC.Generics hiding (to)
58+import GHC.Generics hiding (to)
5559#if MIN_VERSION_base(4, 8, 0)
5660#if !MIN_VERSION_base(4, 9, 0)
5761import GHC.SrcLoc
@@ -59,7 +63,7 @@ import GHC.SrcLoc
5963import GHC.Stack
6064#endif
6165import Language.Haskell.TH
62−import qualified Language.Haskell.TH.Syntax as TH
66+import qualified Language.Haskell.TH.Syntax as TH
6367import Lens.Micro
6468import Lens.Micro.TH
6569import Network.HostName
@@ -75,8 +79,8 @@ import System.Posix
7579readMay :: Read a => String -> Maybe a
7680readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
7781 [x] -> Just x
78− [] -> Nothing -- no parse
79− _ -> Nothing -- Ambiguous parse
82+ [] -> Nothing -- no parse
83+ _ -> Nothing -- Ambiguous parse
8084
8185
8286-------------------------------------------------------------------------------
@@ -132,13 +136,13 @@ data Verbosity = V0 | V1 | V2 | V3
132136-------------------------------------------------------------------------------
133137renderSeverity :: Severity -> Text
134138renderSeverity s = case s of
135− DebugS -> "Debug"
136− InfoS -> "Info"
137− NoticeS -> "Notice"
138− WarningS -> "Warning"
139− ErrorS -> "Error"
140− CriticalS -> "Critical"
141− AlertS -> "Alert"
139+ DebugS -> "Debug"
140+ InfoS -> "Info"
141+ NoticeS -> "Notice"
142+ WarningS -> "Warning"
143+ ErrorS -> "Error"
144+ CriticalS -> "Critical"
145+ AlertS -> "Alert"
142146 EmergencyS -> "Emergency"
143147
144148
@@ -164,7 +168,7 @@ instance FromJSON Severity where
164168 parseJSON = A.withText "Severity" parseSeverity
165169 where
166170 parseSeverity t = case textToSeverity t of
167− Just x -> return x
171+ Just x -> return x
168172 Nothing -> fail $ "Invalid Severity " ++ toS t
169173
170174
@@ -343,7 +347,7 @@ instance FromJSON ProcessIDJs where
343347 parseJSON = A.withText "ProcessID" parseProcessID
344348 where
345349 parseProcessID t = case textToProcessID t of
346− Just p -> return $ ProcessIDJs p
350+ Just p -> return $ ProcessIDJs p
347351 Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t
348352
349353
@@ -380,7 +384,7 @@ class ToObject a where
380384 default toObject :: ToJSON a => a -> A.Object
381385 toObject v = case toJSON v of
382386 A.Object o -> o
383− _ -> mempty
387+ _ -> mempty
384388
385389instance ToObject ()
386390instance ToObject A.Object
@@ -432,7 +436,7 @@ instance ToObject SimpleLogPayload
432436
433437instance LogItem SimpleLogPayload where
434438 payloadKeys V0 _ = SomeKeys []
435− payloadKeys _ _ = AllKeys
439+ payloadKeys _ _ = AllKeys
436440
437441
438442instance Semigroup SimpleLogPayload where
@@ -455,7 +459,7 @@ sl a b = SimpleLogPayload [(a, AnyLogPayload b)]
455459-- automatically bubble higher verbosity levels to lower ones.
456460payloadObject :: LogItem a => Verbosity -> a -> A.Object
457461payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of
458− AllKeys -> toObject a
462+ AllKeys -> toObject a
459463 SomeKeys ks -> HM.filterWithKey (\ k _ -> k `FT.elem` ks) $ toObject a
460464
461465
@@ -498,9 +502,9 @@ itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb
498502-- down gracefully before returning. This can be hooked into your
499503-- application's shutdown routine to ensure you never miss any log
500504-- messages on shutdown.
501−data Scribe = Scribe {
502− liPush :: forall a. LogItem a => Item a -> IO ()
503− }
505+newtype Scribe = Scribe {
506+ liPush :: forall a. LogItem a => Item a -> IO ()
507+ }
504508
505509
506510instance Semigroup Scribe where
@@ -514,6 +518,19 @@ instance Monoid Scribe where
514518 mappend = (<>)
515519
516520
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+
517534-------------------------------------------------------------------------------
518535-- | Should this item be logged given the user's maximum severity?
519536permitItem :: Severity -> Item a -> Bool
@@ -536,7 +553,7 @@ data LogEnv = LogEnv {
536553 -- 'AutoUpdate' for high volume logs but note that this may cause
537554 -- some output forms to display logs out of order. Alternatively,
538555 -- you could just use 'getCurrentTime'.
539− , _logEnvScribes :: M.Map Text Scribe
556+ , _logEnvScribes :: M.Map Text ScribeHandle
540557 }
541558makeLenses ''LogEnv
542559
@@ -568,20 +585,70 @@ registerScribe
568585 :: Text
569586 -- ^ Name the scribe
570587 -> Scribe
588+ -> ScribeSettings
571589 -> LogEnv
572− -> LogEnv
573−registerScribe nm h = logEnvScribes %~ M.insert nm h
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
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
574638
575639
576640-------------------------------------------------------------------------------
577641-- | 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.
579644unregisterScribe
580645 :: Text
581646 -- ^ Name of the scribe
582647 -> LogEnv
583− -> LogEnv
584−unregisterScribe nm = logEnvScribes %~ M.delete nm
648+ -> IO LogEnv
649+unregisterScribe nm le = do
650+ maybe (return ()) shFinalizer (M.lookup nm (_logEnvScribes le))
651+ return (le & logEnvScribes %~ M.delete nm)
585652
586653
587654-------------------------------------------------------------------------------
@@ -592,8 +659,9 @@ unregisterScribe nm = logEnvScribes %~ M.delete nm
592659-- example.
593660clearScribes
594661 :: LogEnv
595− -> LogEnv
596−clearScribes = logEnvScribes .~ mempty
662+ -> IO LogEnv
663+clearScribes le =
664+ foldrM unregisterScribe le (M.keys (_logEnvScribes le))
597665
598666
599667-------------------------------------------------------------------------------
@@ -692,7 +760,7 @@ logItem a ns loc sev msg = do
692760 <*> _logEnvTimer
693761 <*> pure (_logEnvApp <> ns)
694762 <*> pure loc
695− FT.forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item
763+ FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> UB.tryWriteChan shChan (NewItem item)
696764
697765
698766-------------------------------------------------------------------------------
@@ -755,14 +823,14 @@ instance TH.Lift Verbosity where
755823
756824
757825instance TH.Lift Severity where
758− lift DebugS = [| DebugS |]
759− lift InfoS = [| InfoS |]
760− lift NoticeS = [| NoticeS |]
761− lift WarningS = [| WarningS |]
762− lift ErrorS = [| ErrorS |]
826+ lift DebugS = [| DebugS |]
827+ lift InfoS = [| InfoS |]
828+ lift NoticeS = [| NoticeS |]
829+ lift WarningS = [| WarningS |]
830+ lift ErrorS = [| ErrorS |]
763831 lift CriticalS = [| CriticalS |]
764− lift AlertS = [| AlertS |]
765− lift EmergencyS = [| EmergencyS |]
832+ lift AlertS = [| AlertS |]
833+ lift EmergencyS = [| EmergencyS |]
766834
767835
768836-- | Lift a location into an Exp.