diff --git a/Network/Mom/Stompl/Frame.hs b/Network/Mom/Stompl/Frame.hs new file mode 100644 --- /dev/null +++ b/Network/Mom/Stompl/Frame.hs @@ -0,0 +1,1584 @@ +------------------------------------------------------------------------------- +-- | +-- Module : Network/Mom/Stompl/Frame.hs +-- Copyright : (c) Tobias Schoofs +-- License : LGPL +-- Stability : experimental +-- Portability: portable +-- +-- Stomp Frames and some useful operations on them +------------------------------------------------------------------------------- +module Network.Mom.Stompl.Frame ( + -- * Frames + -- $stomp_frames + Frame, FrameType(..), + Header, Body, Heart, Version, + AckMode(..), isValidAck, + SrvDesc, + getSrvName, getSrvVer, getSrvCmts, + -- * Frame Constructors + -- $stomp_constructors + + -- ** Basic Frame Constructors + mkConnect, mkConnected, + mkSubscribe, mkUnsubscribe, mkSend, + mkMessage, + mkBegin, mkCommit, mkAbort, + mkAck, mkNack, + mkDisconnect, + mkBeat, + mkErr, mkReceipt, + -- ** Header-based Frame Constructors + mkConFrame, mkCondFrame, + mkSubFrame, mkUSubFrame, mkMsgFrame, + mkSndFrame, mkDisFrame, mkErrFrame, + mkBgnFrame, mkCmtFrame, mkAbrtFrame, + mkAckFrame, mkNackFrame, mkRecFrame, + -- * Working with Headers + -- $stomp_headers + mkLogHdr, mkPassHdr, mkDestHdr, + mkLenHdr, mkTrnHdr, mkRecHdr, + mkSelHdr, mkIdHdr, mkAckHdr, + mkSesHdr, mkMsgHdr, mkMIdHdr, + mkAcVerHdr, mkVerHdr, mkHostHdr, + mkBeatHdr, mkMimeHdr, mkSrvHdr, + mkSubHdr, + valToVer, valToVers, verToVal, versToVal, + beatToVal, valToBeat, + ackToVal, valToAck, + strToSrv, srvToStr, + negoVersion, negoBeat, + rmHdr, rmHdrs, + getAck, getLen, + -- * Working with Frames + typeOf, putFrame, toString, putCommand, + sndToMsg, conToCond, + resetTrans, + complies, + -- * Get Access to Frames + getDest, getTrans, getReceipt, + getLogin, getPasscode, + getHost, getVersions, getVersion, + getBeat, + getSession, getServer, + getSub, getSelector, getId, getAcknow, + getBody, getMime, getLength, + getMsg, getHeaders, + -- * Sequence Operators to work on 'ByteString' + (|>), (<|), (>|<), + -- * Some random helpers + -- (that do not really belong here) + upString, numeric) +where + + -- Todo: + -- - conformance to protocol + + 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.Split (splitWhen) + import Data.Maybe (catMaybes) + import Codec.MIME.Type as Mime (showType, Type, nullType) + import Codec.MIME.Parse (parseMIMEType) + + ------------------------------------------------------------------------ + -- | Tuple of (key, value) + ------------------------------------------------------------------------ + type Header = (String, String) + + ------------------------------------------------------------------------ + -- | The Frame body is represented as /strict/ 'ByteString'. + ------------------------------------------------------------------------ + type Body = B.ByteString + + ------------------------------------------------------------------------ + -- | The Stomp version used or accepted by the sender; + -- the first 'Int' is the major version number, + -- the second is the minor. + -- For details on version negotiation, please refer to + -- the Stomp specification. + ------------------------------------------------------------------------ + type Version = (Int, Int) + + ------------------------------------------------------------------------ + -- | Heart-beat configuration; + -- the first 'Int' of the pair represents the frequency + -- in which the sender wants to send heart-beats; + -- the second represents the highest frequency + -- in which the sender can accept heart-beats. + -- The frequency is expressed as + -- the period in milliseconds between two heart-beats. + -- For details on negotiating heart-beats, + -- please refer to the Stomp specification. + ------------------------------------------------------------------------ + type Heart = (Int, Int) + + ------------------------------------------------------------------------- + -- | Description of a server consisting of + -- name, version and comments + ------------------------------------------------------------------------- + type SrvDesc = (String, String, String) + + ------------------------------------------------------------------------- + -- | get name from 'SrvDesc' + ------------------------------------------------------------------------- + getSrvName :: SrvDesc -> String + getSrvName (n, _, _) = n + + ------------------------------------------------------------------------- + -- | get version from 'SrvDesc' + ------------------------------------------------------------------------- + getSrvVer :: SrvDesc -> String + getSrvVer (_, v, _) = v + + ------------------------------------------------------------------------- + -- | get comments from 'SrvDesc' + ------------------------------------------------------------------------- + getSrvCmts :: SrvDesc -> String + getSrvCmts (_, _, c) = c + + noBeat :: Heart + noBeat = (0,0) + + defMime :: Mime.Type + defMime = Mime.nullType + + defVerStr :: String + defVerStr = "1.0" + + defVersion :: Version + defVersion = (1, 0) + + noSrvDesc :: SrvDesc + noSrvDesc = ("","","") + + hdrLog, hdrPass, hdrDest, hdrSub, hdrLen, hdrTrn, hdrRec, hdrRecId, + hdrSel, hdrId, hdrAck, hdrSes, hdrMsg, hdrMId, hdrSrv, + hdrAcVer, hdrVer, hdrBeat, hdrHost, hdrMime :: String + hdrLog = "login" + hdrPass = "passcode" + hdrDest = "destination" + hdrSub = "subscription" + hdrLen = "content-length" + hdrMime = "content-type" + hdrTrn = "transaction" + hdrRec = "receipt" + hdrRecId = "receipt-id" + hdrSel = "selector" + hdrId = "id" + hdrAck = "ack" + hdrSes = "session-id" + hdrMsg = "message" + hdrMId = "message-id" + hdrAcVer = "accept-version" + hdrVer = "version" + hdrHost = "host" + hdrBeat = "heart-beat" + hdrSrv = "server" + + mkHeader :: String -> String -> Header + mkHeader k v = (k, v) + + ------------------------------------------------------------------------ + -- | make /login/ header + ------------------------------------------------------------------------ + mkLogHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /passcode/ header + ------------------------------------------------------------------------ + mkPassHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /destination/ header + ------------------------------------------------------------------------ + mkDestHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /content-length/ header + ------------------------------------------------------------------------ + mkLenHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /content-type/ header + ------------------------------------------------------------------------ + mkMimeHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /transaction/ header + ------------------------------------------------------------------------ + mkTrnHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /receipt/ header + ------------------------------------------------------------------------ + mkRecHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /receipt-id/ header + ------------------------------------------------------------------------ + mkRecIdHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /selector/ header + ------------------------------------------------------------------------ + mkSelHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /message-id/ header + ------------------------------------------------------------------------ + mkMIdHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /id/ header (subscribe frame) + ------------------------------------------------------------------------ + mkIdHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /subscription/ header + ------------------------------------------------------------------------ + mkSubHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /server/ header (connected frame) + ------------------------------------------------------------------------ + mkSrvHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /ack/ header (subscribe frame) + ------------------------------------------------------------------------ + mkAckHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /session/ header (connected frame) + ------------------------------------------------------------------------ + mkSesHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /accept-version/ header (connect frame) + ------------------------------------------------------------------------ + mkAcVerHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /version/ header (connected frame) + ------------------------------------------------------------------------ + mkVerHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /host/ header (connect frame) + ------------------------------------------------------------------------ + mkHostHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /message/ header (error frame) + ------------------------------------------------------------------------ + mkMsgHdr :: String -> Header + ------------------------------------------------------------------------ + -- | make /heart-beat/ header + ------------------------------------------------------------------------ + mkBeatHdr :: String -> Header + + mkLogHdr = mkHeader hdrLog + mkPassHdr = mkHeader hdrPass + mkDestHdr = mkHeader hdrDest + mkLenHdr = mkHeader hdrLen + mkMimeHdr = mkHeader hdrMime + mkTrnHdr = mkHeader hdrTrn + mkRecHdr = mkHeader hdrRec + mkRecIdHdr = mkHeader hdrRecId + mkSelHdr = mkHeader hdrSel + mkIdHdr = mkHeader hdrId + mkMIdHdr = mkHeader hdrMId + mkAckHdr = mkHeader hdrAck + mkSubHdr = mkHeader hdrSub + mkSesHdr = mkHeader hdrSes + mkMsgHdr = mkHeader hdrMsg + mkVerHdr = mkHeader hdrVer + mkAcVerHdr = mkHeader hdrAcVer + mkHostHdr = mkHeader hdrHost + mkBeatHdr = mkHeader hdrBeat + mkSrvHdr = mkHeader hdrSrv + + {- $stomp_frames + Frames are the building blocks of the Stomp protocol. + They are exchanged between broker and application + and contain commands or status and error messages. + + Frames follow a simple text-based format. + They consist of a /command/ (the 'FrameType'), + a list of key\/value-pairs, called 'Header', + and a 'Body' (which is empty for most frame types). + -} + + ------------------------------------------------------------------------- + -- | This is a frame + ------------------------------------------------------------------------- + data Frame = ConFrame { + frmLogin :: String, + frmPass :: String, + frmHost :: String, + frmBeat :: Heart, + frmAcVer :: [Version] -- 1.1 + } + | CondFrame { + frmSes :: String, + frmBeat :: Heart, + frmVer :: Version, -- 1.1 + frmSrv :: SrvDesc + } + | SubFrame { + frmDest :: String, + frmAck :: AckMode, + frmSel :: String, + frmId :: String, + frmRec :: String + } + | USubFrame { + frmDest :: String, + frmId :: String, + frmRec :: String + } + | SndFrame { + frmHdrs :: [Header], + frmDest :: String, + frmTrans :: String, + frmRec :: String, + frmLen :: Int, + frmMime :: Mime.Type, + frmBody :: Body} + | DisFrame { + frmRec :: String + } + | BgnFrame { + frmTrans :: String, + frmRec :: String + } + | CmtFrame { + frmTrans :: String, + frmRec :: String + } + | AckFrame { + frmId :: String, + frmSub :: String, + frmTrans :: String, + frmRec :: String + } + | NackFrame { + frmId :: String, + frmSub :: String, + frmTrans :: String, + frmRec :: String + } + | AbrtFrame { + frmTrans :: String, + frmRec :: String + } + | MsgFrame { + frmHdrs :: [Header], + frmSub :: String, + frmDest :: String, + frmId :: String, + frmLen :: Int, + frmMime :: Mime.Type, + frmBody :: Body} + | RecFrame { + frmRec :: String + } + | ErrFrame { + frmMsg :: String, + frmRec :: String, + frmLen :: Int, + frmMime :: Mime.Type, + frmBody :: Body} + | BeatFrame + deriving (Show, Eq) + + {- $stomp_constructors + There are two different interfaces to construct frames: + + * a set of conventional, /basic/ constructors and + + * a set of header-based constructors + + The /basic/ constructors receive the frame attributes + directly, /i.e./ with the types, in which they will be stored. + These constructors are, hence, type-safe. + They are, however, unsafe in terms of protocol compliance. + Headers that identify some entity are stored as plain strings. + The basic constructors do not verify + if an identifier is required for a given frame type. + Using plain strings for identifiers + may appear to be odd on the first sight. + Since this library is intended for any + implementation of Stomp programs (brokers and applications) where + identifers (for messages, transactions, receipts, /etc./) + may have completely different formats, + no choice was made on dedicated identifier types. + + Header-based constructors, on the other hand, + receive attributes packed in a list of 'Header'. + The types are converted by the constructor. + The constructor, additionally, verfies the protocol compliance. + Header-based constructors are, hence, more reliable. + This implies, however, that they can fail. + For this reason, Header-based constructors return 'Either'. + -} + + ---------------------------------------------------------------------- + -- | make a 'Connect' frame (Application -> Broker). + -- The parameters are: + -- + -- * User: user to authenticate at the broker. + -- + -- * Passcode: password to authenticate at the broker. + -- + -- * Host: broker's virtual hoast (/e.g./ + -- stomp.broker.github.org). + -- + -- * 'HeartBeat': the clients bid in negotiating + -- the heart-beat. + -- + -- * 'Version': the versions supported by the client. + ---------------------------------------------------------------------- + mkConnect :: String -> String -> String -> Heart -> [Version] -> Frame + mkConnect usr pwd hst beat vers = + ConFrame { + frmLogin = usr, + frmPass = pwd, + frmHost = hst, + frmBeat = beat, + frmAcVer = vers} + + ---------------------------------------------------------------------- + -- | make a 'Connect' frame (Broker -> Application). + -- The parameters are: + -- + -- * Session: A unique identifier created by the broker + -- and identifying the session + -- + -- * 'HeartBeat': The heart-beat agreed by the broker + -- + -- * 'Version': The version accepted by the broker + -- + -- * 'SrvDesc': The server description + ---------------------------------------------------------------------- + mkConnected :: String -> Heart -> Version -> SrvDesc -> Frame + mkConnected ses beat ver srv = + CondFrame { + frmSes = ses, + frmBeat = beat, + frmVer = ver, + frmSrv = srv} + + ---------------------------------------------------------------------- + -- | make a 'Subscribe' frame (Application -> Broker). + -- The parameters are: + -- + -- * Destination: The name of the queue as it is known by the broker + -- and other applications using the queue + -- + -- * 'AckMode': The Acknowledge Mode for this subscription + -- + -- * Selector: An expression defining those messages + -- that are of actual for client. + -- The Stomp protocol does not define + -- a language for selectors; + -- it is even not entirely clear, + -- where messages are selected: + -- already at the broker, or only by the client. + -- Some brokers provide pre-selection of messages, + -- others do not. + -- + -- * Subscription Id: A unique identifier distinguishing this + -- subscription from others to the same queue. + -- The identifier is defined by the application. + -- + -- * 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. + ---------------------------------------------------------------------- + mkSubscribe :: String -> AckMode -> String -> String -> String -> Frame + mkSubscribe dst ack sel sid rc = + SubFrame { + frmDest = dst, + frmAck = ack, + frmSel = sel, + frmId = sid, + frmRec = rc} + + ---------------------------------------------------------------------- + -- | make an 'Unsubscribe' frame (Application -> Broker). + -- The parameters are: + -- + -- * Destination: The queue name; either a destination or a + -- subscription id must be given. + -- (According to protocol version 1.1, + -- the subscription id is mandatory on + -- both, 'Subscribe' and 'Unsubscribe'.) + -- + -- * Subscription Id: The subscription identifier (see 'mkSubscribe') + -- + -- * Receipt: The receipt (see 'mkSubscribe') + ---------------------------------------------------------------------- + mkUnsubscribe :: String -> String -> String -> Frame + mkUnsubscribe dst sid rc = + USubFrame { + frmDest = dst, + frmId = sid, + frmRec = rc} + + ---------------------------------------------------------------------- + -- | make a 'Send' frame (Application -> Broker). + -- The parameters are: + -- + -- * Destination: The name of the queue + -- where the message should be published + -- + -- * Transaction: A unique identifier indicating + -- a running transaction; + -- if sent with a transaction, + -- the message will not be delivered + -- to subscribing applications, + -- before the transaction is committed. + -- If the 'Send' is not part of a transaction, + -- the string shall be empty. + -- + -- * Receipt: A receipt (see 'mkSubscribe' for details) + -- + -- * 'Mime.Type': The content type of the payload message + -- as MIME Type + -- + -- * Length: The length of the type in bytes + -- + -- * 'Header': List of additional headers; + -- Stomp protocol requires that user-specified + -- headers are passed through to subscribing applications. + -- These headers may, for instance, be use + -- by selectors to select messages. + -- + -- * 'Body': The payload message + ---------------------------------------------------------------------- + mkSend :: String -> String -> String -> + Mime.Type -> Int -> [Header] -> + Body -> Frame + mkSend dst trn rec mime len hs bdy = + SndFrame { + frmHdrs = hs, + frmDest = dst, + frmTrans = trn, + frmRec = rec, + frmLen = len, + frmMime = mime, + frmBody = bdy} + + ---------------------------------------------------------------------- + -- | make a 'Message' frame (Broker -> Application). + -- The parameters are: + -- + -- * Subscription Id: The message was sent + -- because the application subscribed to the queue + -- with this subscription id (see 'mkSubscribe'). + -- + -- * Destination: The name of the queue, in wich the message was published. + -- + -- * Message Id: A unique message identifier, defined by the broker + -- + -- * 'Mime.Type': The type of the playload as MIME Type + -- + -- * Length: The length of the payload in bytes + -- + -- * 'Header': A list of user-defined headers (see 'mkSend' for details) + -- + -- * 'Body': The payload + ---------------------------------------------------------------------- + mkMessage :: String -> String -> String -> + Mime.Type -> Int -> [Header] -> + Body -> Frame + mkMessage sub dst mid mime len hs bdy = + MsgFrame { + frmHdrs = hs, + frmSub = sub, + frmDest = dst, + frmId = mid, + frmLen = len, + frmMime = mime, + frmBody = bdy} + + ---------------------------------------------------------------------- + -- | make a 'Begin' frame (Application -> Broker). + -- The parameters are: + -- + -- * Transaction: A unique transaction identifier + -- defined by the application. + -- + -- * Receipt: A receipt (see 'mkSubscribe' for details) + ---------------------------------------------------------------------- + mkBegin :: String -> String -> Frame + mkBegin = BgnFrame + + ---------------------------------------------------------------------- + -- | make a 'Commit' frame (Application -> Broker). + -- The parameters are: + -- + -- * Transaction: A unique transaction identifier + -- defined by the application. + -- + -- * Receipt: A receipt (see 'mkSubscribe' for details) + ---------------------------------------------------------------------- + mkCommit :: String -> String -> Frame + mkCommit = CmtFrame + + ---------------------------------------------------------------------- + -- | make an 'Abort' frame (Application -> Broker). + -- The parameters are: + -- + -- * Transaction: A unique transaction identifier + -- defined by the application. + -- + -- * Receipt: A receipt (see 'mkSubscribe' for details) + ---------------------------------------------------------------------- + mkAbort :: String -> String -> Frame + mkAbort = AbrtFrame + + ---------------------------------------------------------------------- + -- | make an 'Ack' frame (Application -> Broker). + -- The parameters are: + -- + -- * Message Id: The identifier of the message to be ack'd + -- + -- * Subscription Id: The subscription, through which + -- the message was received + -- + -- * Transaction: Acks may be part of a transaction + -- (see 'mkSend' for details). + -- + -- * 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} + + ---------------------------------------------------------------------- + -- | make a 'Nack' frame (Application -> Broker). + -- The parameters are: + -- + -- * Message Id: The identifier of the message to be nack'd + -- + -- * Subscription Id: The subscription, through which + -- the message was received + -- + -- * Transaction: Nacks may be part of a transaction + -- (see 'mkSend' for details). + -- + -- * 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} + + ---------------------------------------------------------------------- + -- | make a 'HeatBeat' frame (Application -> Broker and + -- Broker -> Application) + ---------------------------------------------------------------------- + mkBeat :: Frame + mkBeat = BeatFrame + + ---------------------------------------------------------------------- + -- | make a 'Disconnect' frame (Application -> Broker). + -- The parameter is: + -- + -- * Receipt: see 'mkSubscribe' for details + ---------------------------------------------------------------------- + mkDisconnect :: String -> Frame + mkDisconnect rec = DisFrame rec + + ---------------------------------------------------------------------- + -- | make a 'Receipt' frame (Broker -> Application). + -- The parameter is: + -- + -- * Receipt: The receipt identifier received from the application + ---------------------------------------------------------------------- + mkReceipt :: String -> Frame + mkReceipt rec = RecFrame rec + + ---------------------------------------------------------------------- + -- | make a 'Receipt' frame (Broker -> Application). + -- The parameters are: + -- + -- * Error Message Id: A short error description + -- + -- * Receipt Id: The receipt of frame sent by the application + -- to which this error relates + -- + -- * 'Mime.Type': The format of the error message as MIME Type + -- + -- * Length: The length of the error message + -- + -- * 'Body': The error message + ---------------------------------------------------------------------- + mkErr :: String -> String -> Mime.Type -> Int -> Body -> Frame + mkErr mid rc mime len bdy = + ErrFrame { + frmMsg = mid, + frmRec = rc, + frmLen = len, + frmMime = mime, + frmBody = bdy} + + ------------------------------------------------------------------------ + -- | get /destination/ + -- from 'Subscribe', 'Unsubscribe', 'Send' or 'Message' + ------------------------------------------------------------------------ + getDest :: Frame -> String + getDest = frmDest + ------------------------------------------------------------------------ + -- | get /transaction/ from 'Send', 'Ack', 'Nack', + -- 'Begin', 'Commit' or 'Abort' + ------------------------------------------------------------------------ + getTrans :: Frame -> String + getTrans = frmTrans + ------------------------------------------------------------------------ + -- | get /receipt/ or /receipt-id/ from any frame, but + -- 'Connect', 'Connected', 'Message', 'Error' + ------------------------------------------------------------------------ + getReceipt :: Frame -> String + getReceipt = frmRec + ------------------------------------------------------------------------ + -- | get /host/ from 'Connect' + ------------------------------------------------------------------------ + getHost :: Frame -> String + getHost = frmHost + ------------------------------------------------------------------------ + -- | get /accept-version/ from 'Connect' + ------------------------------------------------------------------------ + getVersions :: Frame -> [Version] + getVersions = frmAcVer + ------------------------------------------------------------------------ + -- | get /heart-beat/ from 'Connect' or 'Connected' + ------------------------------------------------------------------------ + getBeat :: Frame -> Heart + getBeat = frmBeat + ------------------------------------------------------------------------ + -- | get /login/ from 'Connect' + ------------------------------------------------------------------------ + getLogin :: Frame -> String + getLogin = frmLogin + ------------------------------------------------------------------------ + -- | get /passcode/ from 'Connect' + ------------------------------------------------------------------------ + getPasscode :: Frame -> String + getPasscode = frmPass + ------------------------------------------------------------------------ + -- | get /version/ from 'Connected' + ------------------------------------------------------------------------ + getVersion :: Frame -> Version + getVersion = frmVer + ------------------------------------------------------------------------ + -- | get /session/ from 'Connected' + ------------------------------------------------------------------------ + getSession :: Frame -> String + getSession = frmSes + ------------------------------------------------------------------------ + -- | get /server/ from 'Connected' + ------------------------------------------------------------------------ + getServer :: Frame -> SrvDesc + getServer = frmSrv + ------------------------------------------------------------------------ + -- | get /id/ from 'Subscribe' or 'Unsubscribe' + ------------------------------------------------------------------------ + getId :: Frame -> String + getId = frmId + ------------------------------------------------------------------------ + -- | get /ack/ from 'Subscribe' + ------------------------------------------------------------------------ + getAcknow :: Frame -> AckMode + getAcknow = frmAck + ------------------------------------------------------------------------ + -- | get /selector/ from 'Subscribe' + ------------------------------------------------------------------------ + getSelector :: Frame -> String + getSelector = frmSel + ------------------------------------------------------------------------ + -- | get /subscription/ from 'Ack', 'Nack' or 'Message' + ------------------------------------------------------------------------ + getSub :: Frame -> String + getSub = frmSub + ------------------------------------------------------------------------ + -- | get /body/ from 'Send', 'Message', 'Error' + ------------------------------------------------------------------------ + getBody :: Frame -> B.ByteString + getBody = frmBody + ------------------------------------------------------------------------ + -- | get /content-type/ from 'Send', 'Message', 'Error' + ------------------------------------------------------------------------ + getMime :: Frame -> Mime.Type + getMime = frmMime + ------------------------------------------------------------------------ + -- | get /content-length/ from 'Send', 'Message', 'Error' + ------------------------------------------------------------------------ + getLength :: Frame -> Int + getLength = frmLen + ------------------------------------------------------------------------ + -- | get /message/ from 'Error' + ------------------------------------------------------------------------ + getMsg :: Frame -> String + getMsg = frmMsg + ------------------------------------------------------------------------ + -- | get all additional headers from 'Send' or 'Message' + ------------------------------------------------------------------------ + getHeaders :: Frame -> [Header] + getHeaders = frmHdrs + + ------------------------------------------------------------------------ + -- | The frame type identifies, what the Stomp protocol calls /command/; + -- + -- * commands sent from application to broker are: + -- Connect, Disconnect, Subscribe, Unsubscribe, Send, + -- Begin, Commit, Abort, Ack, Nack, HeartBeat + -- + -- * commands sent from broker to application are: + -- Connected, Message, Error, HeartBeat + ------------------------------------------------------------------------ + data FrameType = + -- | Sent by the application to initiate a connection + Connect + -- | Sent by the broker to confirm the connection + | Connected + -- | Sent by the application to end the connection + | Disconnect + -- | Sent by the application to publish a message in a queue + | Send + -- | Sent by the broker to forward a message + -- published in a queue to which + -- the application has subscribed + | Message + -- | Sent by the application to subscribe to a queue + | Subscribe + -- | Sent by the application to unsubscribe from a queue + | Unsubscribe + -- | Sent by the application to start a transaction + | Begin + -- | Sent by the application to commit a transaction + | Commit + -- | Sent by the application to abort a transaction + | Abort + -- | Sent by the application to acknowledge a message + | Ack + -- | Sent by the application to negatively acknowledge a message + | Nack + -- | Keep-alive message sent by both, application and broker + | HeartBeat + -- | Sent by the broker to report an error + | Error + -- | Sent by the broker to confirm the receipt of a frame + | Receipt + deriving (Show, Read, Eq) + + ------------------------------------------------------------------------ + -- | gets the 'FrameType' of a 'Frame' + ------------------------------------------------------------------------ + 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 + + ------------------------------------------------------------------------ + -- The AckMode of a Subscription + ------------------------------------------------------------------------ + data AckMode = + -- | A successfully sent message is automatically considered ack\'d + Auto + -- | The client is expected to explicitly confirm the receipt + -- of a message by sending an 'Ack' frame; + -- all message older than the ack'd message + -- since the last 'Ack' (or the beginning of the session) + -- are implicitly ack\'d as well. + -- This is called /cumulative/ ack. + | Client + -- | Non-cumulative ack: + -- The client is expected to explicitly confirm the receipt + -- of a message by sending an 'Ack' frame; + -- only the message with the msg-id in the 'Ack' frame + -- is actually ack\'d + | ClientIndi + deriving (Eq) + + instance Show AckMode where + show Auto = "auto" + show Client = "client" + show ClientIndi = "client-individual" + + instance Read AckMode where + readsPrec _ s = case upString s of + "AUTO" -> [(Auto, "")] + "CLIENT" -> [(Client, "")] + "CLIENT-INDIVIDUAL" -> [(ClientIndi, "")] + _ -> error $ "Can't parse AckMode: " ++ s + + infixr >|<, |>, <| + -- | append + (>|<) :: B.ByteString -> B.ByteString -> B.ByteString + -- | snoc + (|>) :: B.ByteString -> Char -> B.ByteString + -- | cons + (<|) :: Char -> B.ByteString -> B.ByteString + x >|< y = x `B.append` y + x <| y = x `B.cons` y + x |> y = x `B.snoc` y + + ---------------------------------------------------------------- + -- | check if 'String' represents a valid 'AckMode' + ---------------------------------------------------------------- + isValidAck :: String -> Bool + isValidAck s = upString s `elem` ["AUTO", "CLIENT", "CLIENT-INDIVIDUAL"] + + upString :: String -> String + upString = map toUpper + + numeric :: String -> Bool + numeric = all isDigit + + cleanWhite :: String -> String + cleanWhite = + takeWhile (/= ' ') . dropWhile (== ' ') + + getLen :: [Header] -> Either String Int + getLen hs = + case lookup hdrLen hs of + Nothing -> Right (-1) + Just l -> let len = cleanWhite l + in if numeric len then Right $ read len + else Left $ "content-length is not numeric: " ++ l + + getAck :: [Header] -> Either String AckMode + getAck hs = + case lookup hdrAck hs of + Nothing -> Right Auto + Just a -> if isValidAck a + then Right $ read a + else Left $ "Invalid ack header in Subscribe Frame: " + ++ a + + ------------------------------------------------------------------------ + -- | convert list of 'Version' to 'String' + ------------------------------------------------------------------------ + versToVal :: [Version] -> String + versToVal = foldr addVer "" . map verToVal + where addVer v vs = if not $ null vs + then v ++ "," ++ vs + else v + + ------------------------------------------------------------------------ + -- | convert 'Version' to 'String' + ------------------------------------------------------------------------ + verToVal :: Version -> String + verToVal (major, minor) = (show major) ++ "." ++ (show minor) + + ------------------------------------------------------------------------ + -- | convert 'String' to list of 'Version' + ------------------------------------------------------------------------ + valToVers :: String -> Maybe [Version] + valToVers s = case find (== Nothing) vs of + Nothing -> Just $ catMaybes vs + Just _ -> Nothing + where ss = splitWhen (== ',') s + vs = map valToVer ss + + ------------------------------------------------------------------------ + -- | convert 'String' to 'Version' + ------------------------------------------------------------------------ + valToVer :: String -> Maybe Version + valToVer v = if numeric major && numeric minor + then Just (read major, read minor) + else Nothing + where major = cleanWhite $ takeWhile (/= '.') v + minor = cleanWhite $ (drop 1 . dropWhile (/= '.')) v + + ------------------------------------------------------------------------ + -- | convert 'HeartBeat' to 'String' + ------------------------------------------------------------------------ + beatToVal :: Heart -> String + beatToVal (x, y) = (show x) ++ "," ++ (show y) + + ------------------------------------------------------------------------ + -- | convert 'String' to 'HeartBeat' + ------------------------------------------------------------------------ + valToBeat :: String -> Maybe Heart + valToBeat s = if numeric send && numeric recv + then Just (read send, read recv) + else Nothing + where send = (cleanWhite . takeWhile (/= ',')) s + recv = (cleanWhite . drop 1 . dropWhile (/= ',')) s + + ------------------------------------------------------------------------ + -- | convert 'SrvDesc' to 'String' + ------------------------------------------------------------------------ + srvToStr :: SrvDesc -> String + srvToStr (n, v, c) = n ++ "/" ++ v ++ c' + where c' = if null c then "" else " " ++ c + + ------------------------------------------------------------------------ + -- | convert 'String' to 'SrvDesc' + ------------------------------------------------------------------------ + strToSrv :: String -> SrvDesc + strToSrv s = (n, v, c) + where n = takeWhile (/= '/') s + v = takeWhile (/= ' ') $ drop (length n + 1) s + c = drop 1 $ dropWhile (/= ' ') s + + ------------------------------------------------------------------------ + -- | remove headers (list of 'String') from list of 'Header' + ------------------------------------------------------------------------ + rmHdrs :: [Header] -> [String] -> [Header] + rmHdrs = foldl' rmHdr + + ------------------------------------------------------------------------ + -- | remove header ('String') from list of 'Header' + ------------------------------------------------------------------------ + rmHdr :: [Header] -> String -> [Header] + rmHdr [] _ = [] + rmHdr ((k,v):hs) key | k == key = rmHdr hs key + | otherwise = (k,v) : rmHdr hs key + + ------------------------------------------------------------------------ + -- | convert 'AckMode' to 'String' + ------------------------------------------------------------------------ + ackToVal :: AckMode -> String + ackToVal = show + + ------------------------------------------------------------------------ + -- | convert 'String' to 'AckMode' + ------------------------------------------------------------------------ + valToAck :: String -> Maybe AckMode + valToAck s = if isValidAck s then Just $ read s else Nothing + + ------------------------------------------------------------------------ + -- | negotiates version - + -- if no common version is found, + -- the function results in version 1.0! + ------------------------------------------------------------------------ + negoVersion :: [Version] -> [Version] -> Version + negoVersion bs cs = nego bs' cs + where bs' = sortBy desc bs + desc = flip compare + nego [] _ = defVersion + nego _ [] = defVersion + nego (v:vs1) vs2 = if v `elem` vs2 then v else nego vs1 vs2 + + ------------------------------------------------------------------------ + -- | negotiates heart-beat + ------------------------------------------------------------------------ + negoBeat :: Heart -> Heart -> Heart + negoBeat hc hs = + let x = if sndC == 0 then 0 else max sndC sndS + y = if rcvC == 0 then 0 else max rcvC rcvS + in (x, y) + where sndC = fst hc + rcvC = snd hc + sndS = fst hs + rcvS = snd hs + + ------------------------------------------------------------------------ + -- | sets the transaction header to an empty string; + -- this is a useful function for brokers: + -- when a transaction has been committed, + -- the 'Send' messages can be handled by the same function + -- without, accidentally, iterating into a new transaction. + ------------------------------------------------------------------------ + resetTrans :: Frame -> Frame + resetTrans f = f {frmTrans = ""} + + ------------------------------------------------------------------------ + -- | converts a 'Frame' into a 'B.ByteString' + ------------------------------------------------------------------------ + putFrame :: Frame -> B.ByteString + putFrame BeatFrame = putCommand mkBeat + putFrame f = putCommand f >|< + putHeaders f >|< + putBody f + + ------------------------------------------------------------------------ + -- | converts a 'Frame' into a 'String' + ------------------------------------------------------------------------ + toString :: Frame -> String + toString = U.toString . putFrame + + ------------------------------------------------------------------------ + -- | converts the 'FrameType' into a 'B.ByteString' + ------------------------------------------------------------------------ + putCommand :: Frame -> B.ByteString + putCommand f = + let s = case typeOf f of + Connect -> "CONNECT" + Connected -> "CONNECTED" + Disconnect -> "DISCONNECT" + Send -> "SEND" + Subscribe -> "SUBSCRIBE" + Unsubscribe -> "UNSUBSCRIBE" + Begin -> "BEGIN" + Commit -> "COMMIT" + Abort -> "ABORT" + Ack -> "ACK" + Nack -> "NACK" + Message -> "MESSAGE" + Receipt -> "RECEIPT" + Error -> "ERROR" + HeartBeat -> "" + in B.pack (s ++ "\n") + + ------------------------------------------------------------------------ + -- Convert headers to ByteString + ------------------------------------------------------------------------ + putHeaders :: Frame -> B.ByteString + putHeaders f = + let hs = toHeaders f + s = B.concat $ map putHeader hs + in s |> '\n' + + ------------------------------------------------------------------------ + -- Convert header to ByteString + ------------------------------------------------------------------------ + putHeader :: Header -> B.ByteString + putHeader h = + let k = fst h + v = snd h + in U.fromString $ k ++ ":" ++ v ++ "\n" + + ------------------------------------------------------------------------ + -- Convert Frame attributes to headers + ------------------------------------------------------------------------ + toHeaders :: Frame -> [Header] + -- Connect Frame ------------------------------------------------------- + toHeaders (ConFrame l p h b v) = + [mkLogHdr l, mkPassHdr p, + mkAcVerHdr $ versToVal v, + mkBeatHdr $ beatToVal b, + mkHostHdr h] + -- Connected Frame ----------------------------------------------------- + toHeaders (CondFrame s b v d) = + [mkSesHdr s, + mkVerHdr $ verToVal v, + mkBeatHdr $ beatToVal b, + mkSrvHdr $ srvToStr d] + -- Disconnect Frame ----------------------------------------------------- + toHeaders (DisFrame r) = + if null r then [] else [mkRecHdr r] + -- Subscribe Frame ------------------------------------------------------ + toHeaders (SubFrame d a s i r) = + 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) + -- Unsubscribe Frame ---------------------------------------------------- + toHeaders (USubFrame d i r) = + 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 + -- Send Frame ----------------------------------------------------------- + toHeaders (SndFrame h 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 + -- Begin Frame ----------------------------------------------------------- + toHeaders (BgnFrame t r) = + let rh = if null r then [] else [mkRecHdr r] + in [mkTrnHdr t] ++ rh + -- Commit Frame ----------------------------------------------------------- + toHeaders (CmtFrame t r) = + let rh = if null r then [] else [mkRecHdr r] + in [mkTrnHdr t] ++ rh + -- Abort Frame ----------------------------------------------------------- + toHeaders (AbrtFrame t r) = + let rh = if null r then [] else [mkRecHdr r] + in [mkTrnHdr t] ++ rh + -- 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) + -- 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) + -- Message Frame ---------------------------------------------------------- + toHeaders (MsgFrame h 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 + -- Receipt Frame ---------------------------------------------------------- + toHeaders (RecFrame r) = [mkRecIdHdr r] + -- Error Frame ------------------------------------------------------------ + toHeaders (ErrFrame m r l t _) = + 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] + -- Beat Frame -------------------------------------------------------------- + toHeaders BeatFrame = [] + + ------------------------------------------------------------------------ + -- 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" + + ------------------------------------------------------------------------ + -- 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 + + ------------------------------------------------------------------------ + -- | make 'Connect' frame + ------------------------------------------------------------------------ + mkConFrame :: [Header] -> Either String Frame + mkConFrame hs = + let l = findStrHdr hdrLog "" hs + p = findStrHdr hdrPass "" hs + h = findStrHdr hdrHost "" hs + eiB = case lookup hdrBeat hs of + Nothing -> Right noBeat + Just x -> case valToBeat x of + Nothing -> Left $ "Not a valid heart-beat: " ++ x + Just b -> Right b + eiVs = case lookup hdrAcVer hs of + Nothing -> Right [] + Just v -> + case valToVers v of + Nothing -> Left $ "Not a valid version: " ++ v + 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 + + ------------------------------------------------------------------------ + -- | make 'Connected' frame + ------------------------------------------------------------------------ + mkCondFrame :: [Header] -> Either String Frame + mkCondFrame hs = + let s = findStrHdr hdrSes "0" hs + v = findStrHdr hdrVer defVerStr hs + d = case lookup hdrSrv hs of + Nothing -> noSrvDesc + Just x -> strToSrv x + eiB = case lookup hdrBeat hs of + Nothing -> Right noBeat + Just x -> case valToBeat x of + Nothing -> Left $ "Not a valid heart-beat: " ++ x + Just b -> Right b + in case valToVer v of + Nothing -> Left $ "Not a valid version: " ++ v + Just v' -> case eiB of + Left e -> Left e + Right b -> Right $ CondFrame s b v' d + + ------------------------------------------------------------------------ + -- | make 'Disconnect' frame + ------------------------------------------------------------------------ + mkDisFrame :: [Header] -> Either String Frame + mkDisFrame hs = + Right $ DisFrame (findStrHdr hdrRec "" hs) + + ------------------------------------------------------------------------ + -- | make 'Send' frame + ------------------------------------------------------------------------ + mkSndFrame :: [Header] -> Int -> Body -> Either String Frame + mkSndFrame hs l b = + case lookup hdrDest hs of + Nothing -> Left "No destination header in SEND Frame" + Just d -> Right $ SndFrame { + frmHdrs = rmHdrs hs [hdrMime, hdrTrn, hdrRec, + hdrDest, hdrLen], + frmDest = d, + frmLen = l, + frmMime = case lookup hdrMime hs of + Nothing -> defMime + Just t -> + case parseMIMEType t of + Nothing -> defMime + Just m -> m, + frmTrans = findStrHdr hdrTrn "" hs, + frmRec = findStrHdr hdrRec "" hs, + frmBody = b + } + + ------------------------------------------------------------------------ + -- | make 'Message' frame + ------------------------------------------------------------------------ + mkMsgFrame :: [Header] -> Int -> Body -> Either String Frame + mkMsgFrame hs l b = + case lookup hdrDest hs of + Nothing -> Left "No destination header in MESSAGE Frame" + 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 + } + + ------------------------------------------------------------------------ + -- | make 'Subscribe' frame + ------------------------------------------------------------------------ + mkSubFrame :: [Header] -> Either String Frame + mkSubFrame hs = + case lookup hdrDest hs of + 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} + + ------------------------------------------------------------------------ + -- | make 'Unsubscribe' frame + ------------------------------------------------------------------------ + mkUSubFrame :: [Header] -> Either String Frame + mkUSubFrame hs = + case lookup hdrDest hs of + 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} + + ------------------------------------------------------------------------ + -- | make 'Begin' frame + ------------------------------------------------------------------------ + 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} + + ------------------------------------------------------------------------ + -- | make 'Commit' frame + ------------------------------------------------------------------------ + 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} + + ------------------------------------------------------------------------ + -- | make 'Abort' frame + ------------------------------------------------------------------------ + 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} + + ------------------------------------------------------------------------ + -- | make 'Ack' frame + ------------------------------------------------------------------------ + 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 { + frmId = i, + frmSub = s, + frmTrans = t, + frmRec = r} + + ------------------------------------------------------------------------ + -- | make 'Nack' frame + ------------------------------------------------------------------------ + 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 { + frmId = i, + frmSub = s, + frmTrans = t, + frmRec = 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 + + ------------------------------------------------------------------------ + -- | 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} + + ------------------------------------------------------------------------ + -- | converts a 'Send' frame into a 'Message' frame; + -- parameters: + -- + -- * message id + -- + -- * subscription id + -- + -- * The original 'Send' frame + ------------------------------------------------------------------------ + sndToMsg :: String -> String -> Frame -> Maybe Frame + sndToMsg i sub f = case typeOf f of + Send -> + Just MsgFrame { + frmHdrs = frmHdrs f, + frmDest = frmDest f, + frmSub = sub, + frmLen = frmLen f, + frmMime = frmMime f, + frmId = i, + frmBody = frmBody f + } + _ -> Nothing + + ------------------------------------------------------------------------ + -- | converts a 'Connect' frame into a 'Connected' frame, + -- negotiating heart-beats and version; + -- parameters: + -- + -- * server desc + -- + -- * session id + -- + -- * caller's bid for heart-beat + -- + -- * caller's supported versions + -- + -- * the original 'Connect' frame + ------------------------------------------------------------------------ + conToCond :: String -> String -> Heart -> [Version] -> Frame -> Maybe Frame + conToCond s i b vs f = case typeOf f of + Connect -> + Just CondFrame { + frmSes = i, + frmBeat = negoBeat (frmBeat f) b, + frmVer = negoVersion vs $ frmAcVer f, + frmSrv = strToSrv s + } + _ -> Nothing + + ------------------------------------------------------------------------ + -- | Compliance with protocol version + ------------------------------------------------------------------------ + complies :: Version -> Frame -> Bool + complies v f = all (`elm` has) must + where must = getHdrs (typeOf f) v + has = toHeaders f + elm h hs = case lookup h hs of + Nothing -> False + Just _ -> True + + ------------------------------------------------------------------------ + -- Mandatory headers + ------------------------------------------------------------------------ + getHdrs :: FrameType -> Version -> [String] + getHdrs t v = + case t of + Connect -> case v of + (1,0) -> [] + (1,1) -> ["host", "accept-version"] + _ -> [] + Connected -> case v of + (1,0) -> ["session-id"] + (1,1) -> ["version"] + _ -> [] + Disconnect -> [] + Subscribe -> case v of + (1,0) -> ["destination"] + (1,1) -> ["id", "destination"] + _ -> [] + Unsubscribe -> case v of + (1,0) -> ["destination"] -- either dest or id + (1,1) -> ["id"] + _ -> [] + Send -> case v of + (1,0) -> ["destination"] + (1,1) -> ["destination"] + _ -> [] + Message -> case v of + (1,0) -> ["message-id", "destination"] + (1,1) -> ["message-id", "subscription", "destination"] + _ -> [] + Begin -> ["transaction"] + Commit -> ["transaction"] + Abort -> ["transaction"] + Ack -> case v of + (1,0) -> ["message-id"] + (1,1) -> ["message-id", "subscription"] + _ -> [] + Nack -> case v of + (1,1) -> ["message-id", "subscription"] + _ -> [] + Error -> [] + Receipt -> ["receipt-id"] + HeartBeat -> [] + diff --git a/Network/Mom/Stompl/Parser.hs b/Network/Mom/Stompl/Parser.hs new file mode 100644 --- /dev/null +++ b/Network/Mom/Stompl/Parser.hs @@ -0,0 +1,232 @@ +------------------------------------------------------------------------------- +-- | +-- 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, + startParsing, + continueParsing + ) +where + + import Data.Attoparsec hiding (take, takeWhile, takeTill) + import qualified Data.Attoparsec as A (takeWhile, takeTill) + import qualified Data.ByteString as B + import qualified Data.ByteString.UTF8 as U + import Data.Word + + import Control.Applicative ((<|>), (<$>)) + 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 + + ------------------------------------------------------------------------ + -- | The Stomp Parser + ------------------------------------------------------------------------ + stompParser :: Parser Frame + stompParser = do + t <- msgType + case t of + "" -> beat + "CONNECT" -> connect + "STOMP" -> connect + "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 (endAny) + 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 + + bodyFrame :: ([Header] -> Int -> Body -> Either String Frame) -> Parser Frame + bodyFrame mk = do + hs <- headers + 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 + + connect :: Parser Frame + connect = genericFrame mkConFrame + + connected :: Parser Frame + connected = genericFrame 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 + + genericFrame :: ([Header] -> Either String Frame) -> Parser Frame + genericFrame mk = do + hs <- headers + ignoreBody + case mk hs of + Left e -> fail e + Right m -> return m + + headers :: Parser [Header] + headers = reverse <$> headers' [] + + headers' :: [Header] -> Parser [Header] + headers' hs = do + skipWhite + endHeaders hs <|> getHeader hs + + endHeaders :: [Header] -> Parser [Header] + endHeaders hs = do + terminal + return hs + + getHeader :: [Header] -> Parser [Header] + getHeader hs = do + h <- header + headers' (h:hs) + + header :: Parser Header + header = do + k <- A.takeTill endAny + keyValSep + v <- A.takeTill endLine + terminal + return (U.toString k, U.toString v) + + keyValSep :: Parser () + keyValSep = do + skipWhite + _ <- takeWhile1 (== col) + skipWhite + + terminal :: Parser () + terminal = do + -- skipWhite + _ <- word8 eol + return () + + 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 |> '\x00') + + ignoreBody :: Parser () + ignoreBody = do + _ <- A.takeTill (== nul) + _ <- word8 nul + return () + + skipWhite :: Parser () + skipWhite = do + _ <- A.takeWhile (== spc) + return () + + endAny :: Word8 -> Bool + endAny w = (w == col || w == eol || w == spc || w == nul) + + endLine :: Word8 -> Bool + endLine = (== eol) + + nul, eol, spc, col :: Word8 + nul = 0 + eol = 10 + spc = 32 + col = 58 + + failBodyLen :: Int -> Int -> Parser a + failBodyLen l1 l2 = + fail $ "Body longer than indicated by content-length: " ++ + (show l1) ++ " - " ++ (show l2) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/license/lgpl-3.0.txt b/license/lgpl-3.0.txt new file mode 100644 --- /dev/null +++ b/license/lgpl-3.0.txt @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/stompl.cabal b/stompl.cabal new file mode 100644 --- /dev/null +++ b/stompl.cabal @@ -0,0 +1,46 @@ +Name: stompl +Category: Message-Oriented Middleware, Network, Stomp, Parser +Version: 0.0.1 +Cabal-Version: >= 1.8 +Copyright: Copyright (c) Tobias Schoofs, 2011 +License: LGPL +license-file: license/lgpl-3.0.txt +Author: Tobias Schoofs +Maintainer: Tobias Schoofs +Homepage: http://github.com/toschoo/stompl +Synopsis: Stomp Parser and Utilities +Build-Type: Simple +Description: + The Stomp Protocol specifies message-oriented interoperability. + Applications connect to a message broker to send (publish) + or receive (subscribe) messages through queues. + Interoperating applications do not know + the location or internal structure of each other. + They see only each other's interfaces, /i.e./ the messages + published and subscribed through the broker. + + Broker and application use a protocol based on the + exchange of commands and other data packets, called /frames/. + + The Stompl library provides abstractions over Stomp frames + and a Stomp frame parser. + It does not implement a client or broker itself, + but provides abstractions to libraries and programs doing so. + It is used by the Stompl Queue library (stomp-queues). + + More documentation and a test suite can be found on + . + The Stomp specification can be found at + . + +Library + Build-Depends: base >= 4.0 && < 5.0, + bytestring >= 0.9 && < 0.10, + utf8-string >= 0.3.6, + attoparsec >= 0.9.1.1, + split >= 0.1.4.1, + mime >= 0.3.3 + -- 3.0.3.2, + + Exposed-Modules: Network.Mom.Stompl.Frame, Network.Mom.Stompl.Parser +