hsrelp 0.1.2.1 → 0.1.3.1
raw patch · 2 files changed
+119/−62 lines, 2 filesdep +cryptondep +crypton-x509dep +crypton-x509-storedep ~basedep ~bytestringdep ~network
Dependencies added: crypton, crypton-x509, crypton-x509-store, exceptions, network-simple-tls, tls
Dependency ranges changed: base, bytestring, network
Files
- hsrelp.cabal +17/−7
- src/Network/RELP/Server.hs +102/−55
hsrelp.cabal view
@@ -1,5 +1,6 @@+cabal-version: 3.4 name: hsrelp-version: 0.1.2.1+version: 0.1.3.1 synopsis: RELP (Reliable Event Logging Protocol) server implementation description: The specification of the RELP protocol:@@ -7,24 +8,33 @@ homepage: https://github.com/verrens/hsrelp bug-reports: https://github.com/verrens/hsrelp/issues-license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Denis Afonin <verrens@yandex.ru> maintainer: Denis Afonin <verrens@yandex.ru> category: Network build-type: Simple -- extra-source-files: -cabal-version: >=1.10 +common warnings+ ghc-options: -Wall+ library+ import: warnings -- other-modules: -- other-extensions: - build-depends: base >= 4 && < 5,+ build-depends: base >= 4.18.2 && < 5, attoparsec >= 0.14.4 && < 0.15,- bytestring >= 0.11.5 && < 0.12,- network >= 3.1.4 && < 3.2,+ bytestring >= 0.11.5 && < 0.13,+ utf8-string >= 1.0.2 && < 1.1,+ network >= 3.1.4 && < 3.3,+ exceptions >= 0.10.7 && < 0.11, network-bsd >= 2.8.1 && < 2.9,- utf8-string >= 1.0.2 && < 1.1+ network-simple-tls >= 0.4.2 && < 0.5,+ tls >= 2.1.5 && < 2.2,+ crypton >= 1.0.1 && < 1.1,+ crypton-x509 >= 1.7.7 && < 1.8,+ crypton-x509-store >= 1.6.9 && < 1.7 hs-source-dirs: src default-language: Haskell2010 exposed-modules: Network.RELP.Server
src/Network/RELP/Server.hs view
@@ -1,37 +1,48 @@ -- | RELP (Reliable Event Logging Protocol) simple server {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-} module Network.RELP.Server ( -- * Running a standalone RELP server RelpMessageHandler , runRelpServer+ , runTLSServer, runTLSServer'+ , RelpFlow+ , buildRelpServerHandle ) where import Prelude hiding (getContents, take)-import Network.Socket hiding (send, recv)-import Network.Socket.ByteString.Lazy-import Control.Concurrent (forkIO, forkFinally)-import Data.Attoparsec.ByteString+import Network.Socket (PortNumber, AddrInfo(..),+ AddrInfoFlag(..), SocketType(..), SocketOption(..))+import qualified Network.Socket as S+import Network.Socket.ByteString.Lazy ( getContents, sendAll )+import qualified Data.ByteString as B+import Network.Simple.TCP.TLS+import Network.TLS+import Data.X509.CertificateStore+import Data.Attoparsec.ByteString (parseOnly, string, take,+ takeWhile1, word8, many', Parser) 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.Functor-import Data.List (lookup)-import Control.Applicative-import Control.Monad+import Data.Functor ( ($>), (<&>), void )+import Control.Applicative ( Alternative((<|>)) )+import Control.Monad (forever)+import Control.Monad.IO.Class++import Control.Monad.Catch+import System.IO hiding (getContents) import qualified Control.Exception as E -- | Message handler callback.-type RelpMessageHandler =+type RelpMessageHandler m = Monad m => SockAddr -- ^ Client connection address -> ByteString -- ^ Log message- -> IO Bool -- ^ Reject message (reply error RSP) if False--+ -> m Bool -- ^ Reject message (reply error RSP) if False data RelpCommand = RelpRSP | RelpOPEN | RelpSYSLOG | RelpCLOSE | RelpCommand ByteString@@ -45,23 +56,78 @@ type RelpOffers = [(ByteString, ByteString)] +class RelpFlow a where+ flowRecv :: (MonadMask m, MonadIO m) => a -> m B8.ByteString+ flowSend :: (MonadMask m, MonadIO m) => a -> B8.ByteString -> m ()+ flowClose :: (MonadMask m, MonadIO m) => a -> m () +instance RelpFlow Socket where+ flowRecv = liftIO . getContents+ flowSend s = liftIO . sendAll s+ flowClose = liftIO . S.close++instance RelpFlow Context where+ flowRecv = fmap B8.fromStrict . recvData+ flowSend = sendData+ flowClose = bye+ -- | Provides a simple RELP server.-runRelpServer :: PortNumber -- ^ Port to listen on- -> RelpMessageHandler -- ^ Message handler- -> IO () -- ^ Never returns-runRelpServer port cb = runTCPServer Nothing port handleConnection where- handleConnection sock peer = handleMessage (sock, peer)- handleMessage s@(sockh, srcAddr) = do- status <- getContents sockh >>= processMessage s- if status then handleMessage s else close sockh+runRelpServer :: PortNumber -> RelpMessageHandler IO -> IO ()+runRelpServer portnum = runTCPServer Nothing portnum . buildRelpServerHandle where+ runTCPServer mhost port server = withSocketsDo $ do+ addr <- resolve+ E.bracket (open addr) S.close loop+ where+ resolve = do+ let hints = S.defaultHints {+ addrFlags = [AI_PASSIVE]+ , addrSocketType = Stream+ }+ head <$> S.getAddrInfo (Just hints) mhost (Just $ show port)+ open addr = E.bracketOnError (S.openSocket addr) S.close $ \sock -> do+ S.setSocketOption sock ReuseAddr 1+ S.withFdSocket sock S.setCloseOnExecIfNeeded+ S.bind sock $ addrAddress addr+ S.listen sock 1024+ return sock+ loop sock = forever $ E.bracketOnError (S.accept sock) (S.close . fst)+ $ \(conn, peer) -> void $+ E.finally (server conn peer) (S.gracefulClose conn 5000) - processMessage (sock, srcAddr) = parseLazy_ err process relpParser+-- | Provides a simple TLS RELP server.+runTLSServer' :: (MonadIO m, MonadMask m) => FilePath -> FilePath -> FilePath+ -> ServiceName -> (SockAddr -> ByteString -> m Bool) -> m ()+runTLSServer' fca fcr fky snm cb = liftIO lcrd >>= \cr ->+ liftIO (readCertificateStore fca) >>= \ca ->+ runTLSServer (makeServerParams cr ca) HostAny snm cb where+ lcrd = credentialLoadX509Chain fcr [fca] fky <&> either (error . show) id++-- | Provides a TLS RELP server+runTLSServer :: (MonadMask m, MonadIO m) => ServerParams -> HostPreference+ -> String -> RelpMessageHandler m -> m ()+runTLSServer params hostprefs servicename server = srv where+ srv = listen hostprefs servicename (\(sock, _peer) -> accept params sock open)+ open (ctx, peer) = do+ liftIO (hPutStrLn stderr (" …" <> show peer))+ buildRelpServerHandle server ctx peer++-- | Build relp messages handler.+buildRelpServerHandle :: (MonadIO m, MonadMask m, RelpFlow sock)+ => RelpMessageHandler m -- ^ Message handler+ -> sock -- ^ Server socket+ -> SockAddr -- ^ Client address+ -> m () -- ^ Never returns+buildRelpServerHandle cb = handleMessage where+ handleMessage sock srcAddr = do+ status <- flowRecv sock >>= processMessage sock srcAddr+ if status then handleMessage sock srcAddr else flowClose sock++ processMessage sock srcAddr = parseLazy_ err process relpParser where- err e = putStrLn ("ERROR: parser: " ++ show e) >> return False+ err e = liftIO (hPutStrLn stderr ("ERROR: parser: " ++ show e) >> return False) - process msg@RelpMessage{ relpCommand = RelpOPEN } = do- let offers = parse_ (const []) id relpOffersParser $ relpData msg+ process msg@RelpMessage{ relpCommand = RelpOPEN, relpData = txt } = do+ let offers = parse_ (const []) id relpOffersParser txt -- NOTE only version 0 supported! let versionValid = (Just "0" ==) $ lookup "relp_version" offers -- TODO FIXME check commands offer?@@ -72,37 +138,16 @@ return True else relpNAck sock msg "unsupported RELP version" >> return False - process msg@RelpMessage{ relpCommand = RelpSYSLOG } = do- status <- cb srcAddr (relpData msg)+ process msg@RelpMessage{ relpCommand = RelpSYSLOG, relpData = txt } = do+ status <- cb srcAddr txt if status then relpAck sock msg else relpNAck sock msg "rejected" return status process msg = do- putStrLn ("ERROR: strange message command: " ++ show msg)+ liftIO (hPutStrLn stderr ("ERROR: strange message command: " ++ show msg)) relpNAck sock msg "unexpected message command" return False - runTCPServer mhost port server = withSocketsDo $ do- addr <- resolve- E.bracket (open addr) close loop- where- resolve = do- let hints = defaultHints {- addrFlags = [AI_PASSIVE]- , addrSocketType = Stream- }- head <$> getAddrInfo (Just hints) mhost (Just $ show port)- open addr = E.bracketOnError (openSocket addr) close $ \sock -> do- setSocketOption sock ReuseAddr 1- withFdSocket sock setCloseOnExecIfNeeded- bind sock $ addrAddress addr- listen sock 1024- return sock- loop sock = forever $ E.bracketOnError (accept sock) (close . fst)- $ \(conn, peer) -> void $- forkFinally (server conn peer) (const $ gracefulClose conn 5000)-- relpParser :: Parser RelpMessage relpParser = do txnr <- decimal <* space@@ -116,7 +161,6 @@ step a c = a * 10 + fromIntegral (c - 48) isDecimal c = c >= 48 && c <= 57 space = word8 32- trailer = word8 10 parseCommand = string "syslog" $> RelpSYSLOG <|> string "close" $> RelpCLOSE@@ -133,19 +177,22 @@ (takeWhile1 (\c-> c /= der && c /= sep)) (word8 der *> takeWhile1 (/= sep) <|> return "") -relpRsp :: Socket -> RelpMessage -> String -> IO ()-relpRsp sock msg reply = sendAll sock mkReply+relpRsp :: (MonadIO m, MonadMask m, RelpFlow s) => s -> RelpMessage -> String -> m ()+relpRsp sock msg reply = flowSend 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 :: (MonadIO m, MonadMask m, RelpFlow s) => s -> RelpMessage -> m () relpAck sock msg = relpRsp sock msg "200 OK" -relpNAck :: Socket -> RelpMessage -> String -> IO ()+relpNAck :: (MonadIO m, MonadMask m, RelpFlow s) => s -> RelpMessage -> String -> m () relpNAck sock msg err = relpRsp sock msg $ "500 " ++ err -- just shortcuts+parse_ :: (String -> c) -> (b -> c) -> Parser b -> ByteString -> c parse_ err ok p = either err ok . parseOnly p++parseLazy_ :: (String -> c) -> (b -> c) -> Parser b -> B8.ByteString -> c parseLazy_ err ok p = either err ok . LBP.eitherResult . LBP.parse p