salvia-websocket (empty) → 1.0.0

raw patch · 4 files changed

+153/−0 lines, 4 filesdep +basedep +bytestringdep +fclabelssetup-changed

Dependencies added: base, bytestring, fclabels, monads-fd, salvia, salvia-protocol, stm, utf8-string

Files

LICENSE +28/−0
Setup.lhs +6/−0
salvia-websocket.cabal +27/−0
src/Network/Salvia/Handler/WebSocket.hs +92/−0

+ LICENSE view

@@ -0,0 +1,28 @@+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.+

+ Setup.lhs view

@@ -0,0 +1,6 @@+#! /usr/bin/env runhaskell++>import Distribution.Simple++>main = defaultMain+

+ salvia-websocket.cabal view

@@ -0,0 +1,27 @@+Name:             salvia-websocket+Version:          1.0.0+Description:      Websocket implementation for the Salvia Webserver.+Synopsis:         Websocket implementation for the Salvia Webserver.+Category:         Network, Web+License:          BSD3+License-file:     LICENSE+Author:           Sebastiaan Visser+Maintainer:       sfvisser@cs.uu.nl+Cabal-version:    >= 1.6+Build-Type:       Simple++Library+  GHC-Options:      -Wall+  HS-Source-Dirs:   src++  Build-Depends:    base ==4.*,+                    bytestring ==0.9.*,+                    salvia ==1.0.*,+                    salvia-protocol ==1.0.*,+                    fclabels ==0.4.*,+                    monads-fd ==0.0.*,+                    stm ==2.1.*,+                    utf8-string ==0.3.*++  Exposed-modules:  Network.Salvia.Handler.WebSocket+

+ src/Network/Salvia/Handler/WebSocket.hs view

@@ -0,0 +1,92 @@+{-# LANGUAGE FlexibleContexts, TypeOperators #-}+module Network.Salvia.Handler.WebSocket+( Protocol+, WebSocketT+, wsOrigin+, wsLocation+, wsProtocol+, hWebSocket+, hRecvFrameNonBlocking+, hSendFrame++, hOnMessage+, hSendTMVar+, hOnMessageUpdateTMVar+)+where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.State+import Data.Record.Label hiding (get)+import Network.Protocol.Http hiding (NotFound)+import Network.Salvia.Handlers+import Network.Salvia.Interface+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.UTF8 as U++type Protocol = String+type WebSocketT m a = StateT U.ByteString m a++wsOrigin, wsLocation, wsProtocol :: Http a :-> Maybe Value+wsOrigin   = header "WebSocket-Origin"+wsLocation = header "WebSocket-Location"+wsProtocol = header "WebSocket-Protocol"++hWebSocket :: (RawHttpM Request m, FlushM Response m, HttpM' m) => Value -> WebSocketT m a -> m a+hWebSocket proto act =+  do loc <- rawRequest (getM hostname)+     raw <- rawRequest (getM uri)+     org <- request (getM (header "Origin"))+     response $+       do headers    =: emptyHeaders+          status     =: CustomStatus 101 "Web Socket Protocol Handshake"+          upgrade    =: Just "WebSocket"+          connection =: Just "Upgrade"+          wsOrigin   =: org+          wsLocation =: fmap (("ws://" ++) . (++ raw)) loc +          wsProtocol =: Just proto+     hFlushResponseHeaders+     evalStateT act B.empty++hRecvFrameNonBlocking :: (MonadIO m, HandleM m) => Int -> StateT U.ByteString m (Maybe String)+hRecvFrameNonBlocking size =+  do prev <- get+     (frame, rest) <- lift $+       do s <- handle+          raw <- liftIO (B.hGetNonBlocking s size)+          let (first, rest) = B.break (== 0xFF) raw+          if not (B.null rest) && B.head rest == 0xFF+            then let frame = U.toString (B.dropWhile (== 0) (prev `B.append` first)) in+                 return (Just frame, B.tail rest)+            else return (Nothing, prev `B.append` first)+     put rest+     return frame++hSendFrame :: (FlushM Response m, SendM m) => String -> m ()+hSendFrame str =+  do sendBs (B.singleton 0x00)+     send str+     sendBs (B.singleton 0xFF)+     flushQueue forResponse++hOnMessage :: (HandleM m, MonadIO m) => Int -> (String -> m ()) -> WebSocketT m ()+hOnMessage ms act = forever $+  do lift . liftIO $ threadDelay (ms * 1000)+     frame <- hRecvFrameNonBlocking 100+     case frame of+       Nothing -> return ()+       Just f  -> lift (act f)++hSendTMVar :: (SendM m, MonadIO m, FlushM Response m, Eq a) => Int -> TMVar a -> (a -> String) -> m ()+hSendTMVar ms var f = loop Nothing+  where +  loop prev =+    do cur <- liftIO $ (threadDelay (ms * 1000) >> atomically (readTMVar var))+       when (Just cur /= prev) $ hSendFrame (f cur)+       loop (Just cur)++hOnMessageUpdateTMVar :: (HandleM m, MonadIO m) => Int -> (String -> a -> a) -> TMVar a -> WebSocketT m ()+hOnMessageUpdateTMVar ms f var =+  hOnMessage ms $ \msg -> (liftIO . atomically) (takeTMVar var >>= putTMVar var . (f msg))+