module Network.Websocket( Config(..), ConfigRestriction(..), WS(..),
startServer, send ) where
import Char (chr)
import Control.Concurrent
import Control.Exception hiding (catch)
import Control.Monad
import Data.Char (isSpace)
import Data.Maybe
import qualified Network as N
import qualified Network.Socket as NS
import Network.Web.HTTP
import Network.URI
import Network.Web.Server
import System.IO
trim = f . f
where f = reverse.dropWhile isSpace
whenM b f = b >>= \b' -> when b' f
instance Show Request where
show req = let method = show $ reqMethod req
uri = show $ reqURI req
fields = show $ reqFields req
in method ++ " " ++ uri ++ "\n" ++ fields
data ConfigRestriction = Any | Only [String]
restrictionValid x Any = True
restrictionValid x (Only xs) = elem x xs
instance Eq Status
data Config = Config {
configPort :: Int,
configOrigins :: ConfigRestriction,
configDomains :: ConfigRestriction,
configOnOpen :: WS -> IO (),
configOnMessage :: WS -> String -> IO (),
configOnClose :: WS -> IO ()
}
data WS = WS {
wsConfig :: Config,
wsHandle :: Handle
}
listenLoop ws =
do onopen ws
(forever $ do
msg <- readFrame h
onmessage ws msg)
`catch`
(\e -> onclose ws)
return ()
where c = wsConfig ws
h = wsHandle 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)
hFlush h
send ws = sendFrame (wsHandle ws)
parseRequest req = do
upgrade <- lookupField (FkOther "Upgrade") req
origin <- lookupField (FkOther "Origin") req
host <- lookupField FkHost req
hostURI <- parseURI ("ws://" ++ host ++ "/")
hostAuth <- uriAuthority hostURI
let domain = uriRegName hostAuth
return (upgrade, origin, domain)
doWebSocket socket f =
bracket (do (h :: Handle, _, _) <- N.accept socket
maybeReq <- receive h
return (h, maybeReq))
(\(h,_) -> hClose h)
(\(h, maybeReq) ->
case maybeReq of
Nothing -> putStrLn "Got bad request"
Just req -> f h req)
sendHandshake h origin location = hPutStr h handshake >> hFlush h
where handshake = "HTTP/1.1 101 Web Socket Protocol Handshake\r\n\
\Upgrade: WebSocket\r\n\
\Connection: Upgrade\r\n\
\WebSocket-Origin: " ++ origin ++ "\r\n\
\WebSocket-Location: "++ show location ++ "\r\n\
\WebSocket-Protocol: sample\r\n\r\n"
accept config socket =
forever $ doWebSocket socket $ \h req ->
do let (upgrade, origin, hostDomain) = case parseRequest req of
Nothing -> throw (userError "Invalid request")
Just a -> a
location = (reqURI req) { uriScheme = "ws:" }
ws = WS { wsConfig = config, wsHandle = h }
return $ assert (upgrade == "WebSocket") ()
return $ assert (restrictionValid origin (configOrigins config)) ()
return $ assert (restrictionValid hostDomain (configDomains config)) ()
sendHandshake h origin location
onOpen ws
(forever $ do msg <- readFrame h
onMessage ws msg) `catch` (\e -> onClose ws)
where onOpen = configOnOpen config
onMessage = configOnMessage config
onClose = configOnClose config
startServer config =
do let port = N.PortNumber $ fromIntegral (configPort config)
socket <- N.listenOn port
accept config socket
NS.sClose socket
return ()