Initial commit

.gitignore

@@ -0,0 +1,28 @@
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*
+stack.yaml
+*.swm
+*.swo
+*.swp
+test_results/**
+examples/validate

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for syslog
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2020, Andrew Martin
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Andrew Martin nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

examples/validate.hs

@@ -0,0 +1,35 @@
+{-# language BangPatterns #-}
+{-# language LambdaCase #-}
+
+import Data.Primitive (ByteArray)
+import Data.ByteString (ByteString)
+import Data.Bool (bool)
+import Control.Exception
+import System.IO.Error (isEOFError)
+import Foreign.C.Types (CChar)
+
+import qualified Data.Primitive as PM
+import qualified Data.Primitive.Ptr as PM
+import qualified Data.ByteString as ByteString
+import qualified Data.Bytes as Bytes
+import qualified Syslog.Bsd as Bsd
+
+main :: IO ()
+main = do
+  let go !ix = catchJust (bool Nothing (Just ()) . isEOFError) (Just <$> ByteString.getLine) (\() -> pure Nothing) >>= \case
+        Nothing -> pure ()
+        Just b0 -> do
+          b1 <- b2b b0
+          case Bsd.decode (Bytes.fromByteArray b1) of
+            Nothing -> fail $ "Decode failure on line " ++ show ix
+            Just _ -> go (ix + 1)
+  go 0
+
+b2b :: ByteString -> IO ByteArray
+b2b !b = ByteString.useAsCStringLen b $ \(ptr,len) -> do
+  arr <- PM.newByteArray len
+  PM.copyPtrToMutablePrimArray (castArray arr) 0 ptr len
+  PM.unsafeFreezeByteArray arr
+
+castArray :: PM.MutableByteArray s -> PM.MutablePrimArray s CChar
+castArray (PM.MutableByteArray x) = PM.MutablePrimArray x

src/Syslog/Bsd.hs

@@ -0,0 +1,96 @@
+{-# language NamedFieldPuns #-}
+
+module Syslog.Bsd
+  ( Message(..)
+  , decode
+  ) where
+
+import Control.Monad (when)
+import Data.Bytes.Types (Bytes(Bytes))
+import Data.Bytes.Parser (Parser)
+import Data.Word (Word8,Word32)
+
+import qualified Chronos
+import qualified Data.Bytes as Bytes
+import qualified Data.Maybe.Unpacked.Numeric.Word32 as Word32
+import qualified Data.Bytes.Parser as Parser
+import qualified Data.Bytes.Parser.Latin as Latin
+import qualified Data.Bytes.Parser.Unsafe as Unsafe
+
+data Message = Message
+  { priority :: !Word32
+  , month :: !Chronos.Month
+  , day :: !Chronos.DayOfMonth
+  , hour :: !Word8
+  , minute :: !Word8
+  , second :: !Word8
+  , host :: {-# UNPACK #-} !Bytes
+  , process :: {-# UNPACK #-} !Bytes
+  , processId :: {-# UNPACK #-} !Word32.Maybe
+  , message :: {-# UNPACK #-} !Bytes
+  }
+
+decode :: Bytes -> Maybe Message
+decode = Parser.parseBytesMaybe parser
+
+parser :: Parser () s Message
+parser = do
+  Latin.char () '<'
+  priority <- Latin.decWord32 ()
+  Latin.char () '>'
+  monthBytes <- Parser.take () 3
+  month <- case resolveMonth monthBytes of
+    Chronos.Month 12 -> Parser.fail ()
+    m -> pure m
+  -- There might be two spaces here since single-digit days get
+  -- padded with a space.
+  Latin.skipChar1 () ' '
+  dayRaw <- Latin.decWord8 ()
+  day <- if dayRaw < 32
+    then pure (Chronos.DayOfMonth (fromIntegral dayRaw))
+    else Parser.fail ()
+  Latin.char () ' '
+  hour <- Latin.decWord8 ()
+  when (hour > 23) (Parser.fail ())
+  Latin.char () ':'
+  minute <- Latin.decWord8 ()
+  when (minute > 59) (Parser.fail ())
+  Latin.char () ':'
+  second <- Latin.decWord8 ()
+  when (second > 59) (Parser.fail ())
+  Latin.char () ' '
+  host <- Latin.takeTrailedBy () ' '
+  -- TODO: This should actually be a takeWhile1.
+  processStart <- Unsafe.cursor
+  hasPid <- Parser.skipTrailedBy2 () 0x3A 0x5B
+  processEndSucc <- Unsafe.cursor
+  arr <- Unsafe.expose
+  let process = Bytes arr processStart ((processEndSucc - 1) - processStart)
+  case hasPid of
+    False -> do
+      Latin.skipChar ' '
+      message <- Parser.remaining
+      pure Message{priority,month,day,hour,minute,second,host,process,processId=Word32.nothing,message}
+    True -> do
+      pid <- Latin.decWord32 ()
+      Latin.char2 () ']' ':'
+      Latin.skipChar ' '
+      message <- Parser.remaining
+      pure Message{priority,month,day,hour,minute,second,host,process,processId=Word32.just pid,message}
+
+-- Precondition: length of bytes is 3
+resolveMonth :: Bytes -> Chronos.Month
+resolveMonth b
+  | Bytes.equalsLatin3 'A' 'p' 'r' b = Chronos.april
+  | Bytes.equalsLatin3 'A' 'u' 'g' b = Chronos.august
+  | Bytes.equalsLatin3 'D' 'e' 'c' b = Chronos.december
+  | Bytes.equalsLatin3 'F' 'e' 'b' b = Chronos.february
+  | Bytes.equalsLatin3 'J' 'a' 'n' b = Chronos.january
+  | Bytes.equalsLatin3 'J' 'u' 'l' b = Chronos.july
+  | Bytes.equalsLatin3 'J' 'u' 'n' b = Chronos.june
+  | Bytes.equalsLatin3 'M' 'a' 'r' b = Chronos.march
+  | Bytes.equalsLatin3 'M' 'a' 'y' b = Chronos.may
+  | Bytes.equalsLatin3 'N' 'o' 'v' b = Chronos.november
+  | Bytes.equalsLatin3 'O' 'c' 't' b = Chronos.october
+  | Bytes.equalsLatin3 'S' 'e' 'p' b = Chronos.september
+  | otherwise = Chronos.Month 12

syslog.cabal

@@ -0,0 +1,29 @@
+cabal-version: 2.4
+name: syslog
+version: 0.1.0.0
+synopsis: Decode RFC 3164 and RFC 5424 syslog message formats
+description:
+  Decode syslog messages that were formatted using RFC 3164 (BSD-syslog) or
+  RFC 5424 (IETF-syslog).
+bug-reports: https://github.com/layer-3-communications/syslog
+license: BSD-3-Clause
+license-file: LICENSE
+author: Andrew Martin
+maintainer: [email protected]
+copyright: 2020 Andrew Martin
+category: Data
+build-type: Simple
+extra-source-files: CHANGELOG.md
+
+library
+  exposed-modules:
+    Syslog.Bsd
+  build-depends:
+    , base >=4.12 && <5
+    , unpacked-maybe-numeric>=0.1.1
+    , chronos >=1.1
+    , byteslice >=0.2.2
+    , bytesmith >=0.3.6
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -O2 -Wall