ghcjs-websockets (empty) → 0.3.0.0
raw patch · 5 files changed
+951/−0 lines, 5 filesdep +basedep +base64-bytestringdep +binarysetup-changed
Dependencies added: base, base64-bytestring, binary, bytestring, ghcjs-base, text
Files
- LICENSE +7/−0
- Setup.hs +2/−0
- ghcjs-websockets.cabal +103/−0
- src/JavaScript/WebSockets.hs +441/−0
- src/JavaScript/WebSockets/Internal.hs +398/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright (c) 2015 Justin Le++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghcjs-websockets.cabal view
@@ -0,0 +1,103 @@+name: ghcjs-websockets+version: 0.3.0.0+synopsis: GHCJS interface for the Javascript Websocket API+description:+ 'ghcjs-websockets' aims to provide a clean, idiomatic,+ efficient, low-level, out-of-your-way, bare bones,+ concurrency-aware interface with minimal abstractions+ over the Javascript Websockets API+ <http://www.w3.org/TR/websockets/>,+ inspired by common Haskell idioms found in libraries like+ 'io-stream'+ <http://hackage.haskell.org/package/io-streams> and the+ server-side 'websockets'+ <http://hackage.haskell.org/package/websockets> library,+ targeting compilation to Javascript with 'ghcjs'.+ .+ The interface asbtracts websockets as simple IO/file+ handles, with additional access to the natively "typed"+ (text vs binary) nature of the Javascript Websockets API.+ There are also convenience functions to directly decode+ serialized data (serialized with 'binary'+ <http://hackage.haskell.org/package/binary>) sent through+ channels.+ .+ The library is mostly intended to be a low-level FFI+ library, with the hopes that other, more advanced+ libraries maybe build on the low-level FFI bindings in+ order to provide more advanced and powerful abstractions.+ Most design decisions were made with the intent of+ keeping things as simple as possible in order for future+ libraries to abstract over it.+ .+ Most of the necessary functionality is in hopefully in+ 'JavaScript.WebSockets'; more of the low-level API is+ exposed in 'JavaScript.WebSockets.Internal' if you need+ it for library construction.+ .+ See the 'JavaScript.WebSockets' module for detailed usage+ instructions and examples.+ .+ Some examples:+ .+ > import Data.Text (unpack)+ >+ > -- A simple echo client, echoing all incoming text data+ > main :: IO ()+ > main = withUrl "ws://my-server.com" $ \conn ->+ > forever $ do+ > t <- receiveText conn+ > putStrLn (unpack t)+ > sendText conn t+ .+ > -- A simple client waiting for connections and outputting the running sum+ > main :: IO ()+ > main = withUrl "ws://my-server.com" (runningSum 0)+ >+ > runningSum :: Int -> Connection -> IO ()+ > runningSum n conn = do+ > i <- receiveData conn+ > print (n + i)+ > runningSum (n + i) conn+ .+ > -- Act as a relay between two servers+ > main :: IO ()+ > main = do+ > conn1 <- openConnection "ws://server-1.com"+ > conn2 <- openConnection "ws://server-2.com"+ > forever $ do+ > msg <- receiveMessage conn1+ > sendMessage conn2 msg+ > closeConnection conn2+ > closeConnection conn1++homepage: http://github.com/mstksg/ghcjs-websockets+license: MIT+license-file: LICENSE+author: Justin Le <justin@jle.im>+maintainer: Justin Le <justin@jle.im>+copyright: Copyright (c) Justin Le 2015+category: Web+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/mstksg/ghcjs-websockets++library+ exposed-modules: JavaScript.WebSockets+ , JavaScript.WebSockets.Internal+ -- ghcjs-options: -O2+ -- other-modules: + -- other-extensions: + ghc-options: -Wall+ build-depends: base >= 4.7 && < 5+ , base64-bytestring >= 1+ , binary >= 0.7+ , bytestring >= 0.10+ , ghcjs-base >= 0.1+ , text >= 1.2+ hs-source-dirs: src+ default-language: Haskell2010
+ src/JavaScript/WebSockets.hs view
@@ -0,0 +1,441 @@+-- |+-- Module : JavaScript.WebSockets+-- Copyright : (c) Justin Le 2015+-- License : MIT+--+-- Maintainer : justin@jle.im+-- Stability : unstable+-- Portability : ghcjs+--+-- Contains functions and operations for working with Javascript Websocket+-- connections, which are encapsulated in the 'Connection' object.+--+-- It includes operations for opening, closing, inspecting connections and+-- operations for sending and receiving text and serializable data+-- (instances of 'Binary') through them.+--+-- Most of the necessary functionality is in hopefully in+-- "JavaScript.WebSockets"; more of the low-level API is exposed in+-- "JavaScript.WebSockets.Internal" if you need it for library+-- construction.+--++module JavaScript.WebSockets (+ -- * Usage+ -- $usage+ -- * Types+ Connection+ , WSSendable+ , WSReceivable+ , SocketMsg(..)+ , ConnClosing(..)+ , ConnectionException(..)+ -- * Opening, closing, and working with connections+ , withUrl+ , withUrlLeftovers+ , openConnection+ , closeConnection+ , closeConnectionLeftovers+ , clearConnectionQueue+ , dumpConnectionQueue+ , connectionClosed+ , connectionCloseReason+ , connectionOrigin+ -- * Sending data+ -- $sending+ , sendData+ , sendData_+ , sendText+ , sendText_+ , sendMessage+ , sendMessage_+ , send+ , send_+ -- * Receiving data+ -- $receiving+ , receive+ , receiveMaybe+ , receiveText+ , receiveTextMaybe+ , receiveData+ , receiveDataMaybe+ , receiveMessage+ , receiveMessageMaybe+ , receiveEither+ , receiveEitherMaybe+ ) where++import Control.Applicative+import Control.Concurrent (readMVar)+import Control.Exception (bracket, throw)+import Control.Monad (void)+import Data.Binary (Binary)+import Data.Text (Text)+import JavaScript.WebSockets.Internal+++-- $usage+--+-- > import Data.Text (unpack)+-- >+-- > -- A simple echo client, echoing all incoming text data+-- > main :: IO ()+-- > main = withUrl "ws://my-server.com" $ \conn ->+-- > forever $ do+-- > t <- receiveText conn+-- > putStrLn (unpack t)+-- > sendText conn t+--+-- The above code will attempt to interpret all incoming data as+-- UTF8-encoded Text, and throw away data that does not.+--+-- @conn@ is a 'Connection', which encapsulates a websocket channel.+--+-- You can also do the same thing to interpret all incoming data as any+-- instance of 'Binary' --- say, 'Int's:+--+-- > -- A simple client waiting for connections and outputting the running sum+-- > main :: IO ()+-- > main = withUrl "ws://my-server.com" (runningSum 0)+-- >+-- > runningSum :: Int -> Connection -> IO ()+-- > runningSum n conn = do+-- > i <- receiveData conn+-- > print (n + i)+-- > runningSum (n + i) conn+--+-- 'receiveData' will block until the 'Connection' receives data that is+-- decodable as whatever type you expect, and will throw away all+-- nondecodable data (including 'Text' data).+--+-- The 'receive' function is provided as a over-indulgent layer of+-- abstraction where you can receive both 'Text' and instances of 'Binary'+-- with the same function using typeclass magic --- for the examples above,+-- you could use 'receive' in place of both 'receiveText' and+-- 'receiveData'.+--+-- 'send' works the same way for 'sendText' and 'sendData'.+--+-- If you want to, you can access the incoming data directly using the+-- 'SocketMsg' sum type, which exposes either a 'Text' or a lazy+-- 'ByteString':+--+-- > import Data.Text (unpack, append)+-- > import qualified Data.ByteString.Base64.Lazy as B64+-- >+-- > main :: IO ()+-- > main = withUrl "ws://my-server.com" $ \conn ->+-- > forever $ do+-- > msg <- receiveMessage+-- > putStrLn $ case msg of+-- > SocketMsgText t ->+-- > unpack $ append "Received text: " t+-- > SocketMsgData d ->+-- > "Received data: " ++ show (B64.encode d)+--+-- You can talk to multiple connections by nesting 'withUrl':+--+-- > -- Act as a relay between two servers+-- > main :: IO ()+-- > main = withUrl "ws://server-1.com" $ \conn1 ->+-- > withUrl "ws://server-2.com" $ \conn2 ->+-- > forever $ do+-- > msg <- receiveMessage conn1+-- > sendMessage conn2 msg+--+-- And also alternatively, you can manually open and close connections:+--+-- > -- Act as a relay between two servers+-- > main :: IO ()+-- > main = do+-- > conn1 <- openConnection "ws://server-1.com"+-- > conn2 <- openConnection "ws://server-2.com"+-- > forever $ do+-- > msg <- receiveMessage conn1+-- > sendMessage conn2 msg+-- > closeConnection conn2+-- > closeConnection conn1+--+-- 'receiveMessage' and its varieties will all throw an exception if the+-- connection closes while they're waiting or if you attempt to receive on+-- a closed connection. You can handle these with mechanisms from+-- "Control.Exception", or you can use their "maybe"-family counterparts,+-- 'receiveMessageMaybe', etc., who will return results in 'Just' on+-- a success, or return a 'Nothing' if the connection is closed or if+-- receiving on a closed connection.+--+-- You can use also @'connectionClosed' :: 'Connection' -> 'IO' 'Bool'@ to+-- check if the given 'Connection' object is closed (or+-- 'connectionCloseReason' to see *why*).+--+-- When closing connections, there might be some messages that were+-- received by the socket but never processed on the Haskell side with+-- a 'receive' method. These will normally be deleted; however, you can+-- use 'closeConnectionLeftovers' or 'withUrlLeftovers' to grab a list of+-- the raw 'SocketMsg's remaining after closing.++-- | Like 'withUrl', except returns also the "leftover messages" that were+-- received by the socket but never processed on the Haskell end with+-- 'receive'.+--+withUrlLeftovers :: Text -- ^ Websocket address to connect to+ -> (Connection -> IO a) -- ^ Process to run on connection+ -> IO (a, [SocketMsg]) -- ^ Result of process, with leftovers+withUrlLeftovers url process = withUrl url $ \conn ->+ liftA2 (,) (process conn) (dumpConnectionQueue conn)++-- | Performs the given @Connection -> IO a@ process attached to the given+-- server url. Handles opening and closing the 'Connection' for you (and+-- clearing the message queue afterwards), and cleans up on errors.+--+-- If any messages were received by the socket but never processed/received+-- on the Haskell end, this will delete and drop them. Use+-- 'withUrlLeftovers' to get a hold of them.+--+withUrl :: Text -- ^ Websocket address to connect to+ -> (Connection -> IO a) -- ^ Process to run on connection+ -> IO a+withUrl url = bracket (openConnection url) closeConnection++-- | Opens a websocket connection to the given url, and returns the+-- 'Connection' after connection is completed and opened. Care should be+-- taken to ensure that the 'Connection' is later closed with+-- 'closeConnection'.+--+-- Consider using 'withUrl', which handles closing with bracketing and+-- error handling so you don't have to worry about closing the connection+-- yourself.+--+-- Blocks until the connection has been established and opened.+--+-- If an async exception happens while this is waiting, the socket will be+-- closed as the exception bubbles up.+openConnection :: Text -> IO Connection+openConnection url = readMVar =<< openConnectionImmediate url++-- | Send the given serializable (instance of 'Binary') data on the given+-- connection.+--+-- Returns 'True' if the connection is open, and 'False' if it is closed.+-- In the future will return more feedback about whether or not the send+-- was completed succesfully.+sendData :: Binary a => Connection -> a -> IO Bool+sendData = send++-- | Send the given (strict) 'Text' on the given connection.+--+-- Returns 'True' if the connection is open, and 'False' if it is closed.+-- In the future will return more feedback about whether or not the send+-- was completed succesfully.+sendText :: Connection -> Text -> IO Bool+sendText = send++-- | Send the given serializable (instance of 'Binary') data on the given+-- connection.+--+-- Fails silently if the connection is closed or otherwise was not+-- succesful. Use 'sendData' to get feedback on the result of the send.+sendData_ :: Binary a => Connection -> a -> IO ()+sendData_ conn = void . sendData conn++-- | Send the given (strict) 'Text' on the given connection.+--+-- Fails silently if the connection is closed or otherwise was not+-- succesful. Use 'sendText' to get feedback on the result of the send.+sendText_ :: Connection -> Text -> IO ()+sendText_ conn = void . sendText conn++-- | Send the given item through the given 'Connection'.+--+-- You can 'send' either (strict) 'Text' or any instance of 'Binary',+-- due to over-indulgent typeclass magic; this is basically a function that+-- works everywhere you would use 'sendText' or 'sendData'.+--+-- Returns 'True' if the connection is open, and 'False' if it is closed.+-- In the future will return more feedback about whether or not the send+-- was completed succesfully.+send :: WSSendable a => Connection -> a -> IO Bool+send conn = sendMessage conn . wrapSendable++-- | Send the given item through the given 'Connection'.+--+-- You can 'send_' either (strict) 'Text' or any instance of 'Binary',+-- due to over-indulgent typeclass magic; this is basically a function that+-- works everywhere you would use 'sendText_' or 'sendData_'.+--+-- Fails silently if the connection is closed or otherwise was not+-- succesful. Use 'send' to get feedback on the result of the send.+send_ :: WSSendable a => Connection -> a -> IO ()+send_ conn = void . send conn++-- | Sends the given 'SocketMsg' through the given 'Connection'.+-- A 'SocketMsg' is a sum type of either 'SocketMsgText t', containing+-- (strict) 'Text', or 'SocketMsgData d', containing a (lazy) 'ByteString'.+--+-- Fails silently if the connection is closed or otherwise was not+-- succesful. Use 'sendMessage' to get feedback on the result of the send.+sendMessage_ :: Connection -> SocketMsg -> IO ()+sendMessage_ conn = void . sendMessage conn++-- | Block and wait until the 'Connection' receives a "typed" 'Text'. This+-- is determined by Javascript's own "typed" Websockets API+-- <http://www.w3.org/TR/websockets/>, which receives data typed either as+-- text or as a binary blob. Returns @Just t@ on the first encountered+-- text. Returns @Nothing@ if the 'Connection' closes while it is waiting,+-- or immediately if the connection is already closed and there are no+-- queued messages left.+--+-- All "binary blobs" encountered are discarded.+receiveTextMaybe :: Connection -> IO (Maybe Text)+receiveTextMaybe = receiveMaybe++-- | Block and wait until the 'Connection' receives a "binary blob"+-- decodable as the desired instance of 'Binary'. Returns @Just x@ as soon+-- as it is able to decode a blob, and @Nothing@ if the 'Connection' closes+-- while it is waiting. Returns @Nothing@ immediately if the 'Connection'+-- is already closed and there are no queued messages left.+--+-- All incoming messages received that cannot be decoded as the data type+-- (or are text) will be discarded.+--+-- This is polymorphic on its return type, so remember to let the type+-- inference system know what you want at some point or just give an+-- explicit type signature --- @receiveData conn :: IO (Maybe Int)@, for+-- example.+receiveDataMaybe :: Binary a => Connection -> IO (Maybe a)+receiveDataMaybe = receiveMaybe++-- | Block and wait until either something decodable as the desired type is+-- received (returning @Just x@), or the 'Connection' closes (returning+-- @Nothing@). Returns @Nothing@ immediately if the 'Connection' is+-- already closed and there are no queued messages left.+--+-- This is polymorphic on its return type, so remember to let the type+-- inference system know what you want at some point or just give an+-- explicit type signature --- @receiveData conn :: IO (Maybe Int)@, for+-- example.+--+-- All non-decodable or non-matching data that comes along is discarded.+--+-- You can 'receive' either (strict) 'Text' or any instance of 'Binary',+-- due to over-indulgent typeclass magic; this is basically a function that+-- works everywhere you would use 'receiveText' or 'receiveData'.+receiveMaybe :: WSReceivable a => Connection -> IO (Maybe a)+receiveMaybe conn = do+ d <- receiveEitherMaybe conn+ case d of+ Nothing -> return Nothing+ Just (Right d') -> return (Just d')+ Just _ -> receiveMaybe conn++-- | Block and wait until the 'Connection' receives a "typed" 'Text'. This+-- is determined by Javascript's own "typed" Websockets API+-- <http://www.w3.org/TR/websockets/>, which receives data+-- typed either as text or as a binary blob. Returns the first encountered+-- text. Throws a 'ConnectionException' if the 'Connection' closes first,+-- and throws one immediately if the connection is already closed and there+-- are no queued messages left.+--+-- All "binary blobs" encountered are discarded.+--+-- To handle closed sockets with 'Maybe', use 'receiveTextMaybe'.+receiveText :: Connection -> IO Text+receiveText = receive++-- | Block and wait until the 'Connection' receives a "binary blob"+-- decodable as the desired instance of 'Binary'. Returns the first+-- succesfully decoded data, and throws a 'ConnectionException' if the+-- 'Connection' closes first. Throws the exception immediately if the+-- 'Connection' is already closed and there are no queued messages left.+--+-- This is polymorphic on its return type, so remember to let the type+-- inference system know what you want at some point or just give an+-- explicit type signature --- @receiveData conn :: IO (Maybe Int)@, for+-- example.+--+-- All incoming messages received that cannot be decoded as the data type+-- (or are text) will be discarded.+--+-- To handle closed sockets with 'Maybe', use 'receiveDataMaybe'.+receiveData :: Binary a => Connection -> IO a+receiveData = receive++-- | Block and wait until either something decodable as the desired type is+-- received (returning it), or the 'Connection' closes (throwing+-- a 'ConnectionException'). Throws the exception immediately if the+-- 'Connection' is already closed and there are no queued messages left.+--+-- This is polymorphic on its return type, so remember to let the type+-- inference system know what you want at some point or just give an+-- explicit type signature --- @receiveData conn :: IO (Maybe Int)@, for+-- example.+--+-- All non-decodable or non-matching data that comes along is discarded.+--+-- You can 'receive' either (strict) 'Text' or any instance of 'Binary',+-- due to over-indulgent typeclass magic; this is basically a function that+-- works everywhere you would use 'receiveText' or 'receiveData'.+--+-- To handle closed sockets with 'Maybe', use 'receiveMaybe'.+receive :: WSReceivable a => Connection -> IO a+receive conn = do+ d <- receiveEither conn+ case d of+ Right d' -> return d'+ _ -> receive conn++-- | Block and wait until the 'Connection' receives any message, and+-- returns the message wrapped in a 'SocketMsg'. A 'SocketMsg' is a sum+-- type of either 'SocketMsgText t', containing (strict) 'Text', or+-- 'SocketMsgData d', containing a (lazy) 'ByteString'.+--+-- Will return the message as soon as any is received, or throw+-- a 'ConnectionException' if the connection is closed while waiting.+-- Throws an exception immediately if the connection is already closed.+--+-- To handle closed sockets with 'Maybe', use 'receiveMessageMaybe'.+receiveMessage :: Connection -> IO SocketMsg+receiveMessage conn = unjust <$> receiveMessageMaybe conn+ where+ unjust (Just i ) = i+ unjust Nothing = throw $ ConnectionClosed (_connOrigin conn)+++-- | Block and wait until the 'Connection' receives any message, and+-- attempts to decode it depending on the desired type. If 'Text' is+-- requested, assumes Utf8-encoded text or just a plain Javascript string.+-- If an instance of 'Binary' is requested, attempts to decode it into that+-- instance. Successful parses return 'Right x', and failed parses return+-- 'Left SocketMsg' (A sum type between 'SocketMsgText' containing (strict)+-- 'Text' and 'SocketMsgData' containing a (lazy) 'ByteString'). Nothing+-- is ever discarded.+--+-- Returns @Just result@ on the first message received, or @Nothing@ if the+-- 'Connection' closes while waiting. Returns @Nothing@ if the connection+-- is already closed and there are no queued messages left.+receiveEitherMaybe :: WSReceivable a => Connection -> IO (Maybe (Either SocketMsg a))+receiveEitherMaybe = (fmap . fmap) unwrapReceivable . receiveMessageMaybe++-- | Block and wait until the 'Connection' receives any message, and+-- attempts to decode it depending on the desired type. If 'Text' is+-- requested, assumes Utf8-encoded text or just a plain Javascript string.+-- If an instance of 'Binary' is requested, attempts to decode it into that+-- instance. Successful parses return 'Right x', and failed parses return+-- 'Left SocketMsg' (A sum type between 'SocketMsgText' containing (strict)+-- 'Text' and 'SocketMsgData' containing a (lazy) 'ByteString'). Nothing+-- is ever discarded.+--+-- Will return the message as soon as any is received, or throw+-- a 'ConnectionException' if the connection is closed while waiting.+-- Throws an exception immediately if the connection is already closed and+-- there are no queued messages left.+--+-- To handle closed sockets with 'Maybe', use 'receiveEitherMaybe'.+--+receiveEither :: WSReceivable a => Connection -> IO (Either SocketMsg a)+receiveEither = fmap unwrapReceivable . receiveMessage++-- | Returns the origin url of the given 'Connection'.+connectionOrigin :: Connection -> Text+connectionOrigin = _connOrigin+
+ src/JavaScript/WebSockets/Internal.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- Module : JavaScript.WebSockets.Internal+-- Copyright : (c) Justin Le 2015+-- License : MIT+--+-- Maintainer : justin@jle.im+-- Stability : unstable+-- Portability : ghcjs+--+--+-- Low-level API for the 'Connection' socket wrapper, for situations like+-- debugging when things exported by "JavaScript.WebSockets" is not enough.+-- Most everyday usage should be covered by the aforementioned module, so+-- don't import this unless you really really have to.+--++module JavaScript.WebSockets.Internal (+ -- * Types+ -- ** Data types+ Connection(..)+ , SocketMsg(..)+ , ConnClosing(..)+ -- ** Typeclasses+ , WSSendable(..)+ , WSReceivable(..)+ -- ** Exceptions+ , ConnectionException(..)+ -- * Manipulating and inspecting 'Connection's+ , openConnectionImmediate+ , closeConnection+ , closeConnectionLeftovers+ , clearConnectionQueue+ , dumpConnectionQueue+ , connectionClosed+ , connectionCloseReason+ , connectionStateCode+ -- * Sending and receiving+ , sendMessage+ , receiveMessageMaybe+ -- * Connection mutex+ , withConnBlock+ , withConnBlockMasked+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad (void, join, when)+import Data.Binary (Binary, encode, decodeOrFail)+import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (isJust, catMaybes)+import Data.Text as T (Text, unpack, append)+import Data.Text.Encoding (decodeUtf8', encodeUtf8, decodeUtf8)+import Data.Traversable (mapM)+import Data.Typeable (Typeable)+import GHCJS.Foreign+import GHCJS.Marshal (fromJSRef)+import GHCJS.Types (JSRef, JSString, isNull)+import JavaScript.Blob (Blob, isBlob, readBlob)+import JavaScript.WebSockets.FFI+import Prelude hiding (mapM)+import Unsafe.Coerce (unsafeCoerce)++import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Base64.Lazy as B64L++-- | Encapsulates a (reference to a) Javascript Websocket connection. Can+-- be created/accessed with either 'openConnection' or (preferably)+-- 'withUrl'.+--+-- Care must be taken to close the connection once you are done if using+-- 'openConnection', or unprocessed messages and callbacks will continue to+-- queue up.+--+data Connection = Connection { -- | JSRef to JS Websocket object+ _connSocket :: Socket+ -- | JSRef to JSArray of queued incoming+ -- messages, managed directly in FFI+ , _connQueue :: ConnectionQueue+ -- | JSRef to JSArray of queue of waiting+ -- receivers, managed directly in FFI+ , _connWaiters :: ConnectionWaiters+ -- | Text of server socket was originally+ -- opened with+ , _connOrigin :: Text+ -- | IORef with Nothing if the connection is+ -- still open and @Just reason@ if it's+ -- closed, with the reason+ , _connClosed :: IORef (Maybe ConnClosing)+ -- | Mutex for thread-safe manipulation+ , _connBlock :: MVar ()+ }++-- | Sum type over the data that can be sent or received through+-- a JavaScript websocket.+--+-- What an incoming message is classified as depends on the Javascript+-- Websockets API <http://www.w3.org/TR/websockets/>, which provides+-- a "typed" input channel of either text or binary blob.+--+-- There are several convenience functions to help you never have to deal+-- with this explicitly; its main purpose is if you want to explicitly+-- branch on a 'receiveMessage' depending on what kind of message you+-- receive and do separate things. 'receiveText' and 'receiveData' will+-- both allow you to "filter" incoming messages by their type.+data SocketMsg = SocketMsgText Text+ | SocketMsgData ByteString+ deriving (Show, Eq, Typeable)++-- | Data type containing information on 'Connection' closes.+--+-- * 'ManualClose': Closed by the Haskell 'JavaScript.WebSockets'+-- interface, using 'closeConnection' or variants.+--+-- * 'JSClose': Closed on the Javascript end, either by a connection error+-- or server request, or what have you. Contains information from the+-- Javascript Websockets API+-- <http://www.w3.org/TR/websockets/#event-definitions>.+--+-- The first field is whether or not it was a clean close; the second+-- field is the closing reason code; the third field is a 'Text' with+-- the reason given by the Websockets API.+--+-- * 'OpenInterupptedClose': There was an unexpected error encountered+-- when attempting to open the connection.+--+-- * 'UnexpectedClose': Otherwise uncategorized closed status, with+-- a 'Text' field offering a reason.+data ConnClosing = ManualClose+ | JSClose (Maybe Bool) (Maybe Int) (Maybe Text)+ | OpenInterruptedClose+ | UnexpectedClose Text+ deriving (Show, Eq)++-- | An exception that may be thrown when using the various 'Connection'+-- operations. Right now, only includes 'ConnectionClosed', which is+-- thrown when using an "unsafe" @receive@ on a closed 'Connection', or if+-- a 'Connection' closes while an unsafe @receive@ is waiting.+data ConnectionException = ConnectionClosed { _socketOrigin :: Text }+ deriving (Eq, Typeable)+-- TODO: Other exceptions! Open? Send?++instance Show ConnectionException where+ show (ConnectionClosed o) = T.unpack $ T.append "Error: Waiting on closed connection " o+instance Exception ConnectionException++-- | A typeclass offering a gratuitous abstraction over what can be sent+-- through a 'Connection'. Allows you to wrap things in a 'SocketMsg'+-- automatically. The only instances that should really ever exist are+-- 'Text' and instances of 'Binary'.+class WSSendable s where+ wrapSendable :: s -> SocketMsg++-- | A typeclass offering a gratuitous abstraction over what can be+-- received through a 'Connection'. Allows you to unwrap things in+-- a 'SocketMsg' automatically. The only instances that should really ever+-- exist are 'Text' and instances of 'Binary'.+class WSReceivable s where+ unwrapReceivable :: SocketMsg -> Either SocketMsg s++instance WSSendable Text where+ wrapSendable = SocketMsgText++instance Binary a => WSSendable a where+ wrapSendable = SocketMsgData . encode++instance WSReceivable Text where+ unwrapReceivable (SocketMsgText t) = Right t+ unwrapReceivable i@(SocketMsgData d) = f . decodeUtf8' . toStrict $ d+ where+ f (Right t) = Right t+ f _ = Left i++instance Binary a => WSReceivable a where+ unwrapReceivable inc =+ case decodeOrFail bs of+ Right (_,_,x) -> Right x+ Left _ -> Left inc+ where+ bs = case inc of+ SocketMsgText t -> fromStrict (encodeUtf8 t)+ SocketMsgData d -> d++-- | A version of 'openConnection' that doesn't wait for the connection to+-- be opened. Returns an 'MVar' where the connection can be expected to be+-- placed when it is opened.+openConnectionImmediate :: Text -> IO (MVar Connection)+openConnectionImmediate url = do+ queue <- newArray+ waiters <- newArray+ socket <- ws_newSocket (toJSString url) queue waiters+ closed <- newIORef Nothing+ block <- newMVar ()+ let conn = Connection socket queue waiters url closed block+ outp <- newEmptyMVar+ _ <- forkIO $ handleClose conn+ -- TODO: Opening errors+ _ <- forkIO $ handleOpen conn outp+ return outp++_dudConnection :: Text -> ConnClosing -> IO Connection+_dudConnection url closing = Connection jsNull+ <$> newArray+ <*> newArray+ <*> pure url+ <*> newIORef (Just closing)+ <*> newMVar ()++handleOpen :: Connection -> MVar Connection -> IO ()+handleOpen conn connMVar =+ bracketOnError (return ())+ (\_ -> _closeConnection OpenInterruptedClose False conn)+ $ \_ -> do+ _ <- ws_handleOpen (_connSocket conn)+ putMVar connMVar conn++handleClose :: Connection -> IO ()+handleClose conn = do+ connState <- connectionStateCode conn+ when (connState < 3) . handle handler $ do+ closeEvent <- ws_handleClose (_connSocket conn)+ wasClean <- fmap fromJSBool <$> getPropMaybe ("wasClean" :: Text) closeEvent+ code <- fmap join . mapM fromJSRef =<< getPropMaybe ("code" :: Text) closeEvent+ reason <- fmap fromJSString <$> getPropMaybe ("reason" :: Text) closeEvent+ let jsClose = JSClose wasClean code reason+ _ <- _closeConnection jsClose False conn+ return ()+ where+ -- TODO: any way to reasonably restore the handler?+ handler :: SomeAsyncException -> IO ()+ handler _ = void $ _closeConnection (UnexpectedClose reason) False conn+ where+ reason = "Close handler interrupted with Asynchronous Exception."++-- | Manually closes the given 'Connection'. It un-blocks all threads+-- currently waiting on the connection and disables all sending and+-- receiving in the future.+--+-- The result is a list of all messages received by the connection but not+-- yet retrieved by 'receive', etc. on the Haskell end.+--+-- To close and ignore leftovers, use 'closeConnection'.+--+closeConnectionLeftovers :: Connection -> IO [SocketMsg]+closeConnectionLeftovers = _closeConnection ManualClose True++-- | Manually closes the given 'Connection'. Will un-block all threads+-- currently waiting on the 'Connection' for messages (releasing their+-- callbacks) and disable sending and receiving in the future.+--+-- All leftover messages that were never processed on the Haskell end will+-- be deleted; use 'dumpConnectionQueue' to manually fetch them before+-- closing, or 'closeConnectionLeftovers' to recover them while closing.+closeConnection :: Connection -> IO ()+closeConnection = void . _closeConnection ManualClose False++_closeConnection :: ConnClosing -> Bool -> Connection -> IO [SocketMsg]+_closeConnection cclsing dump conn = withConnBlockMasked conn $ do+ closed <- isJust <$> readIORef (_connClosed conn)+ connState <- connectionStateCode conn+ if closed || connState < 3+ then+ return []+ else do+ writeIORef (_connClosed conn) (Just cclsing)+ ws_closeSocket (_connSocket conn)+ ws_clearWaiters (_connWaiters conn)+ outp <- if dump+ then _dumpConnectionQueue conn+ else [] <$ ws_clearQueue (_connQueue conn)+ return outp++-- | Clears the message queue (messages waiting to be 'receive'd) on the+-- given 'Connection'. Is essentially a no-op on closed connections.+clearConnectionQueue :: Connection -> IO ()+clearConnectionQueue conn = withConnBlockMasked conn $ do+ closed <- isJust <$> readIORef (_connClosed conn)+ when closed $ ws_clearQueue (_connQueue conn)++-- | Returns all incoming messages received by the socket and queued for+-- retrieval using 'receive' functions. Empties the queue.+dumpConnectionQueue :: Connection -> IO [SocketMsg]+dumpConnectionQueue conn = withConnBlockMasked conn $+ _dumpConnectionQueue conn++-- | Execute process with the connection mutex lock in effect. Will wait+-- until the lock is released before starting, if lock was already in+-- place.+--+-- Will break almost every 'Connection' function if you run one while this+-- is in effect, because almost all of them require the lock to begin.+withConnBlock :: Connection -> IO a -> IO a+withConnBlock conn f = withMVar (_connBlock conn) (const f)++-- | Execute process with the connection mutex lock in effect, with+-- asynchronos exceptions masked (See "Control.Exception"). Will wait+-- until the lock is released before starting, if lock was already in+-- place.+--+-- Will break almost every 'Connection' function if you run one while this+-- is in effect, because almost all of them require the lock to begin.+withConnBlockMasked :: Connection -> IO a -> IO a+withConnBlockMasked conn f = withMVarMasked (_connBlock conn) (const f)++_dumpConnectionQueue :: Connection -> IO [SocketMsg]+_dumpConnectionQueue conn = do+ msgsRefs <- fromArray (_connQueue conn)+ results <- catMaybes <$> mapM _loadJSMessage msgsRefs+ ws_clearQueue (_connQueue conn)+ return results+++-- | Check if the given 'Connection' is closed. Returns a 'Bool'. To+-- check *why* it was closed, see 'connectionCloseReason'.+connectionClosed :: Connection -> IO Bool+connectionClosed = fmap isJust . connectionCloseReason++-- | Returns @Nothing@ if the given 'Connection' is still open, or @Just+-- closing@ containing a 'ConnClosing' with information on why the+-- connection was closed.+--+-- For just a 'Bool' saying whether or not the connection is closed, try+-- 'connectionClosed'.+connectionCloseReason :: Connection -> IO (Maybe ConnClosing)+connectionCloseReason conn = withConnBlock conn $+ readIORef (_connClosed conn)++-- | Returns the "readyState" of the connection's javascript websockets+-- API: 0 is connecting, 1 is open, 2 is closing, and 3 is closed.+-- Shouldn't really be used except for debugging purposes. Use+-- 'connectionCloseReason' whenever possible to get information in a nice+-- haskelley sum type.+connectionStateCode :: Connection -> IO Int+connectionStateCode conn = withConnBlock conn $+ ws_readyState (_connSocket conn)++-- | Sends the given 'SocketMsg' through the given 'Connection'.+-- A 'SocketMsg' is a sum type of either 'SocketMsgText t', containing+-- (strict) 'Text', or 'SocketMsgData d', containing a (lazy) 'ByteString'.+--+-- Returns 'True' if the connection is open, and 'False' if it is closed.+-- In the future will return more feedback about whether or not the send+-- was completed succesfully.+sendMessage :: Connection -> SocketMsg -> IO Bool+sendMessage conn msg = do+ closed <- connectionClosed conn+ if closed+ then+ return False+ else do+ -- TODO: Validate send here+ ws_socketSend (_connSocket conn) (outgoingData msg)+ return True+ where+ outgoingData (SocketMsgText t) = toJSString . decodeUtf8 . B64.encode . encodeUtf8 $ t+ outgoingData (SocketMsgData d) = toJSString . decodeUtf8 . toStrict . B64L.encode $ d++-- | Block and wait until the 'Connection' receives any message, and+-- returns the message wrapped in a 'SocketMsg'. A 'SocketMsg' is a sum+-- type of either 'SocketMsgText t', containing (strict) 'Text', or+-- 'SocketMsgData d', containing a (lazy) 'ByteString'.+--+-- Will return 'Just msg' as soon as any message is received, or 'Nothing'+-- if the 'Connection' closes first. Returns 'Nothing' immediately if the+-- 'Connection' is already closed.+receiveMessageMaybe :: Connection -> IO (Maybe SocketMsg)+receiveMessageMaybe conn = do+ closed <- connectionClosed conn+ if closed+ then return Nothing+ else do+ waiterKilled <- newObj+ -- set to ignore waiter if thread has died+ msg <- ws_awaitConn (_connQueue conn) (_connWaiters conn) waiterKilled+ `onException` setProp ("k" :: JSString) jsTrue waiterKilled+ _loadJSMessage msg++_loadJSMessage :: JSRef a -> IO (Maybe SocketMsg)+_loadJSMessage msg | isNull msg = return Nothing+ | otherwise = do+ blb <- isBlob msg+ if blb+ then do+ let blob = unsafeCoerce msg :: Blob+ readed <- fromStrict <$> readBlob blob+ return (Just (SocketMsgData readed))+ else do+ let blob = unsafeCoerce msg :: JSString+ return . Just . SocketMsgText . fromJSString $ blob+