ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-09-20 23:18:00 +03:00
Code Issues Packages Projects Releases Wiki Activity

king: Minor cleanup.

Browse Source
This commit is contained in:
~siprel 2020-06-08 21:22:04 +00:00
parent 1f4c823d92
commit 957f14ee40
2 changed files with 26 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
pkg/hs/urbit-king/lib/Urbit/Vere/NounServ.hs
View File

@ -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

15
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
View File

@ -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