module Network.Nats.Message.Writer
( writeMessage
) where
import Data.ByteString (ByteString)
import Data.ByteString.Builder
import Data.Monoid ((<>))
import Data.List (foldl', intersperse)
import qualified Data.ByteString.Lazy as LBS
import Network.Nats.Message.Message (Message (..), ProtocolError (..))
import Network.Nats.Types (Sid)
data Field = forall w. Writeable w => Field !w
class Writeable w where
write :: w -> Builder
instance Writeable Bool where
write False = byteString "false"
write True = byteString "true"
instance Writeable Int where
write = intDec
instance Writeable ByteString where
write value = charUtf8 '\"' <> byteString value <> charUtf8 '\"'
writeMessage :: Message -> LBS.ByteString
writeMessage = toLazyByteString . writeMessage'
writeMessage' :: Message -> Builder
writeMessage' INFO {..} =
let fields = foldl' writeField []
[ ("\"server_id\"", Field <$> serverId)
, ("\"version\"", Field <$> serverVersion)
, ("\"go\"", Field <$> goVersion)
, ("\"host\"", Field <$> serverHost)
, ("\"port\"", Field <$> serverPort)
, ("\"auth_required\"", Field <$> serverAuthRequired)
, ("\"ssl_required\"", Field <$> serverSslRequired)
, ("\"tls_required\"", Field <$> serverTlsRequired)
, ("\"tls_verify\"", Field <$> serverTlsVerify)
, ("\"max_payload\"", Field <$> maxPayload)
]
fields' = intersperse (charUtf8 ',') $ reverse fields
in mconcat $ byteString "INFO {":(fields' ++ [charUtf8 '}'])
writeMessage' CONNECT {..} =
let fields = foldl' writeField []
[ ("\"verbose\"", Field <$> clientVerbose)
, ("\"pedantic\"", Field <$> clientPedantic)
, ("\"ssl_required\"", Field <$> clientSslRequired)
, ("\"auth_token\"", Field <$> clientAuthToken)
, ("\"user\"", Field <$> clientUser)
, ("\"pass\"", Field <$> clientPass)
, ("\"name\"", Field <$> clientName)
, ("\"lang\"", Field <$> clientLang)
, ("\"version\"", Field <$> clientVersion)
]
fields' = intersperse (charUtf8 ',') $ reverse fields
in mconcat $ byteString "CONNECT {":(fields' ++ [byteString "}\r\n"])
writeMessage' (MSG subject sid Nothing payload) =
byteString "MSG " <> byteString subject <> charUtf8 ' '
<> writeSid sid <> charUtf8 ' '
<> int64Dec (LBS.length payload) <> byteString "\r\n"
<> lazyByteString payload <> byteString "\r\n"
writeMessage' (MSG subject sid (Just reply) payload) =
byteString "MSG " <> byteString subject <> charUtf8 ' '
<> writeSid sid <> charUtf8 ' '
<> byteString reply <> charUtf8 ' '
<> int64Dec (LBS.length payload) <> byteString "\r\n"
<> lazyByteString payload <> byteString "\r\n"
writeMessage' (PUB subject Nothing payload) =
byteString "PUB " <> byteString subject <> charUtf8 ' '
<> int64Dec (LBS.length payload) <> byteString "\r\n"
<> lazyByteString payload <> byteString "\r\n"
writeMessage' (PUB subject (Just reply) payload) =
byteString "PUB " <> byteString subject <> charUtf8 ' '
<> byteString reply <> charUtf8 ' '
<> int64Dec (LBS.length payload) <> byteString "\r\n"
<> lazyByteString payload <> byteString "\r\n"
writeMessage' (SUB subject Nothing sid) =
byteString "SUB " <> byteString subject <> charUtf8 ' '
<> writeSid sid <> byteString "\r\n"
writeMessage' (SUB subject (Just queue) sid) =
byteString "SUB " <> byteString subject <> charUtf8 ' '
<> byteString queue <> charUtf8 ' '
<> writeSid sid <> byteString "\r\n"
writeMessage' (UNSUB sid Nothing) =
byteString "UNSUB " <> writeSid sid <> byteString "\r\n"
writeMessage' (UNSUB sid (Just maxMsgs)) =
byteString "UNSUB " <> writeSid sid <> charUtf8 ' '
<> intDec maxMsgs <> byteString "\r\n"
writeMessage' PING = byteString "PING" <> byteString "\r\n"
writeMessage' PONG = byteString "PONG" <> byteString "\r\n"
writeMessage' OK = byteString "+OK\r\n"
writeMessage' (ERR pe) = byteString "-ERR " <> writePE pe <> "\r\n"
writeField :: [Builder] -> (ByteString, Maybe Field) -> [Builder]
writeField xs (name, Just (Field value)) =
let x = byteString name <> charUtf8 ':' <> write value
in x:xs
writeField xs (_, Nothing) = xs
writePE :: ProtocolError -> Builder
writePE UnknownProtocolOperation = byteString "\'Unknown Protocol Operation\'"
writePE AuthorizationViolation = byteString "\'Authorization Violation\'"
writePE AuthorizationTimeout = byteString "\'Authorization Timeout\'"
writePE ParserError = byteString "\'Parser Error\'"
writePE StaleConnection = byteString "\'Stale Connection\'"
writePE SlowConsumer = byteString "\'Slow Consumer\'"
writePE MaximumPayloadExceeded = byteString "\'Maximum Payload Exceeded\'"
writePE InvalidSubject = byteString "\'Invalid Subject\'"
writeSid :: Sid -> Builder
writeSid = int64Dec