-------------------------------------------------------------------------------
-- |
-- Module     : Network/Mom/Stompl/Frame.hs
-- Copyright  : (c) Tobias Schoofs
-- License    : LGPL 
-- Stability  : experimental
-- Portability: portable
--
-- Stomp Parser based on Attoparsec
-------------------------------------------------------------------------------
module Network.Mom.Stompl.Parser (
                        stompParser,
                        stompAtOnce)
where

  import           Data.Attoparsec.ByteString hiding (take, takeWhile, takeTill)
  import qualified Data.Attoparsec.ByteString as A
  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
  
  ------------------------------------------------------------------------
  -- | Parses a ByteString at once with Attoparsec 'parseOnly'.
  --   May fail or conclude.
  ------------------------------------------------------------------------
  stompAtOnce :: B.ByteString -> Either String Frame
  stompAtOnce :: ByteString -> Either String Frame
stompAtOnce = Parser Frame -> ByteString -> Either String Frame
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser Frame
stompParser 

  ------------------------------------------------------------------------
  -- | The Stomp Parser
  ------------------------------------------------------------------------
  stompParser :: Parser Frame
  stompParser :: Parser Frame
stompParser = do
    String
t <- Parser String
msgType
    case String
t of
      String
""            -> Parser Frame
beat
      String
"CONNECT"     -> Parser Frame
connect
      String
"STOMP"       -> Parser Frame
stomp
      String
"CONNECTED"   -> Parser Frame
connected
      String
"DISCONNECT"  -> Parser Frame
disconnect
      String
"SEND"        -> Parser Frame
send
      String
"SUBSCRIBE"   -> Parser Frame
subscribe
      String
"UNSUBSCRIBE" -> Parser Frame
usubscribe
      String
"BEGIN"       -> Parser Frame
begin
      String
"COMMIT"      -> Parser Frame
commit 
      String
"ABORT"       -> Parser Frame
abort
      String
"ACK"         -> Parser Frame
ack
      String
"NACK"        -> Parser Frame
nack
      String
"MESSAGE"     -> Parser Frame
message
      String
"RECEIPT"     -> Parser Frame
receipt
      String
"ERROR"       -> Parser Frame
prsError
      String
_             -> String -> Parser Frame
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Frame) -> String -> Parser Frame
forall a b. (a -> b) -> a -> b
$ String
"Unknown message type: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

  msgType :: Parser String
  msgType :: Parser String
msgType = do
    Parser ()
skipWhite
    ByteString
t <- (Word8 -> Bool) -> Parser ByteString
A.takeTill (Word8 -> [Word8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8
cr, Word8
eol, Word8
spc])
    Parser ()
skipWhite
    Parser ()
terminal
    String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
U.toString ByteString
t

  beat :: Parser Frame
  beat :: Parser Frame
beat = Frame -> Parser Frame
forall (m :: * -> *) a. Monad m => a -> m a
return Frame
mkBeat

  send :: Parser Frame
  send :: Parser Frame
send = ([Header] -> Int -> ByteString -> Either String Frame)
-> Parser Frame
bodyFrame [Header] -> Int -> ByteString -> Either String Frame
mkSndFrame

  message :: Parser Frame
  message :: Parser Frame
message = ([Header] -> Int -> ByteString -> Either String Frame)
-> Parser Frame
bodyFrame [Header] -> Int -> ByteString -> Either String Frame
mkMsgFrame

  prsError :: Parser Frame
  prsError :: Parser Frame
prsError = ([Header] -> Int -> ByteString -> Either String Frame)
-> Parser Frame
bodyFrame [Header] -> Int -> ByteString -> Either String Frame
mkErrFrame

  connect :: Parser Frame
  connect :: Parser Frame
connect = ([Header] -> Either String Frame) -> Parser Frame
connectFrame [Header] -> Either String Frame
mkConFrame

  stomp   :: Parser Frame
  stomp :: Parser Frame
stomp   = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkStmpFrame

  connected :: Parser Frame
  connected :: Parser Frame
connected = ([Header] -> Either String Frame) -> Parser Frame
connectFrame [Header] -> Either String Frame
mkCondFrame

  disconnect :: Parser Frame
  disconnect :: Parser Frame
disconnect = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkDisFrame

  subscribe :: Parser Frame
  subscribe :: Parser Frame
subscribe = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkSubFrame 

  usubscribe :: Parser Frame
  usubscribe :: Parser Frame
usubscribe = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkUSubFrame

  begin :: Parser Frame
  begin :: Parser Frame
begin = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkBgnFrame

  commit :: Parser Frame
  commit :: Parser Frame
commit = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkCmtFrame

  abort :: Parser Frame
  abort :: Parser Frame
abort = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkAbrtFrame

  ack :: Parser Frame
  ack :: Parser Frame
ack = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkAckFrame

  nack :: Parser Frame
  nack :: Parser Frame
nack = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkNackFrame
  
  receipt :: Parser Frame
  receipt :: Parser Frame
receipt = ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mkRecFrame

  ------------------------------------------------------------------------
  -- Frame with body
  ------------------------------------------------------------------------
  bodyFrame :: ([Header] -> Int -> Body -> Either String Frame) -> Parser Frame
  bodyFrame :: ([Header] -> Int -> ByteString -> Either String Frame)
-> Parser Frame
bodyFrame [Header] -> Int -> ByteString -> Either String Frame
mk = do
    [Header]
hs <- Bool -> Parser [Header]
headers Bool
True
    case [Header] -> Either String Int
getLen [Header]
hs of
      Left  String
e -> String -> Parser Frame
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
      Right Int
l -> do
        ByteString
b  <- Int -> Parser ByteString
body Int
l
        case [Header] -> Int -> ByteString -> Either String Frame
mk [Header]
hs Int
l ByteString
b of
          Left  String
e -> String -> Parser Frame
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
          Right Frame
m -> Frame -> Parser Frame
forall (m :: * -> *) a. Monad m => a -> m a
return Frame
m

  ------------------------------------------------------------------------
  -- Frame without body and without escaping headers,
  -- i.e. connect and connected
  ------------------------------------------------------------------------
  connectFrame :: ([Header] -> Either String Frame) -> Parser Frame
  connectFrame :: ([Header] -> Either String Frame) -> Parser Frame
connectFrame [Header] -> Either String Frame
mk = do
    [Header]
hs <- Bool -> Parser [Header]
headers Bool
False
    Parser ()
ignoreBody
    case [Header] -> Either String Frame
mk [Header]
hs of
      Left String
e  -> String -> Parser Frame
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
      Right Frame
m -> Frame -> Parser Frame
forall (m :: * -> *) a. Monad m => a -> m a
return Frame
m

  ------------------------------------------------------------------------
  -- Frame without body
  ------------------------------------------------------------------------
  genericFrame :: ([Header] -> Either String Frame) -> Parser Frame
  genericFrame :: ([Header] -> Either String Frame) -> Parser Frame
genericFrame [Header] -> Either String Frame
mk = do
    [Header]
hs <- Bool -> Parser [Header]
headers Bool
True
    Parser ()
ignoreBody
    case [Header] -> Either String Frame
mk [Header]
hs of
      Left String
e  -> String -> Parser Frame
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
      Right Frame
m -> Frame -> Parser Frame
forall (m :: * -> *) a. Monad m => a -> m a
return Frame
m

  ------------------------------------------------------------------------
  -- we add each next header found to the head of the list 
  -- of headers already parsed and therefore 
  -- reverse the list of all headers
  ------------------------------------------------------------------------
  headers :: Bool -> Parser [Header]
  headers :: Bool -> Parser [Header]
headers Bool
t = [Header] -> [Header]
forall a. [a] -> [a]
reverse ([Header] -> [Header]) -> Parser [Header] -> Parser [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Header] -> Parser [Header]
headers' Bool
t []

  headers' :: Bool -> [Header] -> Parser [Header]
  headers' :: Bool -> [Header] -> Parser [Header]
headers' Bool
t [Header]
hs = do
    Parser ()
skipWhite
    [Header] -> Parser [Header]
endHeaders [Header]
hs Parser [Header] -> Parser [Header] -> Parser [Header]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> [Header] -> Parser [Header]
getHeader Bool
t [Header]
hs 

  endHeaders :: [Header] -> Parser [Header]
  endHeaders :: [Header] -> Parser [Header]
endHeaders [Header]
hs = do
    Parser ()
terminal
    [Header] -> Parser [Header]
forall (m :: * -> *) a. Monad m => a -> m a
return [Header]
hs

  getHeader :: Bool -> [Header] -> Parser [Header]
  getHeader :: Bool -> [Header] -> Parser [Header]
getHeader Bool
t [Header]
hs = do
    Header
h <- Bool -> Parser Header
header Bool
t
    Bool -> [Header] -> Parser [Header]
headers' Bool
t (Header
hHeader -> [Header] -> [Header]
forall a. a -> [a] -> [a]
:[Header]
hs)

  header :: Bool -> Parser Header
  header :: Bool -> Parser Header
header Bool
t = do
    ByteString
k <- Bool -> [Word8] -> Parser ByteString
escText Bool
t [Word8
col] 
    Parser ()
keyValSep
    ByteString
v <- Bool -> [Word8] -> Parser ByteString
escText Bool
t [Word8
cr, Word8
eol]
    Parser ()
terminal
    Header -> Parser Header
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> String
U.toString ByteString
k, ByteString -> String
U.toString ByteString
v)

  keyValSep :: Parser ()
  keyValSep :: Parser ()
keyValSep = Parser ByteString Word8 -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString Word8 -> Parser ())
-> Parser ByteString Word8 -> Parser ()
forall a b. (a -> b) -> a -> b
$ Word8 -> Parser ByteString Word8
word8 Word8
col

  ------------------------------------------------------------------------
  -- end-of-line: either lf or cr ++ lf
  ------------------------------------------------------------------------
  terminal :: Parser ()
  terminal :: Parser ()
terminal = do
    Word8
c <- Parser ByteString Word8
anyWord8
    case Word8
c of
      Word8
10 -> () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Word8
13 -> Parser ByteString Word8 -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString Word8 -> Parser ())
-> Parser ByteString Word8 -> Parser ()
forall a b. (a -> b) -> a -> b
$ Word8 -> Parser ByteString Word8
word8 Word8
eol
      Word8
_  -> String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"Expecting end-of-line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
c

  ------------------------------------------------------------------------
  -- read text until end-of-body
  ------------------------------------------------------------------------
  body :: Int -> Parser B.ByteString
  body :: Int -> Parser ByteString
body Int
l | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = ByteString -> Parser ByteString
eob ByteString
B.empty
         | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
0    = Int -> Parser ByteString
A.take Int
l Parser ByteString
-> (ByteString -> Parser ByteString) -> Parser ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Parser ByteString
eob
         | Bool
otherwise = (Word8 -> Bool) -> Parser ByteString
A.takeTill (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
nul) Parser ByteString
-> (ByteString -> Parser ByteString) -> Parser ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Parser ByteString
eob

  ------------------------------------------------------------------------
  -- end-of-body: read nul and return the body 
  ------------------------------------------------------------------------
  eob :: B.ByteString -> Parser B.ByteString
  eob :: ByteString -> Parser ByteString
eob ByteString
b = Parser ByteString Word8 -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Word8 -> Parser ByteString Word8
word8 Word8
nul) Parser () -> Parser ByteString -> Parser ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b

  ------------------------------------------------------------------------
  -- escape header key and value;
  -- we don't do this for connect and connected frames,
  -- this is controlled by the Bool parameter.
  ------------------------------------------------------------------------
  escText :: Bool -> [Word8] -> Parser B.ByteString
  escText :: Bool -> [Word8] -> Parser ByteString
escText Bool
tt [Word8]
stps = ByteString -> Parser ByteString
go ByteString
B.empty
    where go :: ByteString -> Parser ByteString
go ByteString
t = do
            let stps' :: [Word8]
stps' | Bool
tt        = Word8
escWord8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
stps
                      | Bool
otherwise =     [Word8]
stps
            ByteString
n   <- (Word8 -> Bool) -> Parser ByteString
A.takeTill (Word8 -> [Word8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8]
stps')
            Maybe Word8
mbB <- Parser (Maybe Word8)
peekWord8
            case Maybe Word8
mbB of
              Maybe Word8
Nothing -> String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString) -> String -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ String
"end reached, expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Word8] -> String
forall a. Show a => a -> String
show [Word8]
stps
              Just Word8
b  ->
                if Word8
b Word8 -> [Word8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8]
stps then ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
t ByteString -> ByteString -> ByteString
>|< ByteString
n)
                  else do 
                    Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
esc
                    Word8
x <- Parser ByteString Word8
anyWord8
                    Word8
c <- case Word8
x of
                           Word8
92  -> Word8 -> Parser ByteString Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
esc
                           Word8
99  -> Word8 -> Parser ByteString Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
col
                           Word8
110 -> Word8 -> Parser ByteString Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
eol
                           Word8
114 -> Word8 -> Parser ByteString Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
cr
                           Word8
_   -> String -> Parser ByteString Word8
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString Word8)
-> String -> Parser ByteString Word8
forall a b. (a -> b) -> a -> b
$ String
"Unknown escape sequence: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
x
                    ByteString -> Parser ByteString
go (ByteString
t ByteString -> ByteString -> ByteString
>|< ByteString
n ByteString -> Word8 -> ByteString
|> Word8
c)

  ignoreBody :: Parser ()
  ignoreBody :: Parser ()
ignoreBody = do 
    ByteString
_ <- (Word8 -> Bool) -> Parser ByteString
A.takeTill (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
nul)
    Word8
_ <- Word8 -> Parser ByteString Word8
word8 Word8
nul
    () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  skipWhite :: Parser ()
  skipWhite :: Parser ()
skipWhite = Parser ByteString -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString -> Parser ()) -> Parser ByteString -> Parser ()
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> Parser ByteString
A.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
spc)

  nul, eol, cr, spc, col, esc, _c, _r, _n  :: Word8
  nul :: Word8
nul  =   Word8
0
  eol :: Word8
eol  =  Word8
10
  cr :: Word8
cr   =  Word8
13
  spc :: Word8
spc  =  Word8
32
  col :: Word8
col  =  Word8
58
  esc :: Word8
esc  =  Word8
92
  _c :: Word8
_c   =  Word8
99
  _r :: Word8
_r   = Word8
114
  _n :: Word8
_n   = Word8
110