@@ -26,7 +26,8 @@ import Control.Monad.Trans.Reader
2626import Control.Monad.Trans.Resource
2727import Control.Monad.Trans.State
2828import Control.Monad.Trans.Writer
29−import Data.Aeson (ToJSON (..), object)
29+import Data.Aeson (FromJSON (..), ToJSON (..),
30+ object)
3031import qualified Data.Aeson as A
3132import Data.Foldable (foldMap)
3233import qualified Data.HashMap.Strict as HM
@@ -49,7 +50,7 @@ import System.Posix
4950
5051-------------------------------------------------------------------------------
5152newtype Namespace = Namespace { unNamespace :: [Text] }
52− deriving (Eq,Show,Read,Ord,Generic,ToJSON,Monoid)
53+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Monoid)
5354
5455instance IsString Namespace where
5556 fromString s = Namespace [fromString s]
@@ -64,7 +65,7 @@ intercalateNs (Namespace xs) = intersperse "." xs
6465-------------------------------------------------------------------------------
6566-- | Application environment, like @prod@, @devel@, @testing@.
6667newtype Environment = Environment { getEnvironment :: Text }
67− deriving (Eq,Show,Read,Ord,Generic,ToJSON,IsString)
68+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,IsString)
6869
6970
7071-------------------------------------------------------------------------------
@@ -106,8 +107,37 @@ renderSeverity s = case s of
106107
107108
108109-------------------------------------------------------------------------------
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+
109131instance 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
111141
112142
113143-------------------------------------------------------------------------------
@@ -122,6 +152,11 @@ instance Monoid LogStr where
122152 mappend (LogStr a) (LogStr b) = LogStr (a `mappend` b)
123153 mempty = LogStr mempty
124154
155+instance FromJSON LogStr where
156+ parseJSON = A.withText "LogStr" parseLogStr
157+ where
158+ parseLogStr = return . LogStr . B.fromText
159+
125160-------------------------------------------------------------------------------
126161-- | Pack any string-like thing into a 'LogStr'. This will
127162-- automatically work on 'String', 'ByteString, 'Text' and any of the
@@ -141,13 +176,22 @@ showLS :: Show a => a -> LogStr
141176showLS = ls . show
142177
143178
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+
144188-------------------------------------------------------------------------------
145189-- | This has everything each log message will contain.
146190data Item a = Item {
147191 _itemApp :: Namespace
148192 , _itemEnv :: Environment
149193 , _itemSeverity :: Severity
150− , _itemThread :: ThreadId
194+ , _itemThread :: ThreadIdText
151195 , _itemHost :: HostName
152196 , _itemProcess :: ProcessID
153197 , _itemPayload :: a
@@ -164,9 +208,9 @@ instance ToJSON a => ToJSON (Item a) where
164208 [ "app" A..= _itemApp
165209 , "env" A..= _itemEnv
166210 , "sev" A..= _itemSeverity
167− , "thread" A..= show _itemThread
211+ , "thread" A..= getThreadIdText _itemThread
168212 , "host" A..= _itemHost
169− , "pid" A..= A.String (toS (show _itemProcess))
213+ , "pid" A..= ProcessIDJs _itemProcess
170214 , "data" A..= _itemPayload
171215 , "msg" A..= (B.toLazyText $ unLogStr _itemMessage)
172216 , "at" A..= _itemTime
@@ -187,6 +231,61 @@ instance ToJSON LocJs where
187231 ]
188232
189233
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+
190289-------------------------------------------------------------------------------
191290-- | Field selector by verbosity within JSON payload.
192291data PayloadSelection
@@ -411,7 +510,7 @@ logItem a ns loc sev msg = do
411510 <$> pure _logEnvNs
412511 <*> pure _logEnvEnv
413512 <*> pure sev
414− <*> liftIO myThreadId
513+ <*> liftIO (mkThreadIdText <$> myThreadId)
415514 <*> pure _logEnvHost
416515 <*> pure _logEnvPid
417516 <*> pure a