diff --git a/hsrelp.cabal b/hsrelp.cabal --- a/hsrelp.cabal +++ b/hsrelp.cabal @@ -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 maintainer: Denis Afonin 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 diff --git a/src/Network/RELP/Server.hs b/src/Network/RELP/Server.hs --- a/src/Network/RELP/Server.hs +++ b/src/Network/RELP/Server.hs @@ -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