{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnboxedTuples #-}

{- | Parse RFC 5424 messages. For example (from the spec itself):

> <165>1 2003-10-11T22:14:15.003Z mymachine.example.com
>   evntslog - ID47 [exampleSDID@32473 iut="3" eventSource="Application"
>   eventID="1011"] BOMAn application event log entry...
-}
module Syslog.Ietf
  ( -- * Types
    Message (..)
  , Element (..)
  , Parameter (..)

    -- * Full Decode
  , decode
  , parser
  ) where

import Prelude hiding (id)

import Control.Monad (when)
import Control.Monad.ST.Run (runIntByteArrayST)
import Data.Bytes.Parser (Parser)
import Data.Bytes.Types (Bytes (Bytes))
import Data.Int (Int64)
import Data.Primitive (SmallArray)
import Data.Word (Word32, Word64, Word8)

import qualified Chronos
import qualified Data.Bytes.Parser as Parser
import qualified Data.Bytes.Parser.Latin as Latin
import qualified Data.Bytes.Parser.Unsafe as Unsafe
import qualified Data.Bytes.Types
import qualified Data.Maybe.Unpacked.Numeric.Word32 as Word32
import qualified Data.Primitive as PM
import qualified Data.Primitive.Contiguous as C

data Message = Message
  { Message -> Word32
priority :: !Word32
  , Message -> Word32
version :: !Word32
  , Message -> OffsetDatetime
timestamp :: !Chronos.OffsetDatetime
  , Message -> Bytes
hostname :: {-# UNPACK #-} !Bytes
  , Message -> Bytes
application :: {-# UNPACK #-} !Bytes
  , Message -> Maybe
processId :: {-# UNPACK #-} !Word32.Maybe
  , Message -> Bytes
messageType :: {-# UNPACK #-} !Bytes
  -- ^ A missing message type, represented as a hyphen in IETF-flavor
  -- syslog, is represented by the empty byte sequence.
  , Message -> SmallArray Element
structuredData :: {-# UNPACK #-} !(SmallArray Element)
  , Message -> Bytes
message :: {-# UNPACK #-} !Bytes
  }
  deriving (Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Message -> ShowS
showsPrec :: Int -> Message -> ShowS
$cshow :: Message -> String
show :: Message -> String
$cshowList :: [Message] -> ShowS
showList :: [Message] -> ShowS
Show)

data Element = Element
  { Element -> Bytes
id :: {-# UNPACK #-} !Bytes
  , Element -> SmallArray Parameter
parameters :: {-# UNPACK #-} !(SmallArray Parameter)
  }
  deriving (Int -> Element -> ShowS
[Element] -> ShowS
Element -> String
(Int -> Element -> ShowS)
-> (Element -> String) -> ([Element] -> ShowS) -> Show Element
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Element -> ShowS
showsPrec :: Int -> Element -> ShowS
$cshow :: Element -> String
show :: Element -> String
$cshowList :: [Element] -> ShowS
showList :: [Element] -> ShowS
Show)

data Parameter = Parameter
  { Parameter -> Bytes
name :: {-# UNPACK #-} !Bytes
  , Parameter -> Bytes
value :: {-# UNPACK #-} !Bytes
  }
  deriving (Int -> Parameter -> ShowS
[Parameter] -> ShowS
Parameter -> String
(Int -> Parameter -> ShowS)
-> (Parameter -> String)
-> ([Parameter] -> ShowS)
-> Show Parameter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Parameter -> ShowS
showsPrec :: Int -> Parameter -> ShowS
$cshow :: Parameter -> String
show :: Parameter -> String
$cshowList :: [Parameter] -> ShowS
showList :: [Parameter] -> ShowS
Show)

-- | Run the RFC 5424 parser. See 'parser'.
decode :: Bytes -> Maybe Message
decode :: Bytes -> Maybe Message
decode = (forall s. Parser () s Message) -> Bytes -> Maybe Message
forall e a. (forall s. Parser e s a) -> Bytes -> Maybe a
Parser.parseBytesMaybe Parser () s Message
forall s. Parser () s Message
parser

-- | Parse a RFC 5424 message.
parser :: Parser () s Message
parser :: forall s. Parser () s Message
parser = do
  Word32
priority <- () -> Parser () s Word32
forall e s. e -> Parser e s Word32
takePriority ()
  Word32
version <- () -> Parser () s Word32
forall e s. e -> Parser e s Word32
Latin.decWord32 ()
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
' '
  OffsetDatetime
timestamp <- Parser () s OffsetDatetime
forall s. Parser () s OffsetDatetime
takeTimestamp
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
' '
  Bytes
hostname <- () -> Parser () s Bytes
forall e s. e -> Parser e s Bytes
takeKeywordAndSpace ()
  Bytes
application <- () -> Parser () s Bytes
forall e s. e -> Parser e s Bytes
takeKeywordAndSpace ()
  Maybe
processId <-
    (Char -> Bool) -> Parser () s Bool
forall e s. (Char -> Bool) -> Parser e s Bool
Latin.trySatisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Parser () s Bool
-> (Bool -> Parser () s Maybe) -> Parser () s Maybe
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> do
        () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
' '
        Maybe -> Parser () s Maybe
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe
Word32.nothing
      Bool
False ->
        Parser () s Maybe -> Parser () s Maybe -> Parser () s Maybe
forall x s a e. Parser x s a -> Parser e s a -> Parser e s a
Parser.orElse
          -- This is a hack to smooth over a mistake. The process id
          -- can actually be things other than a decimal-encoded number.
          -- Sometimes it is 128-bit or 256-bit hexadecimal number. In
          -- these cases, we just ignore it.
          ( do
              Word32
w <- () -> Parser () s Word32
forall e s. e -> Parser e s Word32
Latin.decWord32 ()
              () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
' '
              Maybe -> Parser () s Maybe
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Maybe
Word32.just Word32
w)
          )
          ( do
              (Char -> Bool) -> Parser () s ()
forall e s. (Char -> Bool) -> Parser e s ()
Latin.skipWhile
                (\Char
c -> (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f') Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F') Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'))
              () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
' '
              Maybe -> Parser () s Maybe
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe
Word32.nothing
          )
  Bytes
messageType <-
    (Char -> Bool) -> Parser () s Bool
forall e s. (Char -> Bool) -> Parser e s Bool
Latin.trySatisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Parser () s Bool
-> (Bool -> Parser () s Bytes) -> Parser () s Bytes
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> do
        () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
' '
        ByteArray
array <- Parser () s ByteArray
forall e s. Parser e s ByteArray
Unsafe.expose
        Bytes -> Parser () s Bytes
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bytes {ByteArray
array :: ByteArray
$sel:array:Bytes :: ByteArray
array, $sel:offset:Bytes :: Int
offset = Int
0, $sel:length:Bytes :: Int
length = Int
0}
      Bool
False -> () -> Parser () s Bytes
forall e s. e -> Parser e s Bytes
takeKeywordAndSpace ()
  SmallArray Element
structuredData <-
    (Char -> Bool) -> Parser () s Bool
forall e s. (Char -> Bool) -> Parser e s Bool
Latin.trySatisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Parser () s Bool
-> (Bool -> Parser () s (SmallArray Element))
-> Parser () s (SmallArray Element)
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> SmallArray Element -> Parser () s (SmallArray Element)
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray Element
forall a. Monoid a => a
mempty
      Bool
False -> Parser () s (SmallArray Element)
forall s. Parser () s (SmallArray Element)
takeStructuredData
  Bytes
message <-
    Parser () s Bool
forall e s. Parser e s Bool
Parser.isEndOfInput Parser () s Bool
-> (Bool -> Parser () s Bytes) -> Parser () s Bytes
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> do
        ByteArray
arr <- Parser () s ByteArray
forall e s. Parser e s ByteArray
Unsafe.expose
        Bytes -> Parser () s Bytes
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bytes {$sel:array:Bytes :: ByteArray
array = ByteArray
arr, $sel:offset:Bytes :: Int
offset = Int
0, $sel:length:Bytes :: Int
length = Int
0}
      Bool
False -> do
        () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
' '
        Parser () s Bytes
forall e s. Parser e s Bytes
Parser.remaining
  Message -> Parser () s Message
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Message
      { Word32
$sel:priority:Message :: Word32
priority :: Word32
priority
      , Word32
$sel:version:Message :: Word32
version :: Word32
version
      , OffsetDatetime
$sel:timestamp:Message :: OffsetDatetime
timestamp :: OffsetDatetime
timestamp
      , Bytes
$sel:hostname:Message :: Bytes
hostname :: Bytes
hostname
      , Bytes
$sel:application:Message :: Bytes
application :: Bytes
application
      , Maybe
$sel:processId:Message :: Maybe
processId :: Maybe
processId
      , Bytes
$sel:messageType:Message :: Bytes
messageType :: Bytes
messageType
      , SmallArray Element
$sel:structuredData:Message :: SmallArray Element
structuredData :: SmallArray Element
structuredData
      , Bytes
$sel:message:Message :: Bytes
message :: Bytes
message
      }

takeStructuredData :: Parser () s (SmallArray Element)
takeStructuredData :: forall s. Parser () s (SmallArray Element)
takeStructuredData = Int -> [Element] -> Parser () s (SmallArray Element)
forall s. Int -> [Element] -> Parser () s (SmallArray Element)
go Int
0 []
 where
  go :: Int -> [Element] -> Parser () s (SmallArray Element)
  go :: forall s. Int -> [Element] -> Parser () s (SmallArray Element)
go !Int
n ![Element]
acc =
    (Char -> Bool) -> Parser () s Bool
forall e s. (Char -> Bool) -> Parser e s Bool
Latin.trySatisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[') Parser () s Bool
-> (Bool -> Parser () s (SmallArray Element))
-> Parser () s (SmallArray Element)
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> do
        Bytes
id <- Parser () s Bytes
forall e s. Parser e s Bytes
takeKeyword
        SmallArray Parameter
parameters <- Parser () s (SmallArray Parameter)
forall s. Parser () s (SmallArray Parameter)
takeParameters
        let !e :: Element
e = Element {Bytes
$sel:id:Element :: Bytes
id :: Bytes
id, SmallArray Parameter
$sel:parameters:Element :: SmallArray Parameter
parameters :: SmallArray Parameter
parameters}
        Int -> [Element] -> Parser () s (SmallArray Element)
forall s. Int -> [Element] -> Parser () s (SmallArray Element)
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Element
e Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
acc)
      Bool
False -> SmallArray Element -> Parser () s (SmallArray Element)
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SmallArray Element -> Parser () s (SmallArray Element))
-> SmallArray Element -> Parser () s (SmallArray Element)
forall a b. (a -> b) -> a -> b
$! Int -> [Element] -> SmallArray Element
forall (arr :: * -> *) a.
(Contiguous arr, Element arr a) =>
Int -> [a] -> arr a
C.unsafeFromListReverseN Int
n [Element]
acc

takeParameters :: Parser () s (SmallArray Parameter)
takeParameters :: forall s. Parser () s (SmallArray Parameter)
takeParameters = Int -> [Parameter] -> Parser () s (SmallArray Parameter)
forall s. Int -> [Parameter] -> Parser () s (SmallArray Parameter)
go Int
0 []
 where
  go :: Int -> [Parameter] -> Parser () s (SmallArray Parameter)
  go :: forall s. Int -> [Parameter] -> Parser () s (SmallArray Parameter)
go !Int
n ![Parameter]
acc =
    (Char -> Bool) -> Parser () s Bool
forall e s. (Char -> Bool) -> Parser e s Bool
Latin.trySatisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
']') Parser () s Bool
-> (Bool -> Parser () s (SmallArray Parameter))
-> Parser () s (SmallArray Parameter)
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> SmallArray Parameter -> Parser () s (SmallArray Parameter)
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SmallArray Parameter -> Parser () s (SmallArray Parameter))
-> SmallArray Parameter -> Parser () s (SmallArray Parameter)
forall a b. (a -> b) -> a -> b
$! Int -> [Parameter] -> SmallArray Parameter
forall (arr :: * -> *) a.
(Contiguous arr, Element arr a) =>
Int -> [a] -> arr a
C.unsafeFromListReverseN Int
n [Parameter]
acc
      Bool
False -> do
        () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
' '
        Bytes
name <- Parser () s Bytes
forall s. Parser () s Bytes
takeKeywordAndEquals
        Bytes
value <- Parser () s Bytes
forall s. Parser () s Bytes
takeParameterValue
        let !p :: Parameter
p = Parameter {Bytes
$sel:name:Parameter :: Bytes
name :: Bytes
name, Bytes
$sel:value:Parameter :: Bytes
value :: Bytes
value}
        Int -> [Parameter] -> Parser () s (SmallArray Parameter)
forall s. Int -> [Parameter] -> Parser () s (SmallArray Parameter)
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Parameter
p Parameter -> [Parameter] -> [Parameter]
forall a. a -> [a] -> [a]
: [Parameter]
acc)

-- This handles escape sequences correctly.
takeParameterValue :: Parser () s Bytes
takeParameterValue :: forall s. Parser () s Bytes
takeParameterValue = do
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
'"'
  Int
start <- Parser () s Int
forall e s. Parser e s Int
Unsafe.cursor
  () -> Word8 -> Word8 -> Parser () s Bool
forall e s. e -> Word8 -> Word8 -> Parser e s Bool
Parser.skipTrailedBy2 () Word8
0x22 Word8
0x5C Parser () s Bool
-> (Bool -> Parser () s Bytes) -> Parser () s Bytes
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> do
      -- no backslashes, went all the way to a double quote
      Int
end <- Parser () s Int
forall e s. Parser e s Int
Unsafe.cursor
      let !len :: Int
len = (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      ByteArray
arr <- Parser () s ByteArray
forall e s. Parser e s ByteArray
Unsafe.expose
      Bytes -> Parser () s Bytes
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bytes {$sel:array:Bytes :: ByteArray
array = ByteArray
arr, $sel:offset:Bytes :: Int
offset = Int
start, $sel:length:Bytes :: Int
length = Int
len}
    Bool
True -> do
      -- found a backslash, we will need to escape quotes
      Char
c <- () -> Parser () s Char
forall e s. e -> Parser e s Char
Latin.any ()
      if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
        then () -> Parser () s ()
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else () -> Parser () s ()
forall e s a. e -> Parser e s a
Parser.fail ()
      Parser () s ()
forall s. Parser () s ()
consumeThroughUnescapedQuote
      Int
end <- Parser () s Int
forall e s. Parser e s Int
Unsafe.cursor
      let !len :: Int
len = (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      ByteArray
arr <- Parser () s ByteArray
forall e s. Parser e s ByteArray
Unsafe.expose
      let bs :: Bytes
bs = Bytes {$sel:array:Bytes :: ByteArray
array = ByteArray
arr, $sel:offset:Bytes :: Int
offset = Int
start, $sel:length:Bytes :: Int
length = Int
len}
      Bytes -> Parser () s Bytes
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Parser () s Bytes) -> Bytes -> Parser () s Bytes
forall a b. (a -> b) -> a -> b
$! Bytes -> Bytes
removeEscapeSequences Bytes
bs

consumeThroughUnescapedQuote :: Parser () s ()
consumeThroughUnescapedQuote :: forall s. Parser () s ()
consumeThroughUnescapedQuote =
  () -> Word8 -> Word8 -> Parser () s Bool
forall e s. e -> Word8 -> Word8 -> Parser e s Bool
Parser.skipTrailedBy2 () Word8
0x22 Word8
0x5C Parser () s Bool -> (Bool -> Parser () s ()) -> Parser () s ()
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> () -> Parser () s ()
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool
True -> do
      Char
c <- () -> Parser () s Char
forall e s. e -> Parser e s Char
Latin.any ()
      if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
        then Parser () s ()
forall s. Parser () s ()
consumeThroughUnescapedQuote
        else () -> Parser () s ()
forall e s a. e -> Parser e s a
Parser.fail ()

{- | Precondition: Every backslash is followed by a double quote or by
a backslash.
-}
removeEscapeSequences :: Bytes -> Bytes
removeEscapeSequences :: Bytes -> Bytes
removeEscapeSequences Bytes {ByteArray
$sel:array:Bytes :: Bytes -> ByteArray
array :: ByteArray
array, $sel:offset:Bytes :: Bytes -> Int
offset = Int
off0, $sel:length:Bytes :: Bytes -> Int
length = Int
len0} =
  let (Int
lengthX, ByteArray
arrayX) = (forall s. ST s (Int, ByteArray)) -> (Int, ByteArray)
runIntByteArrayST ((forall s. ST s (Int, ByteArray)) -> (Int, ByteArray))
-> (forall s. ST s (Int, ByteArray)) -> (Int, ByteArray)
forall a b. (a -> b) -> a -> b
$ do
        MutableByteArray (PrimState (ST s))
dst <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PM.newByteArray Int
len0
        let go :: Int -> Int -> t -> ST s Int
go !Int
ixSrc !Int
ixDst !t
len = case t
len of
              t
0 -> Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
ixDst
              t
_ -> do
                let Word8
w :: Word8 = ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
PM.indexByteArray ByteArray
array Int
ixSrc
                case Word8
w of
                  Word8
0x5C -> case ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
PM.indexByteArray ByteArray
array (Int
ixSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) :: Word8 of
                    Word8
0x5C -> do
                      MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PM.writeByteArray MutableByteArray (PrimState (ST s))
dst Int
ixDst (Word8
0x5C :: Word8)
                      Int -> Int -> t -> ST s Int
go (Int
ixSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Int
ixDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (t
len t -> t -> t
forall a. Num a => a -> a -> a
- t
2)
                    Word8
0x22 -> do
                      MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PM.writeByteArray MutableByteArray (PrimState (ST s))
dst Int
ixDst (Word8
0x22 :: Word8)
                      Int -> Int -> t -> ST s Int
go (Int
ixSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Int
ixDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (t
len t -> t -> t
forall a. Num a => a -> a -> a
- t
2)
                    Word8
_ -> String -> ST s Int
forall a. String -> a
errorWithoutStackTrace String
"Syslog.Ietf.removeEscapeSequences: invariant violated"
                  Word8
_ -> do
                    MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PM.writeByteArray MutableByteArray (PrimState (ST s))
dst Int
ixDst Word8
w
                    Int -> Int -> t -> ST s Int
go (Int
ixSrc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
ixDst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (t
len t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
        Int
lenDst <- Int -> Int -> Int -> ST s Int
forall {t}. (Eq t, Num t) => Int -> Int -> t -> ST s Int
go Int
off0 Int
0 Int
len0
        MutableByteArray (PrimState (ST s)) -> Int -> ST s ()
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> Int -> m ()
PM.shrinkMutableByteArray MutableByteArray (PrimState (ST s))
dst Int
lenDst
        ByteArray
dst' <- MutableByteArray (PrimState (ST s)) -> ST s ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
PM.unsafeFreezeByteArray MutableByteArray (PrimState (ST s))
dst
        (Int, ByteArray) -> ST s (Int, ByteArray)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
lenDst, ByteArray
dst')
   in Bytes {$sel:array:Bytes :: ByteArray
array = ByteArray
arrayX, $sel:length:Bytes :: Int
length = Int
lengthX, $sel:offset:Bytes :: Int
offset = Int
0}

{- | Consume the angle-bracketed priority. RFC 5424 does not allow
a space to follow the priority, so this does not consume a
trailing space.
-}
takePriority :: e -> Parser e s Word32
takePriority :: forall e s. e -> Parser e s Word32
takePriority e
e = do
  e -> Char -> Parser e s ()
forall e s. e -> Char -> Parser e s ()
Latin.char e
e Char
'<'
  Word32
priority <- e -> Parser e s Word32
forall e s. e -> Parser e s Word32
Latin.decWord32 e
e
  e -> Char -> Parser e s ()
forall e s. e -> Char -> Parser e s ()
Latin.char e
e Char
'>'
  Word32 -> Parser e s Word32
forall a. a -> Parser e s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
priority

{- | Consume the keyword and the space that follows it. Returns
the hostname.
-}
takeKeywordAndSpace :: e -> Parser e s Bytes
takeKeywordAndSpace :: forall e s. e -> Parser e s Bytes
takeKeywordAndSpace e
e =
  -- TODO: This should actually use a takeWhile1.
  e -> Char -> Parser e s Bytes
forall e s. e -> Char -> Parser e s Bytes
Latin.takeTrailedBy e
e Char
' '

-- | Consume the keyword. Returns the keyword.
takeKeyword :: Parser e s Bytes
takeKeyword :: forall e s. Parser e s Bytes
takeKeyword =
  -- TODO: Should use takeWhile1
  (Word8 -> Bool) -> Parser e s Bytes
forall e s. (Word8 -> Bool) -> Parser e s Bytes
Parser.takeWhile (\Word8
c -> Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x20)

{- | Consume the keyword and the equals sign that follows it. Returns
the keyword.
-}
takeKeywordAndEquals :: Parser () s Bytes
takeKeywordAndEquals :: forall s. Parser () s Bytes
takeKeywordAndEquals =
  -- TODO: This should actually use a takeWhile1.
  () -> Char -> Parser () s Bytes
forall e s. e -> Char -> Parser e s Bytes
Latin.takeTrailedBy () Char
'='

-- | Consume the timestamp.
takeTimestamp :: Parser () s Chronos.OffsetDatetime
takeTimestamp :: forall s. Parser () s OffsetDatetime
takeTimestamp = do
  Word
year <- () -> Parser () s Word
forall e s. e -> Parser e s Word
Latin.decWord ()
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
'-'
  Word
month' <- () -> Parser () s Word
forall e s. e -> Parser e s Word
Latin.decWord ()
  let !month :: Word
month = Word
month' Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1
  Bool -> Parser () s () -> Parser () s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
month Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
12) (() -> Parser () s ()
forall e s a. e -> Parser e s a
Parser.fail ())
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
'-'
  Word
day <- () -> Parser () s Word
forall e s. e -> Parser e s Word
Latin.decWord ()
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
'T'
  Word
hour <- () -> Parser () s Word
forall e s. e -> Parser e s Word
Latin.decWord ()
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
':'
  Word
minute <- () -> Parser () s Word
forall e s. e -> Parser e s Word
Latin.decWord ()
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
':'
  Word
sec <- () -> Parser () s Word
forall e s. e -> Parser e s Word
Latin.decWord ()
  let date :: Date
date =
        Year -> Month -> DayOfMonth -> Date
Chronos.Date
          (Int -> Year
Chronos.Year (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
year))
          (Int -> Month
Chronos.Month (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
month))
          (Int -> DayOfMonth
Chronos.DayOfMonth (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
day))
  !Word64
nanos <-
    (Char -> Bool) -> Parser () s Bool
forall e s. (Char -> Bool) -> Parser e s Bool
Latin.trySatisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Parser () s Bool
-> (Bool -> Parser () s Word64) -> Parser () s Word64
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> do
        (Int
n, Word64
w) <- Parser () s Word64 -> Parser () s (Int, Word64)
forall e s a. Parser e s a -> Parser e s (Int, a)
Parser.measure (() -> Parser () s Word64
forall e s. e -> Parser e s Word64
Latin.decWord64 ())
        Bool -> Parser () s () -> Parser () s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (() -> Parser () s ()
forall e s a. e -> Parser e s a
Parser.fail ())
        let go :: t -> t -> t
go !t
acc !t
b = case t
b of
              t
0 -> t
acc
              t
_ -> t -> t -> t
go (t
acc t -> t -> t
forall a. Num a => a -> a -> a
* t
10) (t
b t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
            !ns :: Word64
ns = Word64 -> Int -> Word64
forall {t} {t}. (Eq t, Num t, Num t) => t -> t -> t
go Word64
w (Int
9 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
        Word64 -> Parser () s Word64
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
ns
      Bool
False -> Word64 -> Parser () s Word64
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
0
  Int
off <-
    () -> Parser () s Char
forall e s. e -> Parser e s Char
Latin.any () Parser () s Char -> (Char -> Parser () s Int) -> Parser () s Int
forall a b. Parser () s a -> (a -> Parser () s b) -> Parser () s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'Z' -> Int -> Parser () s Int
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
      Char
'+' -> Parser () s Int
forall s. Parser () s Int
parserOffset
      Char
'-' -> do
        !Int
off <- Parser () s Int
forall s. Parser () s Int
parserOffset
        Int -> Parser () s Int
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int
forall a. Num a => a -> a
negate Int
off)
      Char
_ -> () -> Parser () s Int
forall e s a. e -> Parser e s a
Parser.fail ()
  OffsetDatetime -> Parser () s OffsetDatetime
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OffsetDatetime -> Parser () s OffsetDatetime)
-> OffsetDatetime -> Parser () s OffsetDatetime
forall a b. (a -> b) -> a -> b
$!
    Datetime -> Offset -> OffsetDatetime
Chronos.OffsetDatetime
      ( Date -> TimeOfDay -> Datetime
Chronos.Datetime Date
date (TimeOfDay -> Datetime) -> TimeOfDay -> Datetime
forall a b. (a -> b) -> a -> b
$
          Int -> Int -> Int64 -> TimeOfDay
Chronos.TimeOfDay
            (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
hour)
            (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
minute)
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word64 @Int64 (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
sec Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1000000000 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
nanos))
      )
      (Int -> Offset
Chronos.Offset Int
off)

-- Should consume exactly five characters: HH:MM. However, the implementation
-- is more generous.
parserOffset :: Parser () s Int
parserOffset :: forall s. Parser () s Int
parserOffset = do
  Word8
h <- () -> Parser () s Word8
forall e s. e -> Parser e s Word8
Latin.decWord8 ()
  () -> Char -> Parser () s ()
forall e s. e -> Char -> Parser e s ()
Latin.char () Char
':'
  Word8
m <- () -> Parser () s Word8
forall e s. e -> Parser e s Word8
Latin.decWord8 ()
  let !r :: Int
r = ((forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Int Word8
h) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Int Word8
m
  Int -> Parser () s Int
forall a. a -> Parser () s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
r