module Systemd.Journal
(
sendMessage
, sendMessageWith
, sendJournalFields
, JournalFields
, message
, messageId
, priority
, Syslog.Priority(..)
, codeFile
, codeLine
, codeFunc
, errno
, syslogFacility
, syslogIdentifier
, syslogPid
, JournalField
, mkJournalField
, journalField
, openJournal
, Start(..)
, JournalEntry, JournalEntryCursor
, journalEntryFields, journalEntryCursor, journalEntryRealtime
, JournalFlag (..)
, Filter (..)
) where
import Control.Applicative
import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import Data.Bits ((.|.))
import Data.Char (ord, toUpper)
import Data.Data (Data)
import Data.Foldable (for_)
import Data.Hashable (Hashable)
import Data.Int
import Data.List (foldl')
import Data.Monoid (Monoid, mappend, mempty)
import Data.String (IsString (..))
import Data.Typeable (Typeable)
import Data.Word
import Foreign (Ptr, alloca, free, peek, throwIfNeg)
import Foreign.C (CString, peekCString)
import System.Posix.Types (CPid(..))
import Data.Generics.Uniplate.Data ()
import qualified Data.ByteString as BS
import qualified Data.Generics.Uniplate.Operations as Uniplate
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.UUID as UUID
import qualified Data.Vector.Storable as V
import qualified Pipes as Pipes
import qualified Pipes.Safe as Pipes
import qualified System.Posix.Syslog as Syslog
import qualified System.Posix.Types.Iovec as Iovec
foreign import ccall "sd_journal_sendv"
sdJournalSendV :: Ptr Iovec.CIovec -> Int -> IO Int
newtype JournalField = JournalField Text.Text
deriving (Eq, Data, Hashable, Ord, Read, Show, Typeable, Monoid)
instance IsString JournalField where
fromString = JournalField . Text.pack . map toUpper
mkJournalField :: Text.Text -> JournalField
mkJournalField = JournalField . Text.toUpper
journalField :: JournalField -> Text.Text
journalField (JournalField f) = f
type JournalFields = HashMap.HashMap JournalField BS.ByteString
message :: Text.Text -> JournalFields
message = HashMap.singleton (JournalField "MESSAGE") . Text.encodeUtf8
messageId :: UUID.UUID -> JournalFields
messageId =
HashMap.singleton (JournalField "MESSAGE_ID") . Text.encodeUtf8 . Text.pack . UUID.toString
priority :: Syslog.Priority -> JournalFields
priority =
HashMap.singleton (JournalField "PRIORITY") . Text.encodeUtf8 . Text.pack . show . fromEnum
codeFile :: FilePath -> JournalFields
codeFile =
HashMap.singleton (JournalField "CODE_FILE") . Text.encodeUtf8 . Text.pack
codeLine :: Int -> JournalFields
codeLine = HashMap.singleton (JournalField "CODE_LINE") . Text.encodeUtf8 . Text.pack . show
codeFunc :: Text.Text -> JournalFields
codeFunc = HashMap.singleton (JournalField "CODE_FUNC") . Text.encodeUtf8
errno :: Int -> JournalFields
errno = HashMap.singleton (JournalField "ERRNO") . Text.encodeUtf8 . Text.pack . show
syslogFacility :: Syslog.Facility -> JournalFields
syslogFacility =
HashMap.singleton (JournalField "SYSLOG_FACILITY") . Text.encodeUtf8 . Text.pack . show . fromEnum
syslogIdentifier :: Text.Text -> JournalFields
syslogIdentifier =
HashMap.singleton (JournalField "SYSLOG_IDENTIFIER") . Text.encodeUtf8
syslogPid :: CPid -> JournalFields
syslogPid (CPid pid) =
HashMap.singleton (JournalField "SYSLOG_PID") (Text.encodeUtf8 $ Text.pack $ show pid)
sendMessage :: Text.Text -> IO ()
sendMessage = sendJournalFields . message
sendMessageWith :: Text.Text -> JournalFields -> IO ()
sendMessageWith text meta = sendJournalFields $ mappend meta $ message text
sendJournalFields :: JournalFields -> IO ()
sendJournalFields meta = void $
throwIfNeg (("sd_journal_send returned :" ++) . show) $
go id 0 (HashMap.toList meta)
where
go f n [] = V.unsafeWith (V.fromList (f [])) $ \iovecs ->
sdJournalSendV iovecs n
go f n ((k, v) : xs) =
Iovec.unsafeUseAsCIovec (encodeKv k v) $
\messageIovec -> go (f . (++ [messageIovec])) (n + 1) xs
encodeKv :: JournalField -> BS.ByteString -> BS.ByteString
encodeKv (JournalField k) v =
Text.encodeUtf8 k `mappend` BS.singleton (fromIntegral $ ord '=') `mappend` v
foreign import ccall "sd_journal_open"
sdJournalOpen :: Ptr (Ptr JournalEntry) -> Int32 -> IO Int
foreign import ccall "sd_journal_enumerate_data"
sdJournalEnumerateData :: Ptr JournalEntry -> Ptr CString -> Ptr Word64 -> IO Int32
foreign import ccall "sd_journal_next"
sdJournalNext :: Ptr JournalEntry -> IO Int
foreign import ccall "sd_journal_add_match"
sdJournalAddMatch :: Ptr JournalEntry -> Ptr a -> Word64 -> IO Int
foreign import ccall "sd_journal_add_conjunction"
sdJournalAddConjunction :: Ptr JournalEntry -> IO Int
foreign import ccall "sd_journal_add_disjunction"
sdJournalAddDisjunction :: Ptr JournalEntry -> IO Int
foreign import ccall "sd_journal_close"
sdJournalClose :: Ptr JournalEntry -> IO ()
foreign import ccall "sd_journal_get_cursor"
sdJournalGetCursor :: Ptr JournalEntry -> Ptr CString -> IO ()
foreign import ccall "sd_journal_seek_cursor"
sdJournalSeekCursor :: Ptr JournalEntry -> CString -> IO Int32
foreign import ccall "sd_journal_seek_tail"
sdJournalSeekTail :: Ptr JournalEntry -> IO Int32
foreign import ccall "sd_journal_previous_skip"
sdJournalPreviousSkip :: Ptr JournalEntry -> Word64 -> IO Int32
foreign import ccall "sd_journal_wait"
sdJournalWait :: Ptr JournalEntry -> Word64 -> IO Int32
foreign import ccall "sd_journal_set_data_threshold"
sdJournalSetDataThreshold :: Ptr JournalEntry -> Word64 -> IO Int32
foreign import ccall "strerror" c'strerror
:: Int32 -> IO CString
foreign import ccall "sd_journal_get_realtime_usec"
sdJournalGetRealtimeUsec :: Ptr JournalEntry -> Ptr Word64 -> IO Int32
data JournalFlag
= LocalOnly
| RuntimeOnly
| SystemOnly
deriving (Bounded, Enum, Eq, Ord)
type JournalEntryCursor = BS.ByteString
data JournalEntry = JournalEntry
{ journalEntryFields :: JournalFields
, journalEntryCursor :: JournalEntryCursor
, journalEntryRealtime :: Word64
}
deriving (Eq, Show)
data Filter
= Match JournalField BS.ByteString
| And Filter Filter
| Or Filter Filter
deriving (Data, Eq, Show, Typeable)
data Start
= FromStart
| FromEnd
| FromCursor JournalEntryCursor
openJournal
:: Pipes.MonadSafe m
=> [JournalFlag]
-> Start
-> Maybe Filter
-> Maybe Integer
-> Pipes.Producer' JournalEntry m ()
openJournal flags start journalFilter threshold =
Pipes.bracket (liftIO openJournalPtr) (liftIO . sdJournalClose) go
where
openJournalPtr = do
journalPtr <- alloca $ \journalPtrPtr -> do
_ <- throwIfNeg (("sdl_journal_open returned: " ++) . show) $
sdJournalOpen journalPtrPtr encodedJournalFlags
peek journalPtrPtr
for_ journalFilter $ applyFilter journalPtr
case start of
FromStart ->
return ()
FromEnd -> void $ do
throwIfNeg (("sd_journal_seek_tail: " ++) . show) $
sdJournalSeekTail journalPtr
throwIfNeg (("sd_journal_previous_skip" ++) . show) $
sdJournalPreviousSkip journalPtr 1
FromCursor cursor -> void $
BS.useAsCString cursor (sdJournalSeekCursor journalPtr)
_ <- throwIfNeg (("sd_journal_set_data_threshold returned: " ++) . show) .
sdJournalSetDataThreshold journalPtr $ case threshold of
Nothing -> fromIntegral (0 :: Integer)
Just n -> fromIntegral n
return journalPtr
encodedJournalFlags = foldl' (.|.) 0 (map encodeJournalFlag flags)
applyFilter journalPtr =
let cnf (Or a (And b c)) = And (Or a b) (Or a c)
cnf (Or (And a b) c) = And (Or a c) (Or b c)
cnf x = x
addRule (And l r) = addRule l >> sdJournalAddConjunction journalPtr >> addRule r
addRule (Or l r) = addRule l >> sdJournalAddDisjunction journalPtr >> addRule r
addRule (Match k v) = BS.useAsCStringLen (encodeKv k v) $ \(ptr, len) ->
sdJournalAddMatch journalPtr ptr (fromIntegral len)
in addRule . Uniplate.transform cnf
go journalPtr = do
let readField =
alloca $ \dataPtrPtr ->
alloca $ \lengthPtr -> do
ret <- sdJournalEnumerateData journalPtr dataPtrPtr lengthPtr
if ret == 0
then return Nothing
else if ret < 0
then c'strerror (negate ret) >>= peekCString
>>= error . ("sd_journal_enumerate_data: " ++)
else do dataPtr <- peek dataPtrPtr
dataLength <- peek lengthPtr
Just <$> BS.packCStringLen (dataPtr, fromIntegral $ dataLength)
readFields acc = do
field <- readField
case field of
Just f ->
let (fieldName, fieldValue) =
BS.break (== (fromIntegral $ ord '=')) f
in readFields
(HashMap.insert
(JournalField $ Text.decodeUtf8 fieldName)
(BS.tail fieldValue)
acc)
Nothing -> return acc
progressedBy <- liftIO (sdJournalNext journalPtr)
case compare progressedBy 0 of
GT -> do
entry <- liftIO $ JournalEntry
<$> readFields mempty
<*> (alloca $ \cursorStrPtr -> do
sdJournalGetCursor journalPtr cursorStrPtr
cursorCString <- peek cursorStrPtr
BS.packCString cursorCString <* free cursorCString)
<*> (alloca $ \realtimePtr -> do
sdJournalGetRealtimeUsec journalPtr realtimePtr
peek realtimePtr)
Pipes.yield entry
go journalPtr
EQ -> do
liftIO $ sdJournalWait journalPtr (1)
go journalPtr
LT -> error $ "sd_journal_next: " ++ show progressedBy
encodeJournalFlag :: JournalFlag -> Int32
encodeJournalFlag LocalOnly = 1
encodeJournalFlag RuntimeOnly = 2
encodeJournalFlag SystemOnly = 4