urbit/pkg/hs/urbit-king/lib/Urbit/Vere/NounServ.hs

187 lines
5.4 KiB
Haskell
Raw Normal View History

2020-01-23 07:16:09 +03:00
{-|
Use websockets to pass nouns between a client and server.
-}
module Urbit.Vere.NounServ
( Conn(..)
, Server(..)
, Client(..)
, wsServer
, wsClient
, testIt
, wsServApp
, mkConn
, wsConn
) where
import Urbit.Prelude
import qualified Network.Wai.Handler.Warp as W
import qualified Network.WebSockets as WS
--------------------------------------------------------------------------------
data Conn i o = Conn
2020-01-23 07:16:09 +03:00
{ cRecv :: STM (Maybe i)
, cSend :: o -> STM ()
}
mkConn :: TBMChan i -> TBMChan o -> Conn i o
mkConn inp out = Conn (readTBMChan inp) (writeTBMChan out)
--------------------------------------------------------------------------------
data Client i o = Client
{ cConn :: Conn i o
, cAsync :: Async ()
}
data Server i o a = Server
{ sAccept :: STM (Maybe (Conn i o))
, sAsync :: Async ()
, sData :: a
}
--------------------------------------------------------------------------------
withRIOThread RIO e a RIO e (Async a)
withRIOThread act = do
env <- ask
io $ async $ runRIO env $ act
wsConn :: (FromNoun i, ToNoun o, Show i, Show o, HasLogFunc e)
2019-08-31 19:19:40 +03:00
=> Utf8Builder
-> TBMChan i -> TBMChan o
-> WS.Connection
-> RIO e ()
wsConn pre inp out wsc = do
2020-06-09 00:22:04 +03:00
logDebug (pre <> "(wcConn) Connected!")
writer <- withRIOThread $ forever $ do
2020-06-09 00:22:04 +03:00
logDebug (pre <> "(wsConn) Waiting for data.")
2019-08-31 19:19:40 +03:00
byt <- io $ toStrict <$> WS.receiveData wsc
2020-06-09 00:22:04 +03:00
logDebug (pre <> "Got data")
2019-08-31 19:19:40 +03:00
dat <- cueBSExn byt >>= fromNounExn
2020-06-09 00:22:04 +03:00
logDebug (pre <> "(wsConn) Decoded data, writing to chan")
2019-08-31 19:19:40 +03:00
atomically $ writeTBMChan inp dat
reader <- withRIOThread $ forever $ do
2020-06-09 00:22:04 +03:00
logDebug (pre <> "Waiting for data from chan")
2019-08-31 19:19:40 +03:00
atomically (readTBMChan out) >>= \case
Nothing -> do
2020-06-09 00:22:04 +03:00
logDebug (pre <> "(wsConn) Connection closed")
2019-08-31 19:19:40 +03:00
error "dead-conn"
Just msg -> do
2020-06-09 00:22:04 +03:00
logDebug (pre <> "(wsConn) Got message! " <> displayShow msg)
2019-08-31 19:19:40 +03:00
io $ WS.sendBinaryData wsc $ fromStrict $ jamBS $ toNoun msg
let cleanup = do
atomically (closeTBMChan inp >> closeTBMChan out)
cancel writer
cancel reader
2019-08-31 19:19:40 +03:00
flip finally cleanup $ do
res <- atomically (waitCatchSTM writer <|> waitCatchSTM reader)
logInfo $ displayShow (res :: Either SomeException ())
2019-08-31 19:19:40 +03:00
--------------------------------------------------------------------------------
wsClient :: i o e. (ToNoun o, FromNoun i, Show o, Show i, HasLogFunc e)
=> Text -> W.Port -> RIO e (Client i o)
wsClient pax por = do
env <- ask
inp <- io $ newTBMChanIO 5
out <- io $ newTBMChanIO 5
con <- pure (mkConn inp out)
logInfo "NOUNSERV (wsClie) Trying to connect"
tid <- io $ async
$ WS.runClient "127.0.0.1" por (unpack pax)
$ \con -> WS.withPingThread con 15 (pure ()) $
runRIO env (wsConn "NOUNSERV (wsClie) " inp out con)
pure $ Client con tid
2019-08-31 19:19:40 +03:00
--------------------------------------------------------------------------------
wsServApp :: (HasLogFunc e, ToNoun o, FromNoun i, Show i, Show o)
=> (Conn i o -> STM ())
-> WS.PendingConnection
-> RIO e ()
wsServApp cb pen = do
logInfo "NOUNSERV (wsServer) Got connection!"
wsc <- io $ WS.acceptRequest pen
inp <- io $ newTBMChanIO 5
out <- io $ newTBMChanIO 5
atomically $ cb (mkConn inp out)
wsConn "NOUNSERV (wsServ) " inp out wsc
wsServer :: i o e. (ToNoun o, FromNoun i, Show i, Show o, HasLogFunc e)
=> RIO e (Server i o W.Port)
wsServer = do
con <- io $ newTBMChanIO 5
2019-08-31 19:19:40 +03:00
tid <- async $ do
env <- ask
logInfo "NOUNSERV (wsServer) Starting server"
io $ WS.runServer "127.0.0.1" 9999
$ runRIO env . wsServApp (writeTBMChan con)
logInfo "NOUNSERV (wsServer) Server died"
2019-08-31 19:19:40 +03:00
atomically $ closeTBMChan con
2019-08-31 19:19:40 +03:00
pure $ Server (readTBMChan con) tid 9999
-- Hacky Integration Test ------------------------------------------------------
fromJust :: MonadIO m => Text -> Maybe a -> m a
fromJust err Nothing = error (unpack err)
fromJust _ (Just x) = pure x
type Example = Maybe (Word, (), Word)
example :: Example
example = Just (99, (), 44)
testIt :: HasLogFunc e => RIO e ()
testIt = do
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Starting Server"
Server{..} <- wsServer @Example @Example
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Connecting"
Client{..} <- wsClient @Example @Example "/" sData
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Accepting connection"
sConn <- fromJust "accept" =<< atomically sAccept
let
clientSend = do
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Sending from client"
atomically (cSend cConn example)
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Waiting for response"
res <- atomically (cRecv sConn)
2019-08-31 19:19:40 +03:00
print ("clientSend", res, example)
unless (res == Just example) $ do
error "Bad data"
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Success"
serverSend = do
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Sending from server"
atomically (cSend sConn example)
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Waiting for response"
res <- atomically (cRecv cConn)
2019-08-31 19:19:40 +03:00
print ("serverSend", res, example)
unless (res == Just example) $ do
error "Bad data"
2020-06-09 00:22:04 +03:00
logDebug "(testIt) Success"
clientSend
clientSend
clientSend
serverSend
serverSend
cancel sAsync
cancel cAsync