mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-09-20 23:18:00 +03:00
king: Minor cleanup.
This commit is contained in:
parent
1f4c823d92
commit
957f14ee40
@ -55,24 +55,24 @@ wsConn :: (FromNoun i, ToNoun o, Show i, Show o, HasLogFunc e)
|
||||
-> WS.Connection
|
||||
-> RIO e ()
|
||||
wsConn pre inp out wsc = do
|
||||
logWarn (pre <> "(wcConn) Connected!")
|
||||
logDebug (pre <> "(wcConn) Connected!")
|
||||
|
||||
writer <- withRIOThread $ forever $ do
|
||||
logWarn (pre <> "(wsConn) Waiting for data.")
|
||||
logDebug (pre <> "(wsConn) Waiting for data.")
|
||||
byt <- io $ toStrict <$> WS.receiveData wsc
|
||||
logWarn (pre <> "Got data")
|
||||
logDebug (pre <> "Got data")
|
||||
dat <- cueBSExn byt >>= fromNounExn
|
||||
logWarn (pre <> "(wsConn) Decoded data, writing to chan")
|
||||
logDebug (pre <> "(wsConn) Decoded data, writing to chan")
|
||||
atomically $ writeTBMChan inp dat
|
||||
|
||||
reader <- withRIOThread $ forever $ do
|
||||
logWarn (pre <> "Waiting for data from chan")
|
||||
logDebug (pre <> "Waiting for data from chan")
|
||||
atomically (readTBMChan out) >>= \case
|
||||
Nothing -> do
|
||||
logWarn (pre <> "(wsConn) Connection closed")
|
||||
logDebug (pre <> "(wsConn) Connection closed")
|
||||
error "dead-conn"
|
||||
Just msg -> do
|
||||
logWarn (pre <> "(wsConn) Got message! " <> displayShow msg)
|
||||
logDebug (pre <> "(wsConn) Got message! " <> displayShow msg)
|
||||
io $ WS.sendBinaryData wsc $ fromStrict $ jamBS $ toNoun msg
|
||||
|
||||
let cleanup = do
|
||||
@ -82,7 +82,7 @@ wsConn pre inp out wsc = do
|
||||
|
||||
flip finally cleanup $ do
|
||||
res <- atomically (waitCatchSTM writer <|> waitCatchSTM reader)
|
||||
logWarn $ displayShow (res :: Either SomeException ())
|
||||
logDebug $ displayShow (res :: Either SomeException ())
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -111,7 +111,7 @@ wsServApp :: (HasLogFunc e, ToNoun o, FromNoun i, Show i, Show o)
|
||||
-> WS.PendingConnection
|
||||
-> RIO e ()
|
||||
wsServApp cb pen = do
|
||||
logError "NOUNSERV (wsServer) Got connection!"
|
||||
logDebug "NOUNSERV (wsServer) Got connection!"
|
||||
wsc <- io $ WS.acceptRequest pen
|
||||
inp <- io $ newTBMChanIO 5
|
||||
out <- io $ newTBMChanIO 5
|
||||
@ -125,10 +125,10 @@ wsServer = do
|
||||
|
||||
tid <- async $ do
|
||||
env <- ask
|
||||
logError "NOUNSERV (wsServer) Starting server"
|
||||
logDebug "NOUNSERV (wsServer) Starting server"
|
||||
io $ WS.runServer "127.0.0.1" 9999
|
||||
$ runRIO env . wsServApp (writeTBMChan con)
|
||||
logError "NOUNSERV (wsServer) Server died"
|
||||
logDebug "NOUNSERV (wsServer) Server died"
|
||||
atomically $ closeTBMChan con
|
||||
|
||||
pure $ Server (readTBMChan con) tid 9999
|
||||
@ -147,34 +147,34 @@ example = Just (99, (), 44)
|
||||
|
||||
testIt :: HasLogFunc e => RIO e ()
|
||||
testIt = do
|
||||
logTrace "(testIt) Starting Server"
|
||||
logDebug "(testIt) Starting Server"
|
||||
Server{..} <- wsServer @Example @Example
|
||||
logTrace "(testIt) Connecting"
|
||||
logDebug "(testIt) Connecting"
|
||||
Client{..} <- wsClient @Example @Example "/" sData
|
||||
|
||||
logTrace "(testIt) Accepting connection"
|
||||
logDebug "(testIt) Accepting connection"
|
||||
sConn <- fromJust "accept" =<< atomically sAccept
|
||||
|
||||
let
|
||||
clientSend = do
|
||||
logTrace "(testIt) Sending from client"
|
||||
logDebug "(testIt) Sending from client"
|
||||
atomically (cSend cConn example)
|
||||
logTrace "(testIt) Waiting for response"
|
||||
logDebug "(testIt) Waiting for response"
|
||||
res <- atomically (cRecv sConn)
|
||||
print ("clientSend", res, example)
|
||||
unless (res == Just example) $ do
|
||||
error "Bad data"
|
||||
logInfo "(testIt) Success"
|
||||
logDebug "(testIt) Success"
|
||||
|
||||
serverSend = do
|
||||
logTrace "(testIt) Sending from server"
|
||||
logDebug "(testIt) Sending from server"
|
||||
atomically (cSend sConn example)
|
||||
logTrace "(testIt) Waiting for response"
|
||||
logDebug "(testIt) Waiting for response"
|
||||
res <- atomically (cRecv cConn)
|
||||
print ("serverSend", res, example)
|
||||
unless (res == Just example) $ do
|
||||
error "Bad data"
|
||||
logInfo "(testIt) Success"
|
||||
logDebug "(testIt) Success"
|
||||
|
||||
clientSend
|
||||
clientSend
|
||||
|
@ -24,7 +24,6 @@ import Urbit.Arvo
|
||||
import Urbit.King.Config
|
||||
import Urbit.Vere.Pier.Types
|
||||
|
||||
import Data.Text (append)
|
||||
import System.Posix.Files (ownerModes, setFileMode)
|
||||
import Urbit.King.App (HasKingEnv, HasPierEnv(..), PierEnv)
|
||||
import Urbit.King.App (onKillPierSigL)
|
||||
@ -240,7 +239,6 @@ acquireWorker nam act = mkRAcquire (async act) kill
|
||||
kill tid = do
|
||||
logTrace ("Killing worker thread: " <> display nam)
|
||||
cancel tid
|
||||
logTrace ("Killed worker thread: " <> display nam)
|
||||
|
||||
acquireWorkerBound :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
|
||||
acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill
|
||||
@ -248,7 +246,6 @@ acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill
|
||||
kill tid = do
|
||||
logTrace ("Killing worker thread: " <> display nam)
|
||||
cancel tid
|
||||
logTrace ("Killed worker thread: " <> display nam)
|
||||
|
||||
|
||||
-- Run Pier --------------------------------------------------------------------
|
||||
@ -261,9 +258,9 @@ pier
|
||||
-> RAcquire PierEnv ()
|
||||
pier (serf, log) vSlog mStart multi = do
|
||||
computeQ <- newTQueueIO @_ @Serf.EvErr
|
||||
persistQ <- newTQueueIO
|
||||
executeQ <- newTQueueIO
|
||||
saveM <- newEmptyTMVarIO
|
||||
persistQ <- newTQueueIO @_ @(Fact, FX)
|
||||
executeQ <- newTQueueIO @_ @FX
|
||||
saveM <- newEmptyTMVarIO @_ @()
|
||||
kingApi <- King.kingAPI
|
||||
|
||||
termApiQ <- atomically $ do
|
||||
@ -289,14 +286,14 @@ pier (serf, log) vSlog mStart multi = do
|
||||
atomically $ Term.trace muxed txt
|
||||
oldSlog txt
|
||||
|
||||
let logId = Log.identity log
|
||||
let ship = who logId
|
||||
let logId = Log.identity log :: LogIdentity
|
||||
let ship = who logId :: Ship
|
||||
|
||||
-- Our call above to set the logging function which echos errors from the
|
||||
-- Serf doesn't have the appended \r\n because those \r\n s are added in
|
||||
-- the c serf code. Logging output from our haskell process must manually
|
||||
-- add them.
|
||||
let showErr = atomically . Term.trace muxed . flip append "\r\n"
|
||||
let showErr = atomically . Term.trace muxed . (<> "\r\n")
|
||||
|
||||
env <- ask
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user