module Network.Mom.Stompl.Parser (
stompParser,
stompAtOnce)
where
import Data.Attoparsec.ByteString hiding (take, takeWhile, takeTill)
import qualified Data.Attoparsec.ByteString as A (takeWhile, takeTill)
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as U
import Data.Word
import Control.Applicative ((<|>), (<$>))
import Control.Monad (void)
import Network.Mom.Stompl.Frame
stompAtOnce :: B.ByteString -> Either String Frame
stompAtOnce = parseOnly stompParser
stompParser :: Parser Frame
stompParser = do
t <- msgType
case t of
"" -> beat
"CONNECT" -> connect
"STOMP" -> stomp
"CONNECTED" -> connected
"DISCONNECT" -> disconnect
"SEND" -> send
"SUBSCRIBE" -> subscribe
"UNSUBSCRIBE" -> usubscribe
"BEGIN" -> begin
"COMMIT" -> commit
"ABORT" -> abort
"ACK" -> ack
"NACK" -> nack
"MESSAGE" -> message
"RECEIPT" -> receipt
"ERROR" -> prsError
_ -> fail $ "Unknown message type: '" ++ t ++ "'"
msgType :: Parser String
msgType = do
skipWhite
t <- A.takeTill (`elem` [cr, eol, spc])
skipWhite
terminal
return $ U.toString t
beat :: Parser Frame
beat = return mkBeat
send :: Parser Frame
send = bodyFrame mkSndFrame
message :: Parser Frame
message = bodyFrame mkMsgFrame
prsError :: Parser Frame
prsError = bodyFrame mkErrFrame
connect :: Parser Frame
connect = connectFrame mkConFrame
stomp :: Parser Frame
stomp = genericFrame mkStmpFrame
connected :: Parser Frame
connected = connectFrame mkCondFrame
disconnect :: Parser Frame
disconnect = genericFrame mkDisFrame
subscribe :: Parser Frame
subscribe = genericFrame mkSubFrame
usubscribe :: Parser Frame
usubscribe = genericFrame mkUSubFrame
begin :: Parser Frame
begin = genericFrame mkBgnFrame
commit :: Parser Frame
commit = genericFrame mkCmtFrame
abort :: Parser Frame
abort = genericFrame mkAbrtFrame
ack :: Parser Frame
ack = genericFrame mkAckFrame
nack :: Parser Frame
nack = genericFrame mkNackFrame
receipt :: Parser Frame
receipt = genericFrame mkRecFrame
bodyFrame :: ([Header] -> Int -> Body -> Either String Frame) -> Parser Frame
bodyFrame mk = do
hs <- headers True
case getLen hs of
Left e -> fail e
Right l -> do
b <- body l
case mk hs l b of
Left e -> fail e
Right m -> return m
connectFrame :: ([Header] -> Either String Frame) -> Parser Frame
connectFrame mk = do
hs <- headers False
ignoreBody
case mk hs of
Left e -> fail e
Right m -> return m
genericFrame :: ([Header] -> Either String Frame) -> Parser Frame
genericFrame mk = do
hs <- headers True
ignoreBody
case mk hs of
Left e -> fail e
Right m -> return m
headers :: Bool -> Parser [Header]
headers t = reverse <$> headers' t []
headers' :: Bool -> [Header] -> Parser [Header]
headers' t hs = do
skipWhite
endHeaders hs <|> getHeader t hs
endHeaders :: [Header] -> Parser [Header]
endHeaders hs = do
terminal
return hs
getHeader :: Bool -> [Header] -> Parser [Header]
getHeader t hs = do
h <- header t
headers' t (h:hs)
header :: Bool -> Parser Header
header t = do
k <- escText t [col]
keyValSep
v <- escText t [cr, eol]
terminal
return (U.toString k, U.toString v)
keyValSep :: Parser ()
keyValSep = void $ word8 col
terminal :: Parser ()
terminal = do
c <- anyWord8
case c of
10 -> return ()
13 -> void $ word8 eol
_ -> fail $ "Expecting end-of-line: " ++ show c
body :: Int -> Parser B.ByteString
body x = body' x B.empty
where
body' l i = do
n <- A.takeTill (== nul)
let b = i >|< n
if l < 0 || l == B.length b
then do
_ <- word8 nul
return b
else
if l < B.length b
then failBodyLen l (B.length b)
else do
_ <- word8 nul
body' l (b |> 0x00)
escText :: Bool -> [Word8] -> Parser B.ByteString
escText tt stps = go B.empty
where go t = do
let stps' | tt = esc:stps
| otherwise = stps
n <- A.takeTill (`elem` stps')
mbB <- peekWord8
case mbB of
Nothing -> fail $ "end reached, expected: " ++ show stps
Just b ->
if b `elem` stps then return (t >|< n)
else do
_ <- word8 esc
x <- anyWord8
c <- case x of
92 -> return esc
99 -> return col
110 -> return eol
114 -> return cr
_ -> fail $ "Unknown escape sequence: " ++ show x
go (t >|< n |> c)
ignoreBody :: Parser ()
ignoreBody = do
_ <- A.takeTill (== nul)
_ <- word8 nul
return ()
skipWhite :: Parser ()
skipWhite = void $ A.takeWhile (== spc)
nul, eol, cr, spc, col, esc, _c, _r, _n :: Word8
nul = 0
eol = 10
cr = 13
spc = 32
col = 58
esc = 92
_c = 99
_r = 114
_n = 110
failBodyLen :: Int -> Int -> Parser a
failBodyLen l1 l2 =
fail $ "Body longer than indicated by content-length: " ++
show l1 ++ " - " ++ show l2