module Network.WebSockets.Monad
( WebSocketsOptions (..)
, defaultWebSocketsOptions
, WebSockets (..)
, runWebSockets
, runWebSocketsWith
, receive
, send
, Sender
, getSender
, getOptions
) where
import Control.Applicative ((<$>))
import Control.Concurrent.MVar (newMVar, takeMVar, putMVar)
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (forever, replicateM)
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.State (StateT, evalStateT)
import Control.Monad.Trans (MonadIO, lift, liftIO)
import System.Random (randomRIO)
import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.Enumerator (builderToByteString)
import Data.Attoparsec (Parser)
import Data.Attoparsec.Enumerator (iterParser)
import Data.ByteString (ByteString)
import Data.Enumerator ( Iteratee, Stream (..), checkContinue0, isEOF, returnI
, run, ($$), (>>==)
)
import qualified Data.ByteString as B
import Network.WebSockets.Demultiplex (DemultiplexState, emptyDemultiplexState)
import Network.WebSockets.Encode (Encoder)
import qualified Network.WebSockets.Encode as E
data WebSocketsOptions = WebSocketsOptions
{ onPong :: IO ()
, pingInterval :: Maybe Int
}
defaultWebSocketsOptions :: WebSocketsOptions
defaultWebSocketsOptions = WebSocketsOptions
{ onPong = return ()
, pingInterval = Just 10
}
data WebSocketsEnv = WebSocketsEnv WebSocketsOptions (Builder -> IO ())
newtype WebSockets a = WebSockets
{ unWebSockets :: ReaderT WebSocketsEnv
(StateT DemultiplexState (Iteratee ByteString IO)) a
} deriving (Functor, Monad, MonadIO)
runWebSockets :: WebSockets a
-> Iteratee ByteString IO ()
-> Iteratee ByteString IO a
runWebSockets = runWebSocketsWith defaultWebSocketsOptions
runWebSocketsWith :: WebSocketsOptions
-> WebSockets a
-> Iteratee ByteString IO ()
-> Iteratee ByteString IO a
runWebSocketsWith options ws outIter = do
sendLock <- liftIO $ newMVar ()
let sender = makeSend sendLock
env = WebSocketsEnv options sender
state = runReaderT (unWebSockets ws') env
iter = evalStateT state emptyDemultiplexState
iter
where
makeSend sendLock x = do
() <- takeMVar sendLock
_ <- run $ singleton x $$ builderToByteString $$ outIter
putMVar sendLock ()
singleton c = checkContinue0 $ \_ f -> f (Chunks [c]) >>== returnI
ws' = spawnPingThread >> ws
spawnPingThread :: WebSockets ()
spawnPingThread = do
sender <- getSender
options <- getOptions
case pingInterval options of
Nothing -> return ()
Just i -> do
_ <- liftIO $ forkIO $ forever $ do
sender E.ping ("Hi" :: ByteString)
threadDelay (i * 1000 * 1000)
return ()
receive :: Parser a -> WebSockets (Maybe a)
receive parser = WebSockets $ lift $ lift $ do
eof <- isEOF
if eof then return Nothing else fmap Just (iterParser parser)
send :: Encoder a -> a -> WebSockets ()
send encoder x = do
sender <- getSender
liftIO $ sender encoder x
type Sender a = Encoder a -> a -> IO ()
getSender :: WebSockets (Sender a)
getSender = WebSockets $ do
WebSocketsEnv _ send' <- ask
return $ \encoder x -> do
bytes <- replicateM 4 (liftIO randomByte)
send' (encoder (Just (B.pack bytes)) x)
where
randomByte = fromIntegral <$> randomRIO (0x00 :: Int, 0xff)
getOptions :: WebSockets WebSocketsOptions
getOptions = WebSockets $ ask >>= \(WebSocketsEnv options _) -> return options