----------------------------------------------------------------------------------------------------

-- | Streaming interface to journalctl. Use 'entryStream' to stream
--   journalctl entries as they are created.
--
--   Designed with qualified import in mind.
--   For example, if you import it as @Journal@, then 'Entry' becomes
--   @Journal.Entry@, and 'Exception' becomes @Journal.Exception@.
--
module Systemd.Journalctl.Stream (
    -- * Journal entry
    Entry (..)
  , Cursor
    -- * Streaming
  , StreamStart (..)
  , entryStream
    -- * Exceptions
  , Exception
  ) where

-- base
import System.IO (Handle)
import Data.Maybe (fromJust)
import Control.Exception qualified as Base
import System.Posix.Types (CPid (..), ProcessID)
import Data.Foldable (toList)
-- text
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Text qualified as Text
-- bytestring
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
-- aeson
import Data.Aeson (FromJSON, parseJSON, (.:), (.:?), ToJSON)
import Data.Aeson qualified as JSON
import Data.Aeson.Types qualified as JSON
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.KeyMap qualified as KeyMap
#endif
-- time
import Data.Time.Clock (secondsToNominalDiffTime)
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Time.LocalTime (LocalTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
-- process
import System.Process qualified as System
-- conduit
import Conduit (MonadResource, MonadThrow, throwM)
import Data.Conduit (ConduitT, (.|))
import Data.Conduit.Combinators qualified as Conduit
-- unordered-containers
#if !MIN_VERSION_aeson(2,0,0)
import Data.HashMap.Strict qualified as HashMap
#endif

-- | A cursor is an opaque text string that uniquely describes
--   the position of an entry in the journal and is portable
--   across machines, platforms and journal files.
--
--   The 'Ord' instance does not order by time. Given two entries
--   @e1@ and @e2@, @e1@ having an earlier timestamp than @e2@ doesn't
--   mean that @entryCursor e1 < entryCursor e2@.
newtype Cursor = Cursor Text deriving (Cursor -> Cursor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cursor -> Cursor -> Bool
$c/= :: Cursor -> Cursor -> Bool
== :: Cursor -> Cursor -> Bool
$c== :: Cursor -> Cursor -> Bool
Eq, Eq Cursor
Cursor -> Cursor -> Bool
Cursor -> Cursor -> Ordering
Cursor -> Cursor -> Cursor
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cursor -> Cursor -> Cursor
$cmin :: Cursor -> Cursor -> Cursor
max :: Cursor -> Cursor -> Cursor
$cmax :: Cursor -> Cursor -> Cursor
>= :: Cursor -> Cursor -> Bool
$c>= :: Cursor -> Cursor -> Bool
> :: Cursor -> Cursor -> Bool
$c> :: Cursor -> Cursor -> Bool
<= :: Cursor -> Cursor -> Bool
$c<= :: Cursor -> Cursor -> Bool
< :: Cursor -> Cursor -> Bool
$c< :: Cursor -> Cursor -> Bool
compare :: Cursor -> Cursor -> Ordering
$ccompare :: Cursor -> Cursor -> Ordering
Ord, Int -> Cursor -> ShowS
[Cursor] -> ShowS
Cursor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cursor] -> ShowS
$cshowList :: [Cursor] -> ShowS
show :: Cursor -> String
$cshow :: Cursor -> String
showsPrec :: Int -> Cursor -> ShowS
$cshowsPrec :: Int -> Cursor -> ShowS
Show)

instance FromJSON Cursor where
  parseJSON :: Value -> Parser Cursor
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
JSON.withText String
"Cursor" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Cursor
Cursor

instance ToJSON Cursor where
  toJSON :: Cursor -> Value
toJSON (Cursor Text
t) = Text -> Value
JSON.String Text
t

-- | A journal entry.
data Entry = Entry
  { -- | Process ID.
    Entry -> Maybe ProcessID
entryPID :: Maybe ProcessID
    -- | The name of the originating host.
  , Entry -> Text
entryHostname :: Text
    -- | Namespace identifier.
  , Entry -> Maybe Text
entryNamespace :: Maybe Text
    -- | Process name.
  , Entry -> Maybe Text
entryProcess :: Maybe Text
    -- | File path to the executable.
  , Entry -> Maybe String
entryExecutable :: Maybe FilePath
    -- | The cursor for the entry.
  , Entry -> Cursor
entryCursor :: Cursor
    -- | The time the entry was received by the journal.
  , Entry -> POSIXTime
entryTimestamp :: POSIXTime
    -- | Unit name, if present.
  , Entry -> Maybe Text
entryUnit :: Maybe Text
    -- | Entry message. It may come in binary or textual format.
  , Entry -> Maybe (Either ByteString Text)
entryMessage :: Maybe (Either ByteString Text)
    } deriving Int -> Entry -> ShowS
[Entry] -> ShowS
Entry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Entry] -> ShowS
$cshowList :: [Entry] -> ShowS
show :: Entry -> String
$cshow :: Entry -> String
showsPrec :: Int -> Entry -> ShowS
$cshowsPrec :: Int -> Entry -> ShowS
Show

-- | Utility type to parse values (mainly numbers) that are received
--   as text.
newtype AsText a = AsText { forall a. AsText a -> a
asText :: a } deriving Int -> AsText a -> ShowS
forall a. Show a => Int -> AsText a -> ShowS
forall a. Show a => [AsText a] -> ShowS
forall a. Show a => AsText a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AsText a] -> ShowS
$cshowList :: forall a. Show a => [AsText a] -> ShowS
show :: AsText a -> String
$cshow :: forall a. Show a => AsText a -> String
showsPrec :: Int -> AsText a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AsText a -> ShowS
Show

instance FromJSON a => FromJSON (AsText a) where
  parseJSON :: Value -> Parser (AsText a)
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
JSON.withText String
"AsText" forall a b. (a -> b) -> a -> b
$
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> AsText a
AsText) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecodeStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

{- Journal fields

For a more complete list of fields and documentation, go to:

https://www.freedesktop.org/software/systemd/man/systemd.journal-fields.html

-}

instance FromJSON Entry where
  parseJSON :: Value -> Parser Entry
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject String
"Entry" forall a b. (a -> b) -> a -> b
$ \Object
o -> Maybe ProcessID
-> Text
-> Maybe Text
-> Maybe Text
-> Maybe String
-> Cursor
-> POSIXTime
-> Maybe Text
-> Maybe (Either ByteString Text)
-> Entry
Entry
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int32 -> ProcessID
CPid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AsText a -> a
asText) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"_PID")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"_HOSTNAME"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"_NAMESPACE"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"_COMM"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"_EXE"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"__CURSOR"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pico -> POSIXTime
secondsToNominalDiffTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/Pico
1000000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AsText a -> a
asText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"__REALTIME_TIMESTAMP")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"UNIT"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser (Maybe (Either ByteString Text))
messageParser Object
o

messageParser :: JSON.Object -> JSON.Parser (Maybe (Either ByteString Text))
messageParser :: Object -> Parser (Maybe (Either ByteString Text))
messageParser Object
obj =
#if MIN_VERSION_aeson(2,0,0)
  case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"MESSAGE" Object
obj of
#else
  case HashMap.lookup "MESSAGE" obj of
#endif
    Just (JSON.String Text
t) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
t
    Just (JSON.Array Array
arr) -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
ByteString.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. FromJSON a => Value -> Parser a
parseJSON (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
arr)
    Just Value
JSON.Null -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Maybe Value
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Maybe Value
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Couldn't parse MESSAGE. Expected String, Array or Null."

-- | Exception raised while streaming entries from journalctl.
data Exception = JSONError String deriving Int -> Exception -> ShowS
[Exception] -> ShowS
Exception -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exception] -> ShowS
$cshowList :: [Exception] -> ShowS
show :: Exception -> String
$cshow :: Exception -> String
showsPrec :: Int -> Exception -> ShowS
$cshowsPrec :: Int -> Exception -> ShowS
Show

instance Base.Exception Exception where

-- | Where to start a stream.
data StreamStart =
    -- | Start from the given time.
    StartTime LocalTime
    -- | Start from the given number of lines back.
    --   You can use @Lines 0@ to start the stream without
    --   looking for previous lines.
  | Lines Int
    -- | Start /at/ the given cursor.
  | AtCursor Cursor
    -- | Start /after/ the given cursor.
  | AfterCursor Cursor

-- | Translate a 'StreamStart' into the arguments required
--   for journalctl.
streamStartArgs :: StreamStart -> [String]
streamStartArgs :: StreamStart -> [String]
streamStartArgs (StartTime LocalTime
t) =
  [ String
"--since", forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %T" LocalTime
t ]
streamStartArgs (Lines Int
n) =
  [ String
"--lines" , forall a. Show a => a -> String
show Int
n ]
streamStartArgs (AtCursor (Cursor Text
t)) =
  [ String
"--cursor", Text -> String
Text.unpack Text
t ]
streamStartArgs (AfterCursor (Cursor Text
t)) =
  [ String
"--after-cursor", Text -> String
Text.unpack Text
t ]

-- | Stream all journal entries starting from the given point.
entryStream
  :: (MonadResource m, MonadThrow m)
  => StreamStart -- ^ Where to start streaming entries.
  -> ConduitT i Entry m () -- ^ Stream of journal entries.
entryStream :: forall (m :: * -> *) i.
(MonadResource m, MonadThrow m) =>
StreamStart -> ConduitT i Entry m ()
entryStream StreamStart
start =
  let args :: [String]
      args :: [String]
args = StreamStart -> [String]
streamStartArgs StreamStart
start forall a. [a] -> [a] -> [a]
++ [ String
"--follow", String
"--output", String
"json" ]
      hdl :: IO Handle
      hdl :: IO Handle
hdl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Maybe Handle
_, Maybe Handle
h, Maybe Handle
_, ProcessHandle
_) -> forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
h)
          forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
System.createProcess
          forall a b. (a -> b) -> a -> b
$ (String -> [String] -> CreateProcess
System.proc String
"journalctl" [String]
args)
              { std_out :: StdStream
System.std_out = StdStream
System.CreatePipe
                }
  in  forall (m :: * -> *) i.
MonadResource m =>
IO Handle -> ConduitT i ByteString m ()
Conduit.sourceIOHandle IO Handle
hdl
        forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) seq.
(Monad m, IsSequence seq, Element seq ~ Word8) =>
ConduitT seq seq m ()
Conduit.linesUnboundedAscii
        forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
Conduit.mapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
JSONError) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecodeStrict)