From 5572dbc8289de934e9ee5bc3f74a0f98365ce3e5 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 21 Apr 2017 17:42:10 -0400
Subject: initial http server

Incomplete, but the client is able to connect and send messages which
get logged.

Split up debug-me.hs into Role/*

Switched from cereal to binary, since websockets operate on lazy
ByteStrings, and using cereal would involve a copy on every receive.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
---
 WebSockets.hs | 113 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 113 insertions(+)
 create mode 100644 WebSockets.hs

(limited to 'WebSockets.hs')

diff --git a/WebSockets.hs b/WebSockets.hs
new file mode 100644
index 0000000..1f18b14
--- /dev/null
+++ b/WebSockets.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE OverloadedStrings, DeriveGeneric, GeneralizedNewtypeDeriving, FlexibleContexts #-}
+
+module WebSockets where
+
+import Types
+import Serialization
+
+import Control.Concurrent.STM
+import Control.Concurrent.Async
+import Control.Exception
+import qualified Data.Aeson
+import qualified Data.Binary
+import qualified Network.WebSockets as WS
+import qualified Data.Text as T
+import Data.List
+import Data.Maybe
+
+runClientApp :: WS.ClientApp a -> IO a
+runClientApp = WS.runClient "localhost" 8080 "/"
+
+-- | Make a client that sends and receives Messages over a websocket.
+clientApp
+	:: (Binary (Message sent), Binary (Message received))
+	=> Mode
+	-> (TChan (Message sent) -> TChan (Message received) -> IO a)
+	-> WS.ClientApp a
+clientApp mode a conn = bracket setup cleanup go
+  where
+	setup = do
+		schan <- newTChanIO
+		rchan <- newTChanIO
+		sthread <- async $ relayFromSocket conn $
+			atomically . writeTChan rchan
+		rthread <- async $ relayToSocket conn $
+			Just <$> atomically (readTChan schan)
+		return (schan, rchan, sthread, rthread)
+	cleanup (_, _, sthread, rthread) = do
+		cancel sthread
+		cancel rthread
+	go (schan, rchan, _, _) = do
+		print "sendWireVersions start"
+		print "negotiateWireVersion start"
+		_ <- negotiateWireVersion conn
+		--sendWireVersions conn
+		print "negotiateWireVersion done"
+		sendMode conn mode
+		print "sendmode now done"
+		a schan rchan
+
+relayFromSocket :: Binary (Message received) => WS.Connection -> (Message received -> IO ()) -> IO ()
+relayFromSocket conn send = go
+  where
+	go = do
+		dm <- WS.receiveDataMessage conn
+		case dm of
+			WS.Binary b -> case Data.Binary.decodeOrFail b of
+				Right (_, _, msg) -> do
+					send msg
+					go
+				Left (_, _, err) -> error $ "Deserialization error: " ++ err
+			WS.Text _ -> error "Unexpected Text received on websocket"
+
+relayToSocket :: Binary (Message sent) => WS.Connection -> (IO (Maybe (Message sent))) -> IO ()
+relayToSocket conn get = go
+  where
+	go = do
+		mmsg <- get
+		case mmsg of
+			Nothing -> return ()
+			Just msg -> do
+				WS.sendDataMessage conn $ WS.Binary $
+					Data.Binary.encode msg
+				go
+
+newtype WireVersion = WireVersion T.Text
+	deriving (Show, Eq, Generic, Ord)
+
+instance FromJSON WireVersion
+instance ToJSON WireVersion
+
+supportedWireVersions :: [WireVersion]
+supportedWireVersions = [WireVersion "1"]
+
+sendWireVersions :: WS.Connection -> IO ()
+sendWireVersions conn = WS.sendTextData conn (Data.Aeson.encode supportedWireVersions)
+
+-- | Send supportedWireVersions and at the same time receive it from
+-- the remote side. The highest version present in both lists will be used.
+negotiateWireVersion :: WS.Connection -> IO WireVersion
+negotiateWireVersion conn = do
+	remoteversions <- WS.receiveData conn
+	print ("got versions" :: String)
+	case Data.Aeson.decode remoteversions of
+		Nothing -> error "Protocol error: WireVersion list was not sent"
+		Just l -> case reverse (intersect (sort supportedWireVersions) (sort l)) of
+			(v:_) -> return v
+			[] -> error $ "Unable to negotiate a WireVersion. I support: " ++ show supportedWireVersions ++ " They support: " ++ show l
+
+-- | Modes of operation that can be requested for a websocket connection.
+data Mode
+	= InitMode T.Text
+	| ConnectMode T.Text
+	deriving (Show, Eq, Generic)
+
+instance FromJSON Mode
+instance ToJSON Mode where
+
+sendMode :: WS.Connection -> Mode -> IO ()
+sendMode conn mode = WS.sendTextData conn (Data.Aeson.encode mode)
+
+getMode :: WS.Connection -> IO Mode
+getMode conn = fromMaybe (error "Unknown mode") . Data.Aeson.decode
+	<$> WS.receiveData conn
-- 
cgit v1.2.3