module Network.Websocket( Config(..), WS(..), startServer, send) where
import Char
import Control.Concurrent
import Control.Monad (forever)
import qualified Network as N
import qualified Network.Socket as NS
import System.IO
data Config = Config {
configPort :: Int,
configOrigin :: String,
configLocation :: String,
configOnOpen :: WS -> IO (),
configOnMessage :: WS -> String -> IO (),
configOnClose :: WS -> IO ()
}
data WS = WS {
config :: Config,
handle :: Handle
}
listenLoop ws =
do onopen ws
(forever $ do
msg <- readFrame h
onmessage ws msg) `catch` (\e -> onclose ws)
where c = config ws
h = handle ws
onopen = configOnOpen c
onmessage = configOnMessage c
onclose = configOnClose c
readFrame :: Handle -> IO String
readFrame h = readUntil h ""
where readUntil h str =
do new <- hGetChar h
if new == chr 0
then readUntil h ""
else if new == chr 255
then return str
else readUntil h (str ++ [new])
sendFrame :: Handle -> String -> IO ()
sendFrame h s = do
hPutChar h (chr 0)
hPutStr h s
hPutChar h (chr 255)
send ws = sendFrame (handle ws)
accept config socket =
forever $ do
(h, _, _) <- N.accept socket
hPutStr h handshake
hSetBuffering h NoBuffering
let ws = WS { config = config, handle = h }
forkIO $ listenLoop ws
where handshake = "HTTP/1.1 101 Web Socket Protocol Handshake\r\n\
\Upgrade: WebSocket\r\n\
\Connection: Upgrade\r\n\
\WebSocket-Origin: " ++ (configOrigin config) ++ "\r\n\
\WebSocket-Location: "++ (configLocation config) ++ "\r\n\
\WebSocket-Protocol: sample\r\n\r\n"
startServer config =
do let port = N.PortNumber $ fromIntegral (configPort config)
socket <- N.listenOn port
accept config socket
NS.sClose socket
return ()