stompl 0.0.2 → 0.0.3
raw patch · 3 files changed
+318/−240 lines, 3 files
Files
- Network/Mom/Stompl/Frame.hs +292/−214
- Network/Mom/Stompl/Parser.hs +5/−25
- stompl.cabal +21/−1
Network/Mom/Stompl/Frame.hs view
@@ -21,17 +21,16 @@ -- ** Basic Frame Constructors mkConnect, mkConnected, - mkSubscribe, mkUnsubscribe, mkSend,- mkMessage, + mkSubscribe, mkUnsubscribe, + mkSend, mkMessage, mkErr, mkBegin, mkCommit, mkAbort, mkAck, mkNack, mkDisconnect, - mkBeat,- mkErr, mkReceipt,+ mkBeat, mkReceipt, -- ** Header-based Frame Constructors- mkConFrame, mkCondFrame, - mkSubFrame, mkUSubFrame, mkMsgFrame,- mkSndFrame, mkDisFrame, mkErrFrame,+ mkConFrame, mkCondFrame, mkDisFrame,+ mkSubFrame, mkUSubFrame, + mkSndFrame, mkMsgFrame, mkErrFrame, mkBgnFrame, mkCmtFrame, mkAbrtFrame, mkAckFrame, mkNackFrame, mkRecFrame, -- * Working with Headers@@ -42,7 +41,7 @@ mkSesHdr, mkMsgHdr, mkMIdHdr, mkAcVerHdr, mkVerHdr, mkHostHdr, mkBeatHdr, mkMimeHdr, mkSrvHdr,- mkSubHdr,+ mkSubHdr, mkCliIdHdr, valToVer, valToVers, verToVal, versToVal, beatToVal, valToBeat, ackToVal, valToAck,@@ -57,7 +56,7 @@ complies, -- * Get Access to Frames getDest, getTrans, getReceipt,- getLogin, getPasscode, + getLogin, getPasscode, getCliId, getHost, getVersions, getVersion, getBeat, getSession, getServer, @@ -77,9 +76,9 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.UTF8 as U import Data.Char (toUpper, isDigit)- import Data.List (find, sortBy, foldl')+ import Data.List (find, sortBy, foldl', nub) import Data.List.Split (splitWhen)- import Data.Maybe (catMaybes)+ import Data.Maybe (catMaybes, fromMaybe) import Codec.MIME.Type as Mime (showType, Type, nullType) import Codec.MIME.Parse (parseMIMEType) @@ -156,9 +155,10 @@ hdrLog, hdrPass, hdrDest, hdrSub, hdrLen, hdrTrn, hdrRec, hdrRecId, hdrSel, hdrId, hdrAck, hdrSes, hdrMsg, hdrMId, hdrSrv,- hdrAcVer, hdrVer, hdrBeat, hdrHost, hdrMime :: String+ hdrAcVer, hdrVer, hdrBeat, hdrHost, hdrMime, hdrCliId :: String hdrLog = "login" hdrPass = "passcode"+ hdrCliId = "client-id" hdrDest = "destination" hdrSub = "subscription" hdrLen = "content-length"@@ -190,6 +190,10 @@ ------------------------------------------------------------------------ mkPassHdr :: String -> Header ------------------------------------------------------------------------+ -- | make /client-id/ header+ ------------------------------------------------------------------------+ mkCliIdHdr :: String -> Header+ ------------------------------------------------------------------------ -- | make /destination/ header ------------------------------------------------------------------------ mkDestHdr :: String -> Header@@ -264,6 +268,7 @@ mkLogHdr = mkHeader hdrLog mkPassHdr = mkHeader hdrPass+ mkCliIdHdr = mkHeader hdrCliId mkDestHdr = mkHeader hdrDest mkLenHdr = mkHeader hdrLen mkMimeHdr = mkHeader hdrMime@@ -302,25 +307,30 @@ frmPass :: String, frmHost :: String, frmBeat :: Heart,- frmAcVer :: [Version] -- 1.1+ frmAcVer :: [Version], -- 1.1+ frmCliId :: String,+ frmHdrs :: [Header] } | CondFrame { frmSes :: String, frmBeat :: Heart, frmVer :: Version, -- 1.1- frmSrv :: SrvDesc+ frmSrv :: SrvDesc,+ frmHdrs :: [Header] } | SubFrame { frmDest :: String, frmAck :: AckMode, frmSel :: String, frmId :: String,- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | USubFrame { frmDest :: String, frmId :: String,- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | SndFrame { frmHdrs :: [Header],@@ -331,31 +341,37 @@ frmMime :: Mime.Type, frmBody :: Body} | DisFrame {- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | BgnFrame { frmTrans :: String,- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | CmtFrame { frmTrans :: String,- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | AckFrame { frmId :: String, frmSub :: String, frmTrans :: String,- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | NackFrame { frmId :: String, frmSub :: String, frmTrans :: String,- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | AbrtFrame { frmTrans :: String,- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | MsgFrame { frmHdrs :: [Header],@@ -366,13 +382,15 @@ frmMime :: Mime.Type, frmBody :: Body} | RecFrame {- frmRec :: String+ frmRec :: String,+ frmHdrs :: [Header] } | ErrFrame { frmMsg :: String, frmRec :: String, frmLen :: Int, frmMime :: Mime.Type,+ frmHdrs :: [Header], frmBody :: Body} | BeatFrame deriving (Show, Eq)@@ -423,15 +441,25 @@ -- the heart-beat. -- -- * 'Version': the versions supported by the client.+ --+ -- * ClientId: Client identification for persistent connections.+ -- Note that the client id is not a standard Stomp feature,+ -- but specific to ActiveMQ and other brokers.+ -- + --+ -- * 'Header': List of additional, broker-specific headers ----------------------------------------------------------------------- mkConnect :: String -> String -> String -> Heart -> [Version] -> Frame- mkConnect usr pwd hst beat vers =+ mkConnect :: String -> String -> String -> Heart -> [Version] -> + String -> [Header] -> Frame+ mkConnect usr pwd hst beat vers cli hs = ConFrame { frmLogin = usr, frmPass = pwd, frmHost = hst, frmBeat = beat,- frmAcVer = vers}+ frmAcVer = vers,+ frmHdrs = hs,+ frmCliId = cli} ---------------------------------------------------------------------- -- | make a 'Connect' frame (Broker -> Application).@@ -445,14 +473,17 @@ -- * 'Version': The version accepted by the broker -- -- * 'SrvDesc': The server description+ --+ -- * 'Header': List of additional, broker-specific headers. ----------------------------------------------------------------------- mkConnected :: String -> Heart -> Version -> SrvDesc -> Frame- mkConnected ses beat ver srv =+ mkConnected :: String -> Heart -> Version -> SrvDesc -> [Header] -> Frame+ mkConnected ses beat ver srv hs = CondFrame { frmSes = ses, frmBeat = beat, frmVer = ver, - frmSrv = srv}+ frmSrv = srv,+ frmHdrs = hs} ---------------------------------------------------------------------- -- | make a 'Subscribe' frame (Application -> Broker).@@ -480,15 +511,19 @@ -- * Receipt: A unique identifier defined by the application -- to request confirmation of receipt of this frame. -- If no receipt is wanted, the string shall be empty.+ --+ -- * 'Header': List of additional, broker-specific headers. ----------------------------------------------------------------------- mkSubscribe :: String -> AckMode -> String -> String -> String -> Frame- mkSubscribe dst ack sel sid rc =+ mkSubscribe :: String -> AckMode -> + String -> String -> String -> [Header] -> Frame+ mkSubscribe dst ack sel sid rc hs = SubFrame { frmDest = dst, frmAck = ack, frmSel = sel, frmId = sid,- frmRec = rc}+ frmRec = rc,+ frmHdrs = hs} ---------------------------------------------------------------------- -- | make an 'Unsubscribe' frame (Application -> Broker).@@ -503,13 +538,16 @@ -- * Subscription Id: The subscription identifier (see 'mkSubscribe') -- -- * Receipt: The receipt (see 'mkSubscribe')+ --+ -- * 'Header': Additional, broker-specific headers ----------------------------------------------------------------------- mkUnsubscribe :: String -> String -> String -> Frame- mkUnsubscribe dst sid rc =+ mkUnsubscribe :: String -> String -> String -> [Header] -> Frame+ mkUnsubscribe dst sid rc hs = USubFrame { frmDest = dst, frmId = sid,- frmRec = rc}+ frmRec = rc,+ frmHdrs = hs} ---------------------------------------------------------------------- -- | make a 'Send' frame (Application -> Broker).@@ -596,20 +634,24 @@ -- defined by the application. -- -- * Receipt: A receipt (see 'mkSubscribe' for details)+ --+ -- * 'Header': Additional, broker-specific headers ----------------------------------------------------------------------- mkBegin :: String -> String -> Frame+ mkBegin :: String -> String -> [Header] -> Frame mkBegin = BgnFrame ---------------------------------------------------------------------- -- | make a 'Commit' frame (Application -> Broker). -- The parameters are: --- -- * Transaction: A unique transaction identifier+ -- * 'Transaction': A unique transaction identifier -- defined by the application. --- -- * Receipt: A receipt (see 'mkSubscribe' for details)+ -- * 'Receipt': A receipt (see 'mkSubscribe' for details)+ --+ -- * 'Header': Additional, broker-specific headers ----------------------------------------------------------------------- mkCommit :: String -> String -> Frame+ mkCommit :: String -> String -> [Header] -> Frame mkCommit = CmtFrame ----------------------------------------------------------------------@@ -620,8 +662,10 @@ -- defined by the application. -- -- * Receipt: A receipt (see 'mkSubscribe' for details)+ --+ -- * 'Header': Additional, broker-specific headers ----------------------------------------------------------------------- mkAbort :: String -> String -> Frame+ mkAbort :: String -> String -> [Header] -> Frame mkAbort = AbrtFrame ----------------------------------------------------------------------@@ -638,12 +682,13 @@ -- -- * Receipt: see 'mkSubscribe' for details ----------------------------------------------------------------------- mkAck :: String -> String -> String -> String -> Frame- mkAck mid sid trn rc = AckFrame {- frmId = mid,- frmSub = sid,- frmTrans = trn,- frmRec = rc}+ mkAck :: String -> String -> String -> String -> [Header] -> Frame+ mkAck mid sid trn rc hs = AckFrame {+ frmId = mid,+ frmSub = sid,+ frmTrans = trn,+ frmRec = rc,+ frmHdrs = hs} ---------------------------------------------------------------------- -- | make a 'Nack' frame (Application -> Broker).@@ -659,12 +704,13 @@ -- -- * Receipt: see 'mkSubscribe' for details ----------------------------------------------------------------------- mkNack :: String -> String -> String -> String -> Frame- mkNack mid sid trn rc = NackFrame {- frmId = mid,- frmSub = sid,- frmTrans = trn,- frmRec = rc}+ mkNack :: String -> String -> String -> String -> [Header] -> Frame+ mkNack mid sid trn rc hs = NackFrame {+ frmId = mid,+ frmSub = sid,+ frmTrans = trn,+ frmRec = rc,+ frmHdrs = hs} ---------------------------------------------------------------------- -- | make a 'HeatBeat' frame (Application -> Broker and@@ -679,17 +725,19 @@ -- -- * Receipt: see 'mkSubscribe' for details ----------------------------------------------------------------------- mkDisconnect :: String -> Frame- mkDisconnect rec = DisFrame rec+ mkDisconnect :: String -> [Header] -> Frame+ mkDisconnect = DisFrame ---------------------------------------------------------------------- -- | make a 'Receipt' frame (Broker -> Application). -- The parameter is: -- -- * Receipt: The receipt identifier received from the application+ --+ -- * 'Header': List of additional, broker-specific headers ----------------------------------------------------------------------- mkReceipt :: String -> Frame- mkReceipt rec = RecFrame rec+ mkReceipt :: String -> [Header] -> Frame+ mkReceipt = RecFrame ---------------------------------------------------------------------- -- | make a 'Receipt' frame (Broker -> Application).@@ -704,16 +752,19 @@ -- -- * Length: The length of the error message --+ -- * 'Header': List of additional, broker-specific headers+ -- -- * 'Body': The error message ----------------------------------------------------------------------- mkErr :: String -> String -> Mime.Type -> Int -> Body -> Frame- mkErr mid rc mime len bdy =+ mkErr :: String -> String -> Mime.Type -> Int -> [Header] -> Body -> Frame+ mkErr mid rc mime len hs bdy = ErrFrame { frmMsg = mid, frmRec = rc, frmLen = len, frmMime = mime,- frmBody = bdy}+ frmBody = bdy,+ frmHdrs = hs} ------------------------------------------------------------------------ -- | get /destination/ @@ -759,6 +810,11 @@ getPasscode :: Frame -> String getPasscode = frmPass ------------------------------------------------------------------------+ -- | get /client-id/ from 'Connect'+ ------------------------------------------------------------------------+ getCliId :: Frame -> String+ getCliId = frmCliId+ ------------------------------------------------------------------------ -- | get /version/ from 'Connected' ------------------------------------------------------------------------ getVersion :: Frame -> Version@@ -869,21 +925,21 @@ ------------------------------------------------------------------------ typeOf :: Frame -> FrameType typeOf f = case f of- (ConFrame _ _ _ _ _ ) -> Connect- (CondFrame _ _ _ _ ) -> Connected- (DisFrame _ ) -> Disconnect- (SubFrame _ _ _ _ _ ) -> Subscribe- (USubFrame _ _ _ ) -> Unsubscribe- (SndFrame _ _ _ _ _ _ _ ) -> Send- (BgnFrame _ _ ) -> Begin- (CmtFrame _ _ ) -> Commit- (AbrtFrame _ _ ) -> Abort- (AckFrame _ _ _ _ ) -> Ack- (NackFrame _ _ _ _ ) -> Nack- (MsgFrame _ _ _ _ _ _ _ ) -> Message- (RecFrame _ ) -> Receipt- (ErrFrame _ _ _ _ _ ) -> Error- (BeatFrame ) -> HeartBeat+ ConFrame {} -> Connect+ CondFrame {} -> Connected+ DisFrame {} -> Disconnect+ SubFrame {} -> Subscribe+ USubFrame {} -> Unsubscribe+ SndFrame {} -> Send+ BgnFrame {} -> Begin+ CmtFrame {} -> Commit+ AbrtFrame {} -> Abort+ AckFrame {} -> Ack+ NackFrame {} -> Nack+ MsgFrame {} -> Message+ RecFrame {} -> Receipt+ ErrFrame {} -> Error+ BeatFrame {} -> HeartBeat ------------------------------------------------------------------------ -- The AckMode of a Subscription@@ -966,7 +1022,7 @@ -- | convert list of 'Version' to 'String' ------------------------------------------------------------------------ versToVal :: [Version] -> String- versToVal = foldr addVer "" . map verToVal + versToVal = foldr (addVer . verToVal) "" where addVer v vs = if not $ null vs then v ++ "," ++ vs else v@@ -975,7 +1031,7 @@ -- | convert 'Version' to 'String' ------------------------------------------------------------------------ verToVal :: Version -> String- verToVal (major, minor) = (show major) ++ "." ++ (show minor)+ verToVal (major, minor) = show major ++ "." ++ show minor ------------------------------------------------------------------------ -- | convert 'String' to list of 'Version'@@ -1001,7 +1057,7 @@ -- | convert 'HeartBeat' to 'String' ------------------------------------------------------------------------ beatToVal :: Heart -> String- beatToVal (x, y) = (show x) ++ "," ++ (show y)+ beatToVal (x, y) = show x ++ "," ++ show y ------------------------------------------------------------------------ -- | convert 'String' to 'HeartBeat' @@ -1018,7 +1074,7 @@ ------------------------------------------------------------------------ srvToStr :: SrvDesc -> String srvToStr (n, v, c) = n ++ "/" ++ v ++ c'- where c' = if null c then "" else " " ++ c+ where c' = if null c then "" else ' ' : c ------------------------------------------------------------------------ -- | convert 'String' to 'SrvDesc' @@ -1061,7 +1117,7 @@ -- the function results in version 1.0! ------------------------------------------------------------------------ negoVersion :: [Version] -> [Version] -> Version- negoVersion bs cs = nego bs' cs+ negoVersion bs = nego bs' where bs' = sortBy desc bs desc = flip compare nego [] _ = defVersion@@ -1134,7 +1190,7 @@ ------------------------------------------------------------------------ putHeaders :: Frame -> B.ByteString putHeaders f = - let hs = toHeaders f+ let hs = toHeaders f s = B.concat $ map putHeader hs in s |> '\n' @@ -1152,110 +1208,119 @@ ------------------------------------------------------------------------ toHeaders :: Frame -> [Header] -- Connect Frame -------------------------------------------------------- toHeaders (ConFrame l p h b v) = - [mkLogHdr l, mkPassHdr p, - mkAcVerHdr $ versToVal v, - mkBeatHdr $ beatToVal b,- mkHostHdr h]+ toHeaders (ConFrame l p h b v i hs) =+ let lh = if null l then [] else [mkLogHdr l]+ ph = if null p then [] else [mkPassHdr p]+ bh = if b == (0,0) then [] else [mkBeatHdr $ beatToVal b]+ ih = if null i then [] else [mkCliIdHdr i]+ in normalise $ [mkAcVerHdr $ versToVal v, + mkHostHdr h] ++ lh ++ ph ++ bh ++ ih ++ hs -- Connected Frame ------------------------------------------------------ toHeaders (CondFrame s b v d) =- [mkSesHdr s, - mkVerHdr $ verToVal v,- mkBeatHdr $ beatToVal b,- mkSrvHdr $ srvToStr d]+ toHeaders (CondFrame s b v d hs) =+ let sh = if s == "0" then [] else [mkSesHdr s]+ bh = if b == (0,0) then [] else [mkBeatHdr $ beatToVal b]+ x = srvToStr d+ dh = if x == "/" then [] else [mkSrvHdr x]+ in normalise $ mkVerHdr (verToVal v) : sh ++ bh ++ dh ++ hs -- Disconnect Frame ------------------------------------------------------ toHeaders (DisFrame r) =- if null r then [] else [mkRecHdr r]+ toHeaders (DisFrame r hs) =+ if null r then hs else normalise $ mkRecHdr r : hs -- Subscribe Frame ------------------------------------------------------- toHeaders (SubFrame d a s i r) =+ toHeaders (SubFrame d a s i r hs) = let ah = if a == Auto then [] else [mkAckHdr (show a)]- sh = if null s then [] else [mkSelHdr s]- rh = if null r then [] else [mkRecHdr r]- ih = if null i then [] else [mkIdHdr i]- in mkDestHdr d : (ah ++ sh ++ ih ++ rh)+ sh = if null s then [] else [mkSelHdr s]+ rh = if null r then [] else [mkRecHdr r]+ ih = if null i then [] else [mkIdHdr i]+ in normalise $ mkDestHdr d : (ah ++ sh ++ ih ++ rh) ++ hs -- Unsubscribe Frame ----------------------------------------------------- toHeaders (USubFrame d i r) =+ toHeaders (USubFrame d i r hs) = let ih = if null i then [] else [mkIdHdr i] dh = if null d then [] else [mkDestHdr d] rh = if null r then [] else [mkRecHdr r]- in dh ++ ih ++ rh+ in normalise $ dh ++ ih ++ rh ++ hs -- Send Frame ------------------------------------------------------------ toHeaders (SndFrame h d t r l m _) = + toHeaders (SndFrame hs d t r l m _) = let th = if null t then [] else [mkTrnHdr t] rh = if null r then [] else [mkRecHdr r] lh = if l <= 0 then [] else [mkLenHdr (show l)]- in [mkDestHdr d, - mkMimeHdr (showType m)] ++ th ++ rh ++ lh ++ h+ in normalise $ [mkDestHdr d, + mkMimeHdr (showType m)] ++ th ++ rh ++ lh ++ hs -- Begin Frame ------------------------------------------------------------ toHeaders (BgnFrame t r) = + toHeaders (BgnFrame t r hs) = let rh = if null r then [] else [mkRecHdr r]- in [mkTrnHdr t] ++ rh+ in normalise $ [mkTrnHdr t] ++ rh ++ hs -- Commit Frame ------------------------------------------------------------ toHeaders (CmtFrame t r) = + toHeaders (CmtFrame t r hs) = let rh = if null r then [] else [mkRecHdr r]- in [mkTrnHdr t] ++ rh+ in normalise $ [mkTrnHdr t] ++ rh ++ hs -- Abort Frame ------------------------------------------------------------ toHeaders (AbrtFrame t r) = + toHeaders (AbrtFrame t r hs) = let rh = if null r then [] else [mkRecHdr r]- in [mkTrnHdr t] ++ rh+ in normalise $ [mkTrnHdr t] ++ rh ++ hs -- Ack Frame --------------------------------------------------------------- toHeaders (AckFrame i s t r) = - let sh = if null s then [] else [mkSubHdr s]- rh = if null r then [] else [mkRecHdr r]- th = if null t then [] else [mkTrnHdr t]- in ([mkMIdHdr i] ++ th ++ sh ++ rh)+ toHeaders (AckFrame i s t r hs) = + normalise ([mkMIdHdr i] ++ hs ++ subRecTrn s r t) -- Nack Frame -------------------------------------------------------------- toHeaders (NackFrame i s t r) = - let sh = if null s then [] else [mkSubHdr s]- rh = if null r then [] else [mkRecHdr r]- th = if null t then [] else [mkTrnHdr t]- in ([mkMIdHdr i] ++ th ++ sh ++ rh)+ toHeaders (NackFrame i s t r hs) = + normalise ([mkMIdHdr i] ++ hs ++ subRecTrn s r t) -- Message Frame ----------------------------------------------------------- toHeaders (MsgFrame h s d i l m _) = + toHeaders (MsgFrame hs s d i l m _) = let sh = if null s then [] else [mkSubHdr s] dh = if null d then [] else [mkDestHdr d] lh = if l <= 0 then [] else [mkLenHdr (show l)]- in [mkMIdHdr i,- mkMimeHdr (showType m)] - ++ sh ++ dh ++ lh ++ h+ in normalise $ [mkMIdHdr i,+ mkMimeHdr (showType m)] + ++ sh ++ dh ++ lh ++ hs -- Receipt Frame ----------------------------------------------------------- toHeaders (RecFrame r) = [mkRecIdHdr r]+ toHeaders (RecFrame r hs) = normalise $ mkRecIdHdr r : hs -- Error Frame ------------------------------------------------------------- toHeaders (ErrFrame m r l t _) = + toHeaders (ErrFrame m r l t hs _) = let mh = if null m then [] else [mkMsgHdr m] rh = if null r then [] else [mkRecIdHdr r]- lh = if l < 0 then [] else [mkLenHdr (show l)]- in mh ++ rh ++ lh ++ [mkMimeHdr $ showType t]+ lh = if l <= 0 then [] else [mkLenHdr (show l)]+ in normalise $ mh ++ rh ++ lh ++ [mkMimeHdr $ showType t] ++ hs -- Beat Frame -------------------------------------------------------------- toHeaders BeatFrame = [] + subRecTrn :: String -> String -> String -> [Header]+ subRecTrn s r t = + let sh = if null s then [] else [mkSubHdr s]+ rh = if null r then [] else [mkRecHdr r]+ th = if null t then [] else [mkTrnHdr t]+ in sh ++ rh ++ th++ ----------------------------------------------------------------------------+ -- no duplicates, alphanumerical order+ ----------------------------------------------------------------------------+ normalise :: [Header] -> [Header]+ normalise = nub+ ------------------------------------------------------------------------ -- get body from frame ------------------------------------------------------------------------ putBody :: Frame -> Body putBody f = case f of - SndFrame _ _ _ _ _ _ b -> b |> '\x00'- ErrFrame _ _ _ _ b -> b |> '\x00'- MsgFrame _ _ _ _ _ _ b -> b |> '\x00'- _ -> B.pack "\x00"+ x@SndFrame {} -> frmBody x |> '\x00'+ x@ErrFrame {} -> frmBody x |> '\x00'+ x@MsgFrame {} -> frmBody x |> '\x00'+ _ -> B.pack "\x00" ------------------------------------------------------------------------ -- find a header and return it as string value (with default) ------------------------------------------------------------------------ findStrHdr :: String -> String -> [Header] -> String- findStrHdr h d hs = case lookup h hs of- Nothing -> d- Just x -> x+ findStrHdr h d hs = fromMaybe d $ lookup h hs ------------------------------------------------------------------------ -- | make 'Connect' frame ------------------------------------------------------------------------ mkConFrame :: [Header] -> Either String Frame mkConFrame hs = - let l = findStrHdr hdrLog "" hs- p = findStrHdr hdrPass "" hs- h = findStrHdr hdrHost "" hs+ let l = findStrHdr hdrLog "" hs+ p = findStrHdr hdrPass "" hs+ h = findStrHdr hdrHost "" hs+ i = findStrHdr hdrCliId "" hs eiB = case lookup hdrBeat hs of Nothing -> Right noBeat Just x -> case valToBeat x of@@ -1269,9 +1334,11 @@ Just x -> Right x in case eiVs of Left e -> Left e- Right vs -> case eiB of- Left e -> Left e- Right b -> Right $ ConFrame l p h b vs + Right vs -> + case eiB of+ Left e -> Left e+ Right b -> Right $ ConFrame l p h b vs i $ + rmHdrs hs [hdrLog, hdrPass, hdrHost, hdrCliId] ------------------------------------------------------------------------ -- | make 'Connected' frame@@ -1292,14 +1359,15 @@ Nothing -> Left $ "Not a valid version: " ++ v Just v' -> case eiB of Left e -> Left e- Right b -> Right $ CondFrame s b v' d+ Right b -> Right $ CondFrame s b v' d $ + rmHdrs hs [hdrSes, hdrVer, hdrSrv, hdrBeat] ------------------------------------------------------------------------ -- | make 'Disconnect' frame ------------------------------------------------------------------------ mkDisFrame :: [Header] -> Either String Frame mkDisFrame hs = - Right $ DisFrame (findStrHdr hdrRec "" hs)+ Right $ DisFrame (findStrHdr hdrRec "" hs) $ rmHdrs hs [hdrRec] ------------------------------------------------------------------------ -- | make 'Send' frame@@ -1308,7 +1376,7 @@ mkSndFrame hs l b = case lookup hdrDest hs of Nothing -> Left "No destination header in SEND Frame"- Just d -> Right $ SndFrame {+ Just d -> Right SndFrame { frmHdrs = rmHdrs hs [hdrMime, hdrTrn, hdrRec, hdrDest, hdrLen], frmDest = d,@@ -1316,9 +1384,7 @@ frmMime = case lookup hdrMime hs of Nothing -> defMime Just t -> - case parseMIMEType t of- Nothing -> defMime- Just m -> m,+ fromMaybe defMime (parseMIMEType t), frmTrans = findStrHdr hdrTrn "" hs, frmRec = findStrHdr hdrRec "" hs, frmBody = b@@ -1334,22 +1400,19 @@ Just d -> case lookup hdrMId hs of Nothing -> Left "No message id in MESSAGE Frame" Just i ->- Right $ MsgFrame {- frmHdrs = rmHdrs hs [hdrSub, hdrMime, - hdrLen, hdrDest,- hdrMId],- frmDest = d,- frmSub = findStrHdr hdrSub "" hs,- frmId = i, - frmLen = l,- frmMime = case lookup hdrMime hs of- Nothing -> defMime- Just t -> - case parseMIMEType t of- Nothing -> defMime- Just m -> m,- frmBody = b- }+ Right MsgFrame {+ frmHdrs = rmHdrs hs [hdrSub, hdrMime, + hdrLen, hdrDest,+ hdrMId],+ frmDest = d,+ frmSub = findStrHdr hdrSub "" hs,+ frmId = i, + frmLen = l,+ frmMime = case lookup hdrMime hs of+ Nothing -> defMime+ Just t -> + fromMaybe defMime (parseMIMEType t),+ frmBody = b} ------------------------------------------------------------------------ -- | make 'Subscribe' frame@@ -1360,12 +1423,15 @@ Nothing -> Left "No destination header in Subscribe Frame" Just d -> case getAck hs of Left e -> Left e- Right a -> Right $ SubFrame {- frmDest = d,- frmAck = a,- frmSel = findStrHdr hdrSel "" hs,- frmId = findStrHdr hdrId "" hs,- frmRec = findStrHdr hdrRec "" hs}+ Right a -> Right SubFrame {+ frmDest = d,+ frmAck = a,+ frmSel = findStrHdr hdrSel "" hs,+ frmId = findStrHdr hdrId "" hs,+ frmRec = findStrHdr hdrRec "" hs,+ frmHdrs = rmHdrs hs [hdrDest, hdrAck,+ hdrSel, hdrId, + hdrRec]} ------------------------------------------------------------------------ -- | make 'Unsubscribe' frame@@ -1376,14 +1442,16 @@ Nothing -> case lookup hdrId hs of Nothing -> Left $ "No destination and no id header " ++ "in UnSubscribe Frame"- Just i -> Right $ USubFrame {- frmId = i,- frmDest = "",- frmRec = findStrHdr hdrRec "" hs}- Just d -> Right $ USubFrame {- frmId = findStrHdr hdrId "" hs,- frmDest = d,- frmRec = findStrHdr hdrRec "" hs}+ Just i -> Right USubFrame {+ frmId = i,+ frmDest = "",+ frmRec = findStrHdr hdrRec "" hs,+ frmHdrs = rmHdrs hs [hdrId, hdrRec]}+ Just d -> Right USubFrame {+ frmId = findStrHdr hdrId "" hs,+ frmDest = d,+ frmRec = findStrHdr hdrRec "" hs,+ frmHdrs = rmHdrs hs [hdrId, hdrDest, hdrRec]} ------------------------------------------------------------------------ -- | make 'Begin' frame@@ -1391,10 +1459,11 @@ mkBgnFrame :: [Header] -> Either String Frame mkBgnFrame hs = case lookup hdrTrn hs of- Nothing -> Left $ "No transation header in Begin Frame"- Just t -> Right $ BgnFrame {- frmTrans = t,- frmRec = findStrHdr hdrRec "" hs}+ Nothing -> Left "No transation header in Begin Frame"+ Just t -> Right BgnFrame {+ frmTrans = t,+ frmRec = findStrHdr hdrRec "" hs,+ frmHdrs = rmHdrs hs [hdrTrn, hdrRec]} ------------------------------------------------------------------------ -- | make 'Commit' frame@@ -1402,10 +1471,11 @@ mkCmtFrame :: [Header] -> Either String Frame mkCmtFrame hs = case lookup hdrTrn hs of- Nothing -> Left $ "No transation header in Commit Frame"- Just t -> Right $ CmtFrame {- frmTrans = t,- frmRec = findStrHdr hdrRec "" hs}+ Nothing -> Left "No transation header in Commit Frame"+ Just t -> Right CmtFrame {+ frmTrans = t,+ frmRec = findStrHdr hdrRec "" hs,+ frmHdrs = rmHdrs hs [hdrTrn, hdrRec]} ------------------------------------------------------------------------ -- | make 'Abort' frame@@ -1413,10 +1483,11 @@ mkAbrtFrame :: [Header] -> Either String Frame mkAbrtFrame hs = case lookup hdrTrn hs of- Nothing -> Left $ "No transation header in Abort Frame"- Just t -> Right $ AbrtFrame {- frmTrans = t,- frmRec = findStrHdr hdrRec "" hs}+ Nothing -> Left "No transation header in Abort Frame"+ Just t -> Right AbrtFrame {+ frmTrans = t,+ frmRec = findStrHdr hdrRec "" hs,+ frmHdrs = rmHdrs hs [hdrTrn, hdrRec]} ------------------------------------------------------------------------ -- | make 'Ack' frame@@ -1424,15 +1495,15 @@ mkAckFrame :: [Header] -> Either String Frame mkAckFrame hs = case lookup hdrMId hs of- Nothing -> Left $ "No message-id header in Ack Frame"- Just i -> let t = findStrHdr hdrTrn "" hs- s = findStrHdr hdrSub "" hs- r = findStrHdr hdrRec "" hs- in Right AckFrame {+ Nothing -> Left "No message-id header in Ack Frame"+ Just i -> let (t,s,r) = findSubRecTrn hs+ in Right AckFrame { frmId = i, frmSub = s, frmTrans = t,- frmRec = r}+ frmRec = r,+ frmHdrs = rmHdrs hs [hdrMId, hdrTrn, + hdrSub, hdrRec]} ------------------------------------------------------------------------ -- | make 'Nack' frame@@ -1440,41 +1511,47 @@ mkNackFrame :: [Header] -> Either String Frame mkNackFrame hs = case lookup hdrMId hs of- Nothing -> Left $ "No message-id header in Ack Frame"- Just i -> let t = findStrHdr hdrTrn "" hs- s = findStrHdr hdrSub "" hs- r = findStrHdr hdrRec "" hs- in Right NackFrame {+ Nothing -> Left "No message-id header in Ack Frame"+ Just i -> let (t,s,r) = findSubRecTrn hs+ in Right NackFrame { frmId = i, frmSub = s, frmTrans = t,- frmRec = r}+ frmRec = r,+ frmHdrs = rmHdrs hs [hdrMId, hdrTrn,+ hdrSub, hdrRec]} + findSubRecTrn :: [Header] -> (String, String, String)+ findSubRecTrn hs = + let t = findStrHdr hdrTrn "" hs+ s = findStrHdr hdrSub "" hs+ r = findStrHdr hdrRec "" hs+ in (t,s,r)+ ------------------------------------------------------------------------ -- | make 'Receipt' frame ------------------------------------------------------------------------ mkRecFrame :: [Header] -> Either String Frame mkRecFrame hs = case lookup hdrRecId hs of- Nothing -> Left $ "No receipt-id header in Receipt Frame"- Just r -> Right $ RecFrame r+ Nothing -> Left "No receipt-id header in Receipt Frame"+ Just r -> Right $ RecFrame r $ rmHdrs hs [hdrRecId] ------------------------------------------------------------------------ -- | make 'Error' frame ------------------------------------------------------------------------ mkErrFrame :: [Header] -> Int -> Body -> Either String Frame mkErrFrame hs l b =- Right $ ErrFrame {- frmMsg = findStrHdr hdrMsg "" hs,- frmRec = findStrHdr hdrRecId "" hs,- frmLen = l,- frmMime = case lookup hdrMime hs of- Nothing -> defMime- Just t -> - case parseMIMEType t of- Nothing -> defMime- Just x -> x,- frmBody = b}+ Right ErrFrame {+ frmMsg = findStrHdr hdrMsg "" hs,+ frmRec = findStrHdr hdrRecId "" hs,+ frmLen = l,+ frmMime = + case lookup hdrMime hs of+ Nothing -> defMime+ Just t -> fromMaybe defMime (parseMIMEType t),+ frmHdrs = rmHdrs hs [hdrMime, hdrLen, hdrMsg, hdrRecId],+ frmBody = b} ------------------------------------------------------------------------ -- | converts a 'Send' frame into a 'Message' frame;@@ -1522,7 +1599,8 @@ frmSes = i, frmBeat = negoBeat (frmBeat f) b, frmVer = negoVersion vs $ frmAcVer f,- frmSrv = strToSrv s+ frmSrv = strToSrv s,+ frmHdrs = frmHdrs f } _ -> Nothing @@ -1532,7 +1610,7 @@ complies :: Version -> Frame -> Bool complies v f = all (`elm` has) must where must = getHdrs (typeOf f) v- has = toHeaders f+ has = toHeaders f ++ frmHdrs f elm h hs = case lookup h hs of Nothing -> False Just _ -> True
Network/Mom/Stompl/Parser.hs view
@@ -10,9 +10,7 @@ ------------------------------------------------------------------------------- module Network.Mom.Stompl.Parser ( stompParser,- stompAtOnce,- startParsing,- continueParsing+ stompAtOnce ) where @@ -26,29 +24,11 @@ import Network.Mom.Stompl.Frame ------------------------------------------------------------------------- -- | Starts parsing with Attoparsec 'parse'.- -- May fail, conclude or return a partial result.- ------------------------------------------------------------------------- startParsing :: B.ByteString -> Either String (Result Frame)- startParsing m = case parse stompParser m of- Fail _ _ e -> Left e- r -> Right r-- ------------------------------------------------------------------------- -- | Continues parsing with Attoparsec 'feed'.- -- May fail, conclude or return a partial result.- ------------------------------------------------------------------------- continueParsing :: Result Frame -> B.ByteString -> Either String (Result Frame)- continueParsing r m = case feed r m of- Fail _ _ e -> Left e- r' -> Right r'-- ------------------------------------------------------------------------ -- | Parses a ByteString at once with Attoparsec 'parseOnly'. -- May fail or conclude. ------------------------------------------------------------------------ stompAtOnce :: B.ByteString -> Either String Frame- stompAtOnce s = parseOnly stompParser s+ stompAtOnce = parseOnly stompParser ------------------------------------------------------------------------ -- | The Stomp Parser@@ -78,7 +58,7 @@ msgType :: Parser String msgType = do skipWhite- t <- A.takeTill (endAny)+ t <- A.takeTill endAny skipWhite terminal return $ U.toString t@@ -214,7 +194,7 @@ return () endAny :: Word8 -> Bool- endAny w = (w == col || w == eol || w == spc || w == nul)+ endAny w = w `elem` [col, eol, spc, nul] endLine :: Word8 -> Bool endLine = (== eol)@@ -228,5 +208,5 @@ failBodyLen :: Int -> Int -> Parser a failBodyLen l1 l2 = fail $ "Body longer than indicated by content-length: " ++- (show l1) ++ " - " ++ (show l2)+ show l1 ++ " - " ++ show l2
stompl.cabal view
@@ -1,6 +1,6 @@ Name: stompl Category: Message-Oriented Middleware, Network, Stomp, Parser-Version: 0.0.2+Version: 0.0.3 Cabal-Version: >= 1.8 Copyright: Copyright (c) Tobias Schoofs, 2011 - 2012 License: LGPL@@ -32,6 +32,26 @@ <https://github.com/toschoo/mom/>. The Stomp specification can be found at <http://stomp.github.com>.++ .++ Release History:++ .++ [0.0.3] Major changes:+ New attribute "ClientId" in Connect frame + for compatibility with ActiveMQ; + all commands accept additional headers+ to ease adaptations to broker-specific features. ++ .++ [0.0.2] Minor corrections and documentation++ .++ [0.0.1] Initial Release Library Build-Depends: base >= 4.0 && < 5.0,