-- | Provides a simple, clean monad to write websocket servers in{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings,
NoMonomorphismRestriction, Rank2Types, ScopedTypeVariables #-}moduleNetwork.WebSockets.Monad(WebSocketsOptions(..),defaultWebSocketsOptions,WebSockets(..),runWebSockets,runWebSocketsWith,runWebSocketsHandshake,runWebSocketsWithHandshake,runWebSocketsWith',receiveWith,sendWith,send,Sink,sendSink,getSink,getOptions,getProtocol,getVersion,throwWsError,catchWsError,spawnPingThread)whereimportControl.Applicative(Applicative,(<$>))importControl.Concurrent(forkIO,threadDelay)importControl.Concurrent.MVar(newMVar,withMVar)importControl.Exception(Exception(..),SomeException,throw)importControl.Monad(forever)importControl.Monad.Reader(ReaderT,ask,runReaderT)importControl.Monad.State(StateT,evalStateT,get)importControl.Monad.Trans(MonadIO,lift,liftIO)importBlaze.ByteString.Builder(Builder)importBlaze.ByteString.Builder.Enumerator(builderToByteString)importData.ByteString(ByteString)importData.Enumerator(Enumerator,Iteratee,($$),(>>==))importqualifiedData.Attoparsec.EnumeratorasAEimportqualifiedData.EnumeratorasEimportNetwork.WebSockets.Demultiplex(DemultiplexState,emptyDemultiplexState)importNetwork.WebSockets.HandshakeimportNetwork.WebSockets.Handshake.HttpimportNetwork.WebSockets.Handshake.ShyIterParserimportNetwork.WebSockets.MaskimportNetwork.WebSockets.ProtocolimportNetwork.WebSockets.TypesasT-- | Options for the WebSocket programdataWebSocketsOptions=WebSocketsOptions{onPong::IO()}-- | Default optionsdefaultWebSocketsOptions::WebSocketsOptionsdefaultWebSocketsOptions=WebSocketsOptions{onPong=return()}-- | Environment in which the 'WebSockets' monad actually runsdataWebSocketsEnvp=WebSocketsEnv{options::WebSocketsOptions,sendBuilder::Builder->IO(),protocol::p}-- | The monad in which you can write WebSocket-capable applicationsnewtypeWebSocketspa=WebSockets{unWebSockets::ReaderT(WebSocketsEnvp)(StateTDemultiplexState(IterateeByteStringIO))a}deriving(Applicative,Functor,Monad,MonadIO)-- | Receives the initial client handshake, then behaves like 'runWebSockets'.runWebSocketsHandshake::Protocolp=>(Request->WebSocketspa)->IterateeByteStringIO()->IterateeByteStringIOarunWebSocketsHandshake=runWebSocketsWithHandshakedefaultWebSocketsOptions-- | Receives the initial client handshake, then behaves like-- 'runWebSocketsWith'.runWebSocketsWithHandshake::Protocolp=>WebSocketsOptions->(Request->WebSocketspa)->IterateeByteStringIO()->IterateeByteStringIOarunWebSocketsWithHandshakeoptsgoWsoutIter=dohttpReq<-receiveIterateedecodeRequestrunWebSocketsWithoptshttpReqgoWsoutIter-- | Run a 'WebSockets' application on an 'Enumerator'/'Iteratee' pair, given-- that you (read: your web server) has already received the HTTP part of the-- initial request. If not, you might want to use 'runWebSocketsWithHandshake'-- instead.---- If the handshake failed, throws a 'HandshakeError'. Otherwise, executes the-- supplied continuation. You should still send a response to the client-- yourself.runWebSockets::Protocolp=>RequestHttpPart->(Request->WebSocketspa)->IterateeByteStringIO()->IterateeByteStringIOarunWebSockets=runWebSocketsWithdefaultWebSocketsOptions-- | Version of 'runWebSockets' which allows you to specify custom optionsrunWebSocketsWith::forallpa.Protocolp=>WebSocketsOptions->RequestHttpPart->(Request->WebSocketspa)->IterateeByteStringIO()->IterateeByteStringIOarunWebSocketsWithoptshttpReqgoWsoutIter=domreq<-receiveIterateeShy$tryFinishRequesthttpReqcasemreqof(Lefterr)->dosendIterateeencodeResponse(responseErrorprotoerr)outIterE.throwErrorerr(Right(r,p))->runWebSocketsWith'optsp(goWsr)outIterwhereproto::pproto=undefinedrunWebSocketsWith'::Protocolp=>WebSocketsOptions->p->WebSocketspa->IterateeByteStringIO()->IterateeByteStringIOarunWebSocketsWith'optsprotowsoutIter=dosendLock<-liftIO$newMVar()letsender=makeSendsendLockenv=WebSocketsEnvoptssenderprotostate=runReaderT(unWebSocketsws)enviter=evalStateTstateemptyDemultiplexStateiterwheremakeSendsendLockx=withMVarsendLock$\_->builderSenderoutIterx-- | @spawnPingThread n@ spawns a thread which sends a ping every @n@ seconds-- (if the protocol supports it). To be called after having sent the response.spawnPingThread::BinaryProtocolp=>Int->WebSocketsp()spawnPingThreadi=dosink<-getSink_<-liftIO$forkIO$forever$do-- An ugly hack here. We first sleep before sending the first-- ping, so the ping (hopefully) doesn't interfere with the-- intitial request/response.threadDelay(i*1000*1000)-- secondssendSinksink$ping("Hi"::ByteString)return()-- | Receive some data from the socket, using a user-supplied parser.receiveWith::Decoderpa->WebSocketspareceiveWith=liftIteratee.receiveIteratee-- todo: move some stuff to another module. "Decode"?-- | Underlying iteratee version of 'receiveWith'.receiveIteratee::Decoderpa->IterateeByteStringIOareceiveIterateeparser=doeof<-E.isEOFifeofthenE.throwErrorConnectionClosedelsewrappingParseError.AE.iterParser$parser-- | Like receiveIteratee, but if the supplied parser is happy with no input,-- we don't supply any more. This is very, very important when we have parsers-- that don't necessarily read data, like hybi10's completeRequest.receiveIterateeShy::Decoderpa->IterateeByteStringIOareceiveIterateeShyparser=wrappingParseError$shyIterParserparser-- | Execute an iteratee, wrapping attoparsec-enumeratee's ParseError into the-- ParseError constructor (which is a ConnectionError).wrappingParseError::(Monadm)=>Iterateeamb->IterateeambwrappingParseError=flipE.catchError$\e->E.throwError$maybee(toException.ParseError)$fromExceptionesendIteratee::Encoderpa->a->IterateeByteStringIO()->IterateeByteStringIO()sendIterateeencrespoutIter=doliftIO$mkSend(builderSenderoutIter)encresp-- | Low-leven sending with an arbitrary 'Encoder'sendWith::Encoderpa->a->WebSocketsp()sendWithencoderx=WebSockets$dosend'<-sendBuilder<$>askliftIO$mkSendsend'encoderx-- | Low-level sending with an arbitrary 'T.Message'send::Protocolp=>T.Messagep->WebSocketsp()sendmsg=getSink>>=\sink->liftIO$sendSinksinkmsg-- | Used for asynchronous sending.newtypeSinkp=Sink{unSink::Messagep->IO()}-- | Send a message to a sink. Might generate an exception if the underlying-- connection is closed.sendSink::Sinkp->Messagep->IO()sendSink=unSink-- | In case the user of the library wants to do asynchronous sending to the-- socket, he can extract a 'Sink' and pass this value around, for example,-- to other threads.getSink::Protocolp=>WebSocketsp(Sinkp)getSink=WebSockets$doproto<-unWebSocketsgetProtocolsend'<-sendBuilder<$>askreturn$Sink$mkSendsend'$encodeMessage$encodeFrameprotowhere-- TODO: proper multiplexing?encodeMessageframemaskmsg=framemask$casemsgof(ControlMessage(Closepl))->FrameTrueCloseFramepl(ControlMessage(Pingpl))->FrameTruePingFramepl(ControlMessage(Pongpl))->FrameTruePongFramepl(DataMessage(Textpl))->FrameTrueTextFramepl(DataMessage(Binarypl))->FrameTrueBinaryFramepl-- TODO: rename to mkEncodedSender?mkSend::(Builder->IO())->Encoderpa->a->IO()mkSendsend'encoderx=domask<-randomMasksend'$encodermaskxsingleton::Monadm=>a->Enumeratorambsingletonc=E.checkContinue0$\_f->f(E.Chunks[c])>>==E.returnIbuilderSender::MonadIOm=>IterateeByteStringmb->Builder->m()builderSenderoutIterx=dook<-E.run$singletonx$$builderToByteString$$outItercaseokofLefterr->throwerrRight_->return()-- | Get the current configurationgetOptions::WebSocketspWebSocketsOptionsgetOptions=WebSockets$ask>>=return.options-- | Get the underlying protocolgetProtocol::WebSocketsppgetProtocol=WebSockets$protocol<$>ask-- | Find out the 'WebSockets' version used at runtimegetVersion::Protocolp=>WebSocketspStringgetVersion=version<$>getProtocol-- | Throw an iteratee error in the WebSockets monadthrowWsError::(Exceptione)=>e->WebSocketspathrowWsError=liftIteratee.E.throwError-- | Catch an iteratee error in the WebSockets monadcatchWsError::WebSocketspa->(SomeException->WebSocketspa)->WebSocketspacatchWsErroractc=WebSockets$doenv<-askstate<-getletit=peelWebSocketsstateenv$actcit=peelWebSocketsstateenv.clift.lift$it`E.catchError`citwherepeelWebSocketsstateenv=flipevalStateTstate.fliprunReaderTenv.unWebSockets-- | Lift an Iteratee computation to WebSocketsliftIteratee::IterateeByteStringIOa->WebSocketspaliftIteratee=WebSockets.lift.lift