module Network.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
type RelpMessageHandler =
SockAddr
-> ByteString
-> IO Bool
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)]
runRelpServer :: PortNumber
-> RelpMessageHandler
-> IO ()
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
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
let versionValid = maybe False (== "0") $ lookup "relp_version" offers
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
relpParser :: Parser RelpMessage
relpParser = do
txnr <- decimal <* space
command <- parseCommand <* space
datalen <- decimal <* space
content <- take (datalen + 1)
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
der = 61
pair = liftA2 (,)
(takeWhile1 (\c-> c /= der && c /= sep))
(word8 der *> takeWhile1 (/= sep) <|> return "")
relpRsp :: Socket -> RelpMessage -> String -> IO ()
relpRsp sock msg reply = sendAll sock 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
parse_ err ok p = either err ok . parseOnly p
parseLazy_ err ok p = either err ok . LBP.eitherResult . LBP.parse p