-- | 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
import qualified Control.Exception as E
import Control.Concurrent (forkFinally)

-- | 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 (Int -> RelpCommand -> ShowS
[RelpCommand] -> ShowS
RelpCommand -> [Char]
(Int -> RelpCommand -> ShowS)
-> (RelpCommand -> [Char])
-> ([RelpCommand] -> ShowS)
-> Show RelpCommand
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RelpCommand -> ShowS
showsPrec :: Int -> RelpCommand -> ShowS
$cshow :: RelpCommand -> [Char]
show :: RelpCommand -> [Char]
$cshowList :: [RelpCommand] -> ShowS
showList :: [RelpCommand] -> ShowS
Show, RelpCommand -> RelpCommand -> Bool
(RelpCommand -> RelpCommand -> Bool)
-> (RelpCommand -> RelpCommand -> Bool) -> Eq RelpCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RelpCommand -> RelpCommand -> Bool
== :: RelpCommand -> RelpCommand -> Bool
$c/= :: RelpCommand -> RelpCommand -> Bool
/= :: RelpCommand -> RelpCommand -> Bool
Eq)

data RelpMessage = RelpMessage
  { RelpMessage -> Int
relpTxnr :: Int
  , RelpMessage -> RelpCommand
relpCommand :: RelpCommand
  , RelpMessage -> ByteString
relpData :: ByteString
  } deriving (Int -> RelpMessage -> ShowS
[RelpMessage] -> ShowS
RelpMessage -> [Char]
(Int -> RelpMessage -> ShowS)
-> (RelpMessage -> [Char])
-> ([RelpMessage] -> ShowS)
-> Show RelpMessage
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RelpMessage -> ShowS
showsPrec :: Int -> RelpMessage -> ShowS
$cshow :: RelpMessage -> [Char]
show :: RelpMessage -> [Char]
$cshowList :: [RelpMessage] -> ShowS
showList :: [RelpMessage] -> ShowS
Show, RelpMessage -> RelpMessage -> Bool
(RelpMessage -> RelpMessage -> Bool)
-> (RelpMessage -> RelpMessage -> Bool) -> Eq RelpMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RelpMessage -> RelpMessage -> Bool
== :: RelpMessage -> RelpMessage -> Bool
$c/= :: RelpMessage -> RelpMessage -> Bool
/= :: RelpMessage -> RelpMessage -> Bool
Eq)

type RelpOffers = [(ByteString, ByteString)]


-- | Provides a simple RELP server.
runRelpServer :: PortNumber -- ^ Port to listen on
  -> RelpMessageHandler -- ^ Message handler
  -> IO () -- ^ Never returns
runRelpServer :: PortNumber -> RelpMessageHandler -> IO ()
runRelpServer PortNumber
port RelpMessageHandler
cb = Maybe [Char] -> PortNumber -> (Socket -> IO ()) -> IO ()
forall a. Maybe [Char] -> PortNumber -> (Socket -> IO a) -> IO a
runTCPServer Maybe [Char]
forall a. Maybe a
Nothing PortNumber
port Socket -> IO ()
forall {b}. Socket -> IO b
handleConnection where
  handleConnection :: Socket -> IO b
handleConnection Socket
sock = do
    Socket -> IO (Socket, SockAddr)
accept Socket
sock IO (Socket, SockAddr)
-> ((Socket, SockAddr) -> IO ThreadId) -> IO ThreadId
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId)
-> ((Socket, SockAddr) -> IO ())
-> (Socket, SockAddr)
-> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Socket, SockAddr) -> IO ()
handleMessage
    Socket -> IO b
handleConnection Socket
sock

  handleMessage :: (Socket, SockAddr) -> IO ()
handleMessage s :: (Socket, SockAddr)
s@(Socket
sockh, SockAddr
srcAddr) = do
    Bool
status <- Socket -> IO ByteString
getContents Socket
sockh IO ByteString -> (ByteString -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Socket, SockAddr) -> ByteString -> IO Bool
processMessage (Socket, SockAddr)
s
    if Bool
status then (Socket, SockAddr) -> IO ()
handleMessage (Socket, SockAddr)
s
      else Socket -> IO ()
close Socket
sockh

  processMessage :: (Socket, SockAddr) -> ByteString -> IO Bool
processMessage (Socket
sock, SockAddr
srcAddr) = ([Char] -> IO Bool)
-> (RelpMessage -> IO Bool)
-> Parser RelpMessage
-> ByteString
-> IO Bool
forall {c} {b}.
([Char] -> c) -> (b -> c) -> Parser b -> ByteString -> c
parseLazy_ [Char] -> IO Bool
forall {a}. Show a => a -> IO Bool
err RelpMessage -> IO Bool
process Parser RelpMessage
relpParser
    where
    err :: a -> IO Bool
err a
e = [Char] -> IO ()
putStrLn ([Char]
"ERROR: parser: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
e) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    process :: RelpMessage -> IO Bool
process msg :: RelpMessage
msg@RelpMessage{ relpCommand :: RelpMessage -> RelpCommand
relpCommand = RelpCommand
RelpOPEN } = do
      let offers :: [(ByteString, ByteString)]
offers = ([Char] -> [(ByteString, ByteString)])
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> Parser [(ByteString, ByteString)]
-> ByteString
-> [(ByteString, ByteString)]
forall {c} {b}.
([Char] -> c) -> (b -> c) -> Parser b -> ByteString -> c
parse_ ([(ByteString, ByteString)] -> [Char] -> [(ByteString, ByteString)]
forall a b. a -> b -> a
const []) [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> a
id Parser [(ByteString, ByteString)]
relpOffersParser (ByteString -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ RelpMessage -> ByteString
relpData RelpMessage
msg
      -- NOTE only version 0 supported!
      let versionValid :: Bool
versionValid = Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"0") (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"relp_version" [(ByteString, ByteString)]
offers
      -- TODO FIXME check commands offer?
      if Bool
versionValid then do
          Socket -> RelpMessage -> [Char] -> IO ()
relpRsp Socket
sock RelpMessage
msg ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"200 OK "
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"relp_version=0\nrelp_software=hsRELP\ncommands="
            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Char] -> (ByteString -> [Char]) -> Maybe ByteString -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"syslog" ByteString -> [Char]
toString (Maybe ByteString -> [Char]) -> Maybe ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"commands" [(ByteString, ByteString)]
offers)
          Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else Socket -> RelpMessage -> [Char] -> IO ()
relpNAck Socket
sock RelpMessage
msg [Char]
"unsupported RELP version" IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    process msg :: RelpMessage
msg@RelpMessage{ relpCommand :: RelpMessage -> RelpCommand
relpCommand = RelpCommand
RelpSYSLOG } = do
      Bool
status <- RelpMessageHandler
cb SockAddr
srcAddr (RelpMessage -> ByteString
relpData RelpMessage
msg)
      if Bool
status then Socket -> RelpMessage -> IO ()
relpAck Socket
sock RelpMessage
msg else Socket -> RelpMessage -> [Char] -> IO ()
relpNAck Socket
sock RelpMessage
msg [Char]
"rejected"
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
status

    process RelpMessage
msg = do
      [Char] -> IO ()
putStrLn ([Char]
"ERROR: strange message command: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ RelpMessage -> [Char]
forall a. Show a => a -> [Char]
show RelpMessage
msg)
      Socket -> RelpMessage -> [Char] -> IO ()
relpNAck Socket
sock RelpMessage
msg [Char]
"unexpected message command"
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  runTCPServer :: Maybe HostName -> PortNumber -> (Socket -> IO a) -> IO a
  runTCPServer :: forall a. Maybe [Char] -> PortNumber -> (Socket -> IO a) -> IO a
runTCPServer Maybe [Char]
mhost PortNumber
port Socket -> IO a
server = IO a -> IO a
forall a. IO a -> IO a
withSocketsDo (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
      AddrInfo
addr <- IO AddrInfo
resolve
      IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (AddrInfo -> IO Socket
open AddrInfo
addr) Socket -> IO ()
close Socket -> IO a
forall {b}. Socket -> IO b
loop
    where
      resolve :: IO AddrInfo
resolve = do
          let hints :: AddrInfo
hints = AddrInfo
defaultHints {
                  addrFlags = [AI_PASSIVE]
                , addrSocketType = Stream
                }
          [AddrInfo] -> AddrInfo
forall a. HasCallStack => [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe [Char]
mhost ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port)
      open :: AddrInfo -> IO Socket
open AddrInfo
addr = IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (AddrInfo -> IO Socket
openSocket AddrInfo
addr) Socket -> IO ()
close ((Socket -> IO Socket) -> IO Socket)
-> (Socket -> IO Socket) -> IO Socket
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
          Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
          Socket -> (CInt -> IO ()) -> IO ()
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
sock CInt -> IO ()
setCloseOnExecIfNeeded
          Socket -> SockAddr -> IO ()
bind Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addr
          Socket -> Int -> IO ()
listen Socket
sock Int
1024
          Socket -> IO Socket
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
      loop :: Socket -> IO b
loop Socket
sock = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ IO (Socket, SockAddr)
-> ((Socket, SockAddr) -> IO ())
-> ((Socket, SockAddr) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (Socket -> IO (Socket, SockAddr)
accept Socket
sock) (Socket -> IO ()
close (Socket -> IO ())
-> ((Socket, SockAddr) -> Socket) -> (Socket, SockAddr) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst)
          (((Socket, SockAddr) -> IO ()) -> IO ())
-> ((Socket, SockAddr) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Socket
conn, SockAddr
_peer) -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$
              IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Socket -> IO a
server Socket
conn) (IO () -> Either SomeException a -> IO ()
forall a b. a -> b -> a
const (IO () -> Either SomeException a -> IO ())
-> IO () -> Either SomeException a -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> Int -> IO ()
gracefulClose Socket
conn Int
5000)


relpParser :: Parser RelpMessage
relpParser :: Parser RelpMessage
relpParser = do
  Int
txnr <- Parser Int
forall a. Integral a => Parser a
decimal Parser Int -> Parser ByteString Word8 -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Word8
space
  RelpCommand
command <- Parser ByteString RelpCommand
parseCommand Parser ByteString RelpCommand
-> Parser ByteString Word8 -> Parser ByteString RelpCommand
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Word8
space
  Int
datalen <- Parser Int
forall a. Integral a => Parser a
decimal Parser Int -> Parser ByteString Word8 -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Word8
space
  ByteString
content <- Int -> Parser ByteString
take (Int
datalen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) -- <* trailer
  RelpMessage -> Parser RelpMessage
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (RelpMessage -> Parser RelpMessage)
-> RelpMessage -> Parser RelpMessage
forall a b. (a -> b) -> a -> b
$ Int -> RelpCommand -> ByteString -> RelpMessage
RelpMessage Int
txnr RelpCommand
command ByteString
content
  where
  decimal :: Integral a => Parser a
  decimal :: forall a. Integral a => Parser a
decimal = (a -> Word8 -> a) -> a -> ByteString -> a
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' a -> Word8 -> a
forall {a} {a}. (Integral a, Num a) => a -> a -> a
step a
0 (ByteString -> a) -> Parser ByteString -> Parser ByteString a
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Word8 -> Bool) -> Parser ByteString
takeWhile1 Word8 -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
isDecimal where
    step :: a -> a -> a
step a
a a
c = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
c a -> a -> a
forall a. Num a => a -> a -> a
- a
48)
    isDecimal :: a -> Bool
isDecimal a
c = a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
57
  space :: Parser ByteString Word8
space = Word8 -> Parser ByteString Word8
word8 Word8
32
  trailer :: Parser ByteString Word8
trailer = Word8 -> Parser ByteString Word8
word8 Word8
10
  parseCommand :: Parser ByteString RelpCommand
parseCommand =
    ByteString -> Parser ByteString
string ByteString
"syslog" Parser ByteString
-> Parser ByteString RelpCommand -> Parser ByteString RelpCommand
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RelpCommand -> Parser ByteString RelpCommand
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return RelpCommand
RelpSYSLOG
    Parser ByteString RelpCommand
-> Parser ByteString RelpCommand -> Parser ByteString RelpCommand
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"close" Parser ByteString
-> Parser ByteString RelpCommand -> Parser ByteString RelpCommand
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RelpCommand -> Parser ByteString RelpCommand
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return RelpCommand
RelpCLOSE
    Parser ByteString RelpCommand
-> Parser ByteString RelpCommand -> Parser ByteString RelpCommand
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"open" Parser ByteString
-> Parser ByteString RelpCommand -> Parser ByteString RelpCommand
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RelpCommand -> Parser ByteString RelpCommand
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return RelpCommand
RelpOPEN
    Parser ByteString RelpCommand
-> Parser ByteString RelpCommand -> Parser ByteString RelpCommand
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"rsp" Parser ByteString
-> Parser ByteString RelpCommand -> Parser ByteString RelpCommand
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RelpCommand -> Parser ByteString RelpCommand
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return RelpCommand
RelpRSP
    Parser ByteString RelpCommand
-> Parser ByteString RelpCommand -> Parser ByteString RelpCommand
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> RelpCommand
RelpCommand (ByteString -> RelpCommand)
-> Parser ByteString -> Parser ByteString RelpCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
takeWhile1 (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
32)

relpOffersParser :: Parser RelpOffers 
relpOffersParser :: Parser [(ByteString, ByteString)]
relpOffersParser = Parser ByteString (ByteString, ByteString)
-> Parser [(ByteString, ByteString)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser ByteString (ByteString, ByteString)
 -> Parser [(ByteString, ByteString)])
-> Parser ByteString (ByteString, ByteString)
-> Parser [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Parser ByteString (ByteString, ByteString)
pair Parser ByteString (ByteString, ByteString)
-> Parser ByteString Word8
-> Parser ByteString (ByteString, ByteString)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Word8 -> Parser ByteString Word8
word8 Word8
sep
  where
  sep :: Word8
sep = Word8
10 -- \n
  der :: Word8
der = Word8
61 -- '='
  pair :: Parser ByteString (ByteString, ByteString)
pair = (ByteString -> ByteString -> (ByteString, ByteString))
-> Parser ByteString
-> Parser ByteString
-> Parser ByteString (ByteString, ByteString)
forall a b c.
(a -> b -> c)
-> Parser ByteString a
-> Parser ByteString b
-> Parser ByteString c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)
    ((Word8 -> Bool) -> Parser ByteString
takeWhile1 (\Word8
c-> Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
der Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
sep))
    (Word8 -> Parser ByteString Word8
word8 Word8
der Parser ByteString Word8 -> Parser ByteString -> Parser ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString
takeWhile1 (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
sep) Parser ByteString -> Parser ByteString -> Parser ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"")

relpRsp :: Socket -> RelpMessage -> String -> IO ()
relpRsp :: Socket -> RelpMessage -> [Char] -> IO ()
relpRsp Socket
sock RelpMessage
msg [Char]
reply = Socket -> ByteString -> IO ()
sendAll Socket
sock ByteString
mkReply
  -- putStrLn $ prettyHex $ B8.toStrict mkReply
  where
  mkReply :: ByteString
mkReply = [Char] -> ByteString
B8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ RelpMessage -> Int
relpTxnr RelpMessage
msg) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" rsp "
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
reply) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
reply [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

relpAck :: Socket -> RelpMessage -> IO ()
relpAck :: Socket -> RelpMessage -> IO ()
relpAck Socket
sock RelpMessage
msg = Socket -> RelpMessage -> [Char] -> IO ()
relpRsp Socket
sock RelpMessage
msg [Char]
"200 OK"

relpNAck :: Socket -> RelpMessage -> String -> IO ()
relpNAck :: Socket -> RelpMessage -> [Char] -> IO ()
relpNAck Socket
sock RelpMessage
msg [Char]
err = Socket -> RelpMessage -> [Char] -> IO ()
relpRsp Socket
sock RelpMessage
msg ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"500 " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err

-- just shortcuts
parse_ :: ([Char] -> c) -> (b -> c) -> Parser b -> ByteString -> c
parse_ [Char] -> c
err b -> c
ok Parser b
p = ([Char] -> c) -> (b -> c) -> Either [Char] b -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> c
err b -> c
ok (Either [Char] b -> c)
-> (ByteString -> Either [Char] b) -> ByteString -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser b -> ByteString -> Either [Char] b
forall a. Parser a -> ByteString -> Either [Char] a
parseOnly Parser b
p
parseLazy_ :: ([Char] -> c) -> (b -> c) -> Parser b -> ByteString -> c
parseLazy_ [Char] -> c
err b -> c
ok Parser b
p = ([Char] -> c) -> (b -> c) -> Either [Char] b -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> c
err b -> c
ok (Either [Char] b -> c)
-> (ByteString -> Either [Char] b) -> ByteString -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result b -> Either [Char] b
forall r. Result r -> Either [Char] r
LBP.eitherResult (Result b -> Either [Char] b)
-> (ByteString -> Result b) -> ByteString -> Either [Char] b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser b -> ByteString -> Result b
forall a. Parser a -> ByteString -> Result a
LBP.parse Parser b
p