hsrelp (empty) → 0.1.0.0

raw patch · 4 files changed

+206/−0 lines, 4 filesdep +attoparsecdep +basedep +bytestringsetup-changed

Dependencies added: attoparsec, base, bytestring, network, utf8-string

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• hsrelp.cabal +34/−0
• src/Network/RELP/Server.hs +140/−0

@@ -0,0 +1,30 @@+Copyright (c) 2016, Denis Afonin++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 Denis Afonin 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.

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

@@ -0,0 +1,34 @@+name:                hsrelp+version:             0.1.0.0+synopsis:            RELP (Reliable Event Logging Protocol) server implementation+description:         +  The specification of the RELP protocol:+  <http://www.rsyslog.com/doc/relp.html>++homepage:            https://github.com/verrens/hsrelp+bug-reports:         https://github.com/verrens/hsrelp/issues+license:             BSD3+license-file:        LICENSE+author:              Denis Afonin+maintainer:          verrens@yandex.ru+-- copyright:           +category:            Network+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  -- other-modules:       +  -- other-extensions:    +  build-depends:    base >=4.8 && <4.9,+                    network,+                    bytestring,+                    utf8-string,+                    attoparsec+  hs-source-dirs:   src+  default-language: Haskell2010+  exposed-modules:  Network.RELP.Server++Source-repository head+  Type:     git+  Location: https://github.com/verrens/hsrelp

@@ -0,0 +1,140 @@+-- | RELP (Reliable Event Logging Protocol) simple server+{-# LANGUAGE OverloadedStrings #-}+module Network.RELP.Server+  (+    -- * Running a standalone RELP server+    RelpMessageHandler+  , runRelpServer+  )+  where++import Prelude hiding (getContents, take)+import Network.Socket hiding (send, recv)+import Network.Socket.ByteString.Lazy+import Control.Concurrent (forkIO)+import Data.Attoparsec.ByteString+import qualified Data.Attoparsec.ByteString.Lazy as LBP+import qualified Data.ByteString.Lazy.Char8 as B8+import qualified Data.ByteString as B+import Data.ByteString (ByteString)+import Data.ByteString.UTF8 (toString)+import Data.Char+import Data.List (lookup)+import Control.Applicative+import Control.Monad++-- | Message handler callback.+type RelpMessageHandler =+  SockAddr -- ^ Client connection address+  -> ByteString -- ^ Log message+  -> IO Bool -- ^ Reject message (reply error RSP) if False++++data RelpCommand = RelpRSP | RelpOPEN | RelpSYSLOG | RelpCLOSE+  | RelpCommand ByteString+  deriving (Show, Eq)++data RelpMessage = RelpMessage+  { relpTxnr :: Int+  , relpCommand :: RelpCommand+  , relpData :: ByteString+  } deriving (Show, Eq)++type RelpOffers = [(ByteString, ByteString)]++-- | Provides a simple RELP server.+runRelpServer :: PortNumber -- ^ Port to listen on+  -> RelpMessageHandler -- ^ Message handler+  -> IO () -- ^ Never returns+runRelpServer port cb = withSocketsDo $ do+  sock <- socket AF_INET Stream defaultProtocol+  setSocketOption sock ReuseAddr 1+  bindSocket sock (SockAddrInet port iNADDR_ANY)+  listen sock 3+  handleConnection sock+  sClose sock+  where++  relpRsp :: Socket -> RelpMessage -> String -> IO ()+  relpRsp sock msg reply = sendAll sock mkReply+    -- putStrLn $ prettyHex $ B8.toStrict mkReply+    where+    mkReply = B8.pack $ (show $ relpTxnr msg) ++ " rsp "+      ++ (show $ length reply) ++ " " ++ reply ++ "\n"++  relpAck :: Socket -> RelpMessage -> IO ()+  relpAck sock msg = relpRsp sock msg "200 OK"++  relpNAck :: Socket -> RelpMessage -> String -> IO ()+  relpNAck sock msg err = relpRsp sock msg $ "500 " ++ err++  relpParser :: Parser RelpMessage+  relpParser = do+    txnr <- decimal <* space+    command <- parseCommand <* space+    datalen <- decimal <* space+    content <- take (datalen + 1) -- <* trailer+    return $ RelpMessage txnr command content+    where+    decimal :: Integral a => Parser a+    decimal = B.foldl' step 0 `fmap` takeWhile1 isDecimal where+      step a c = a * 10 + fromIntegral (c - 48)+      isDecimal c = c >= 48 && c <= 57+    space = word8 32+    trailer = word8 10+    parseCommand =+      string "syslog" *> return RelpSYSLOG+      <|> string "close" *> return RelpCLOSE+      <|> string "open" *> return RelpOPEN+      <|> string "rsp" *> return RelpRSP+      <|> RelpCommand <$> takeWhile1 (/= 32)++  relpOffersParser :: Parser RelpOffers +  relpOffersParser = many' $ pair <* word8 sep+    where+    sep = 10 -- \n+    der = 61 -- '='+    pair = liftA2 (,)+      (takeWhile1 (\c-> c /= der && c /= sep))+      (word8 der *> takeWhile1 (/= sep) <|> return "")++  -- just shortcuts+  parse_ err ok p = either err ok . parseOnly p+  parseLazy_ err ok p = either err ok . LBP.eitherResult . LBP.parse p+++  handleConnection sock = do+    accept sock >>= forkIO . handleMessage+    handleConnection sock++  handleMessage s@(sockh, srcAddr) = do+    status <- getContents sockh >>= processMessage s+    if status then handleMessage s+      else close sockh++  processMessage (sock, srcAddr) = parseLazy_ err process relpParser+    where+    err e = putStrLn ("ERROR: parser: " ++ show e) >> return False++    process msg@RelpMessage{ relpCommand = RelpOPEN } = do+      let offers = parse_ (const []) id relpOffersParser $ relpData msg+      -- NOTE only version 0 supported!+      let versionValid = maybe False (== "0") $ lookup "relp_version" offers+      -- TODO FIXME check commands offer?+      if versionValid then do+          relpRsp sock msg $ "200 OK "+            ++ "relp_version=0\nrelp_software=hsRELP\ncommands="+            ++ (maybe "syslog" toString $ lookup "commands" offers)+          return True+        else relpNAck sock msg "unsupported RELP version" >> return False++    process msg@RelpMessage{ relpCommand = RelpSYSLOG } = do+      status <- cb srcAddr (relpData msg)+      if status then relpAck sock msg else relpNAck sock msg "rejected"+      return status++    process msg = do+      putStrLn ("ERROR: strange message command: " ++ show msg)+      relpNAck sock msg "unexpected message command"+      return False