urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-24 11:24:21 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/king-haskell' into king-exit-cleanly

Browse Source
This commit is contained in:
Elliot Glaysher 2019-09-18 10:38:20 -07:00
commit f417c084a4
15 changed files with 460 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
pkg/king/app/Main.hs
View File

@ -84,31 +84,31 @@ module Main (main) where
import UrbitPrelude
import Data.RAcquire
import Arvo
import Control.Exception (AsyncException(UserInterrupt))
import Data.Acquire
import Data.Conduit
import Data.Conduit.List hiding (replicate, take)
import Noun hiding (Parser)
import Data.RAcquire
import Noun hiding (Parser)
import RIO.Directory
import Vere.Pier
import Vere.Pier.Types
import Vere.Serf
import Control.Concurrent (myThreadId, runInBoundThread)
import Control.Exception (AsyncException(UserInterrupt))
import Control.Lens ((&))
import Data.Default (def)
import System.Directory (doesFileExist, removeFile)
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import KingApp (runApp)
import System.Environment (getProgName)
import System.Posix.Signals (Handler(Catch), installHandler, sigTERM)
import Text.Show.Pretty (pPrint)
import Urbit.Time (Wen)
import Vere.LockFile (lockFile)
import qualified CLI
import qualified CLI as CLI
import qualified Data.Set as Set
import qualified EventBrowser
import qualified EventBrowser as EventBrowser
import qualified System.IO.LockFile.Internal as Lock
import qualified Vere.Log as Log
import qualified Vere.Pier as Pier
@ -116,42 +116,6 @@ import qualified Vere.Serf as Serf
--------------------------------------------------------------------------------
class HasAppName env where
appNameL :: Lens' env Utf8Builder
data App = App
{ _appLogFunc :: !LogFunc
, _appName :: !Utf8Builder
}
makeLenses ''App
instance HasLogFunc App where
logFuncL = appLogFunc
instance HasAppName App where
appNameL = appName
runApp :: RIO App a -> IO a
runApp inner = do
home <- getHomeDirectory
let logDir = home <> "/log"
createDirectoryIfMissing True logDir
withTempFile logDir "king-" $ \tmpFile hFile -> do
hSetBuffering hFile LineBuffering
logOptions <- logOptionsHandle hFile True
<&> setLogUseTime True
<&> setLogUseLoc False
withLogFunc logOptions $ \logFunc -> do
let app = App { _appLogFunc = logFunc
, _appName = "Alice"
}
runRIO app inner
--------------------------------------------------------------------------------
zod :: Ship
zod = 0
@ -159,9 +123,9 @@ zod = 0
removeFileIfExists :: HasLogFunc env => FilePath -> RIO env ()
removeFileIfExists pax = do
exists <- io $ doesFileExist pax
exists <- doesFileExist pax
when exists $ do
io $ removeFile pax
removeFile pax
--------------------------------------------------------------------------------
@ -196,21 +160,6 @@ tryPlayShip shipPath = do
rio $ logTrace "SHIP RESUMED"
Pier.pier shipPath Nothing sls
lockFile :: HasLogFunc e => FilePath -> RAcquire e ()
lockFile pax = void $ mkRAcquire start stop
where
fil = pax <> "/.vere.lock"
stop handle = do
logInfo $ display @Text $ ("Releasing lock file: " <> pack fil)
io $ Lock.unlock fil handle
params = def { Lock.retryToAcquireLock = Lock.No }
start = do
logInfo $ display @Text $ ("Taking lock file: " <> pack fil)
io (Lock.lock params fil)
tryResume :: HasLogFunc e => FilePath -> RIO e ()
tryResume shipPath = do
rwith resumedPier $ \(serf, log, ss) -> do

70
pkg/king/dhall-sketch/config.dhall Normal file
View File

@ -0,0 +1,70 @@
let Persist = { collect-fx : Bool }
let FakeMode = < Dry | Wet : Persist >
let Mode = < Online : Persist | Local : Persist | Fake : FakeMode >
let Verbose = < Quiet | Normal | Verbose >
let King = { mode : Mode, log : Verbose }
let Serf =
{ debug-ram :
Bool
, debug-cpu :
Bool
, check-corrupt :
Bool
, check-fatal :
Bool
, verbose :
Bool
, dry-run :
Bool
, quiet :
Bool
, hashless :
Bool
, trace :
Bool
}
let Ship = { addr : Text, serf : Serf, ames-port : Optional Natural }
let Config = { king : King, ships : List Ship }
let KingDefault =
{ mode = Mode.Online { collect-fx = False }, log = Verbose.Normal } : King
let SerfDefault =
{ debug-ram =
False
, debug-cpu =
False
, check-corrupt =
False
, check-fatal =
False
, verbose =
False
, dry-run =
False
, quiet =
False
, hashless =
False
, trace =
False
}
: Serf
let ShipDefault =
λ(addr : Text)
→ { addr = addr, serf = SerfDefault, ames-port = None Natural }
let ConfigDefault = { king = KingDefault, ships = [] : List Ship } : Config
let ConfigExample =
{ king = KingDefault, ships = [ ShipDefault "zod" ] } : Config
in ConfigExample

27
pkg/king/lib/Arvo/Event.hs
View File

@ -5,8 +5,8 @@ import UrbitPrelude hiding (Term)
import Arvo.Common (KingId(..), ServId(..))
import Arvo.Common (NounMap, NounSet)
import Arvo.Common (Desk, Mime)
import Arvo.Common (HttpEvent, Header(..))
import Arvo.Common (Ipv4, Ipv6, Port, Turf, AmesDest)
import Arvo.Common (Header(..), HttpEvent)
import Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
import Arvo.Common (ReOrg(..), reorgThroughNoun)
import qualified Network.HTTP.Types.Method as H
@ -299,3 +299,26 @@ instance FromNoun Ev where
ReOrg "" s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v)
ReOrg "vane" s t p v -> fmap EvVane $ parseNoun $ toNoun (s,t,p,v)
ReOrg _ _ _ _ _ -> fail "First path-elem must be ?($ %vane)"
-- Short Event Names -----------------------------------------------------------
getSpinnerNameForEvent :: Ev -> Maybe String
getSpinnerNameForEvent = \case
EvVane _ -> Nothing
EvBlip b -> case b of
BlipEvAmes _ -> Just "ames"
BlipEvArvo _ -> Just "arvo"
BlipEvBehn _ -> Just "behn"
BlipEvBoat _ -> Just "boat"
BlipEvHttpClient _ -> Just "iris"
BlipEvHttpServer _ -> Just "eyre"
BlipEvNewt _ -> Just "newt"
BlipEvSync _ -> Just "clay"
BlipEvTerm t -> case t of
TermEvBelt _ belt -> case belt of
-- In the case of the user hitting enter, the cause is technically a
-- terminal event, but we don't display any name because the cause is
-- really the user.
Ret () -> Nothing
_ -> Just "term"
_ -> Just "term"

49
pkg/king/lib/KingApp.hs Normal file
View File

@ -0,0 +1,49 @@
module KingApp
( App
, runApp
, HasAppName(..)
) where
import UrbitPrelude
import RIO.Directory
--------------------------------------------------------------------------------
class HasAppName env where
appNameL :: Lens' env Utf8Builder
data App = App
{ _appLogFunc :: !LogFunc
, _appName :: !Utf8Builder
}
makeLenses ''App
instance HasLogFunc App where
logFuncL = appLogFunc
instance HasAppName App where
appNameL = appName
withLogFileHandle :: (Handle -> IO a) -> IO a
withLogFileHandle act = do
home <- getHomeDirectory
let logDir = home <> "/log"
createDirectoryIfMissing True logDir
withTempFile logDir "king-" $ \_tmpFile handle -> do
hSetBuffering handle LineBuffering
act handle
runApp :: RIO App a -> IO a
runApp inner = do
withLogFileHandle $ \logFile -> do
logOptions <- logOptionsHandle logFile True
<&> setLogUseTime True
<&> setLogUseLoc False
withLogFunc logOptions $ \logFunc ->
go $ App { _appLogFunc = logFunc
, _appName = "Vere"
}
where
go app = runRIO app inner

26
pkg/king/lib/Vere/LockFile.hs Normal file
View File

@ -0,0 +1,26 @@
module Vere.LockFile (lockFile) where
import UrbitPrelude
import Data.Default (def)
import RIO.Directory (createDirectoryIfMissing)
import System.IO.LockFile.Internal (LockingParameters(..), RetryStrategy(..),
lock, unlock)
--------------------------------------------------------------------------------
lockFile :: HasLogFunc e => FilePath -> RAcquire e ()
lockFile pax = void $ mkRAcquire start stop
where
fil = pax <> "/.vere.lock"
stop handle = do
logInfo $ display @Text $ ("Releasing lock file: " <> pack fil)
io $ unlock fil handle
params = def { retryToAcquireLock = No }
start = do
createDirectoryIfMissing True pax
logInfo $ display @Text $ ("Taking lock file: " <> pack fil)
io (lock params fil)

15
pkg/king/lib/Vere/Pier.hs
View File

@ -10,7 +10,6 @@ import Arvo
import System.Random
import Vere.Pier.Types
import System.Directory (createDirectoryIfMissing)
import System.Posix.Files (ownerModes, setFileMode)
import Vere.Ames (ames)
import Vere.Behn (behn)
@ -21,6 +20,8 @@ import Vere.Log (EventLog)
import Vere.Serf (Serf, SerfState(..), doJob, sStderr)
import Vere.Term
import RIO.Directory
import qualified System.Entropy as Ent
import qualified Urbit.Time as Time
import qualified Vere.Log as Log
@ -35,7 +36,7 @@ setupPierDirectory :: FilePath -> RIO e ()
setupPierDirectory shipPath = do
for_ ["put", "get", "log", "chk"] $ \seg -> do
let pax = shipPath <> "/.urb/" <> seg
io $ createDirectoryIfMissing True pax
createDirectoryIfMissing True pax
io $ setFileMode pax ownerModes
@ -161,7 +162,8 @@ pier pierPath mPort (serf, log, ss) = do
tExe <- startDrivers >>= router (readTQueue executeQ)
tDisk <- runPersist log persistQ (writeTQueue executeQ)
tCpu <- runCompute serf ss (readTQueue computeQ) (takeTMVar saveM)
(takeTMVar shutdownM) (writeTQueue persistQ)
(takeTMVar shutdownM) (tsShowSpinner terminalSystem)
(tsHideSpinner terminalSystem) (writeTQueue persistQ)
tSaveSignal <- saveSignalThread saveM
@ -284,9 +286,12 @@ runCompute :: ∀e. HasLogFunc e
-> STM Ev
-> STM ()
-> STM ()
-> (Maybe String -> STM ())
-> STM ()
-> ((Job, FX) -> STM ())
-> RAcquire e (Async ())
runCompute serf ss getEvent getSaveSignal getShutdownSignal putResult =
runCompute serf ss getEvent getSaveSignal getShutdownSignal
showSpinner hideSpinner putResult =
mkRAcquire (async (go ss)) cancel
where
go :: SerfState -> RIO e ()
@ -302,7 +307,9 @@ runCompute serf ss getEvent getSaveSignal getShutdownSignal putResult =
eId <- pure (ssNextEv ss)
mug <- pure (ssLastMug ss)
atomically $ showSpinner (getSpinnerNameForEvent ev)
(job', ss', fx) <- doJob serf $ DoWork $ Work eId mug wen ev
atomically $ hideSpinner
atomically (putResult (job', fx))
go ss'
CRSave () -> do

71
pkg/king/lib/Vere/Serf.hs
View File

@ -27,10 +27,12 @@ import Foreign.Ptr (castPtr)
import Foreign.Storable (peek, poke)
import System.Exit (ExitCode)
import qualified Urbit.Ob as Ob
import qualified Data.ByteString.Unsafe as BS
import qualified Data.Text as T
import qualified System.IO.Error as IO
import qualified System.IO as IO
import qualified System.IO.Error as IO
import qualified Urbit.Time as Time
import qualified Vere.Log as Log
@ -151,7 +153,7 @@ startUp conf@(Config pierPath flags) = do
(Just i, Just o, Just e, p) <- createProcess pSpec
pure (i, o, e, p)
stderr <- newMVar putStrLn
stderr <- newMVar serf
async (readStdErr e stderr)
pure (Serf i o p stderr)
where
@ -367,6 +369,22 @@ replayJob serf job = do
Left replace -> throwIO (ReplacedEventDuringReplay (jobId job) replace)
Right (ss, _) -> pure ss
--------------------------------------------------------------------------------
updateProgressBar :: Int -> Text -> Maybe (ProgressBar ())
-> RIO e (Maybe (ProgressBar ()))
updateProgressBar count startMsg = \case
Nothing -> do
-- We only construct the progress bar on the first time that we
-- process an event so that we don't display an empty progress
-- bar when the snapshot is caught up to the log.
putStrLn startMsg
let style = defStyle { stylePostfix = exact }
pb <- io $ newProgressBar style 10 (Progress 0 count ())
pure (Just pb)
Just pb -> do
io $ incProgress pb 1
pure (Just pb)
--------------------------------------------------------------------------------
@ -379,23 +397,34 @@ data BootExn = ShipAlreadyBooted
bootFromSeq :: ∀e. HasLogFunc e => Serf e -> BootSeq -> RIO e ([Job], SerfState)
bootFromSeq serf (BootSeq ident nocks ovums) = do
handshake serf ident >>= \case
ss@(SerfState 1 (Mug 0)) -> loop [] ss bootSeqFns
ss@(SerfState 1 (Mug 0)) -> loop [] ss Nothing bootSeqFns
_ -> throwIO ShipAlreadyBooted
where
loop :: [Job] -> SerfState -> [BootSeqFn] -> RIO e ([Job], SerfState)
loop acc ss = \case
[] -> pure (reverse acc, ss)
x:xs -> do wen <- io Time.now
job <- pure $ x (ssNextEv ss) (ssLastMug ss) wen
(job, ss) <- bootJob serf job
loop (job:acc) ss xs
loop :: [Job] -> SerfState -> Maybe (ProgressBar ()) -> [BootSeqFn]
-> RIO e ([Job], SerfState)
loop acc ss pb = \case
[] -> do
pb <- updateProgressBar 0 bootMsg pb
pure (reverse acc, ss)
x:xs -> do
wen <- io Time.now
job <- pure $ x (ssNextEv ss) (ssLastMug ss) wen
pb <- updateProgressBar (1 + length xs) bootMsg pb
(job, ss) <- bootJob serf job
loop (job:acc) ss pb xs
bootSeqFns :: [BootSeqFn]
bootSeqFns = fmap muckNock nocks <> fmap muckOvum ovums
where
muckNock nok eId mug _ = RunNok $ LifeCyc eId mug nok
muckOvum ov eId mug wen = DoWork $ Work eId mug wen ov
bootMsg = "Booting " ++ (fakeStr (isFake ident)) ++
(Ob.render (Ob.patp (fromIntegral (who ident))))
fakeStr True = "fake "
fakeStr False = ""
{-
The ship is booted, but it is behind. shove events to the worker
until it is caught up.
@ -408,23 +437,15 @@ replayJobs serf lastEv = go Nothing
await >>= \case
Nothing -> pure ss
Just job -> do
pb <- updatePb ss pb
pb <- lift $ updatePb ss pb
played <- lift $ replayJob serf job
go (Just pb) played
go pb played
updatePb ss = \case
Nothing -> do
-- We only construct the progress bar on the first time that we
-- process an event so that we don't display an empty progress
-- bar when the snapshot is caught up to the log.
let toReplay = lastEv - (fromIntegral (ssNextEv ss))
let style = defStyle { stylePostfix = exact }
putStrLn $ pack ("Replaying events #" ++ (show (ssNextEv ss)) ++
" to #" ++ (show lastEv))
io $ newProgressBar style 10 (Progress 0 toReplay lastEv)
Just pb -> do
io $ incProgress pb 1
pure pb
updatePb ss = do
let start = lastEv - (fromIntegral (ssNextEv ss))
let msg = pack ("Replaying events #" ++ (show (ssNextEv ss)) ++
" to #" ++ (show lastEv))
updateProgressBar start msg
replay :: HasLogFunc e => Serf e -> Log.EventLog -> RIO e SerfState

179
pkg/king/lib/Vere/Term.hs
View File

@ -1,10 +1,12 @@
module Vere.Term (initializeLocalTerminal, term, TerminalSystem(..)) where
import Arvo hiding (Term)
import UrbitPrelude
import Urbit.Time
import UrbitPrelude hiding (getCurrentTime)
import Vere.Pier.Types
import Data.Char
import Data.List ((!!))
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
@ -27,8 +29,19 @@ import qualified Data.ByteString.UTF8 as UTF8
data VereOutput = VereBlitOutput [Blit]
| VerePrintOutput String
| VereBlankLine
| VereShowSpinner (Maybe String)
| VereHideSpinner
data LineState = LineState String Int
-- All stateful data in the printing to stdOutput.
data LineState = LineState
{ lsLine :: String
, lsCurPos :: Int
, lsSpinTimer :: Maybe (Async ())
, lsSpinCause :: Maybe String
, lsSpinFirstRender :: Bool
, lsSpinFrame :: Int
, lsPrevEndTime :: Wen
}
-- A record used in reading data from stdInput.
data ReadData = ReadData
@ -46,9 +59,11 @@ data ReadData = ReadData
-- the session is over, and has a general in/out queue in the types of the
-- vere/arvo interface.
data TerminalSystem e = TerminalSystem
{ tsReadQueue :: TQueue Belt
, tsWriteQueue :: TQueue VereOutput
, tsStderr :: Text -> RIO e ()
{ tsReadQueue :: TQueue Belt
, tsWriteQueue :: TQueue VereOutput
, tsStderr :: Text -> RIO e ()
, tsShowSpinner :: Maybe String -> STM ()
, tsHideSpinner :: STM ()
}
-- Private data to the TerminalSystem that we keep around for stop().
@ -68,6 +83,16 @@ initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) ()
-- Version one of this is punting on the ops_u.dem flag: whether we're running
-- in daemon mode.
spinners = ['|', '/', '-', '\\']
leftBracket = ['«']
rightBracket = ['»']
_spin_cool_us = 500000
_spin_warm_us = 50000
_spin_rate_us = 250000
_spin_idle_us = 500000
--------------------------------------------------------------------------------
runMaybeTermOutput :: Terminal -> (Terminal -> Maybe TermOutput) -> RIO e ()
@ -93,10 +118,9 @@ isTerminalBlit _ = True
-- Initializes the generalized input/output parts of the terminal.
--
initializeLocalTerminal :: HasLogFunc e => RAcquire e (TerminalSystem e)
initializeLocalTerminal = do
(a, b) <- mkRAcquire start stop
pure a
initializeLocalTerminal :: forall e. HasLogFunc e
=> RAcquire e (TerminalSystem e)
initializeLocalTerminal = fst <$> mkRAcquire start stop
where
start :: HasLogFunc e => RIO e (TerminalSystem e, Private)
start = do
@ -106,7 +130,9 @@ initializeLocalTerminal = do
-- TODO: We still need to actually get the size from the terminal somehow.
tsWriteQueue <- newTQueueIO
pWriterThread <- asyncBound (writeTerminal pTerminal tsWriteQueue)
spinnerMVar <- newEmptyTMVarIO
pWriterThread <-
asyncBound (writeTerminal pTerminal tsWriteQueue spinnerMVar)
pPreviousConfiguration <- io $ getTerminalAttributes stdInput
@ -120,11 +146,15 @@ initializeLocalTerminal = do
tsReadQueue <- newTQueueIO
pReaderThread <- asyncBound
(readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue))
(readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue))
let tsStderr = \txt ->
atomically $ writeTQueue tsWriteQueue $ VerePrintOutput $ unpack txt
let tsShowSpinner = \str ->
writeTQueue tsWriteQueue $ VereShowSpinner str
let tsHideSpinner = writeTQueue tsWriteQueue $ VereHideSpinner
pure (TerminalSystem{..}, Private{..})
stop :: HasLogFunc e
@ -165,26 +195,87 @@ initializeLocalTerminal = do
vtParmLeft t = getCap t "cub1"
vtParmRight t = getCap t "cuf1"
-- An async which will put into an mvar after a delay. Used to spin the
-- spinner in writeTerminal.
spinnerHeartBeat :: Int -> Int -> TMVar () -> RIO e ()
spinnerHeartBeat first rest mvar = do
threadDelay first
loop
where
loop = do
atomically $ putTMVar mvar ()
threadDelay rest
loop
-- Writes data to the terminal. Both the terminal reading, normal logging,
-- and effect handling can all emit bytes which go to the terminal.
writeTerminal :: Terminal -> TQueue VereOutput -> RIO e ()
writeTerminal t q = loop (LineState "" 0)
writeTerminal :: Terminal -> TQueue VereOutput -> TMVar () -> RIO e ()
writeTerminal t q spinner = do
currentTime <- io $ now
loop (LineState "" 0 Nothing Nothing True 0 currentTime)
where
loop s = do
x <- atomically $ readTQueue q
loop ls@LineState{..} = do
x <- atomically $
Right <$> readTQueue q <|>
Left <$> takeTMVar spinner
case x of
VereBlitOutput blits -> do
s <- foldM (writeBlit t) s blits
loop s
VerePrintOutput p -> do
Right (VereBlitOutput blits) -> do
ls <- foldM (writeBlit t) ls blits
loop ls
Right (VerePrintOutput p) -> do
io $ runTermOutput t $ termText "\r"
runMaybeTermOutput t vtClearToBegin
io $ runTermOutput t $ termText p
s <- termRefreshLine t s
loop s
VereBlankLine -> do
ls <- termRefreshLine t ls
loop ls
Right VereBlankLine -> do
io $ runTermOutput t $ termText "\r\n"
loop s
loop ls
Right (VereShowSpinner txt) -> do
current <- io $ now
-- Figure out how long to wait to show the spinner. When we don't
-- have a vane name to display, we assume its a user action and
-- trigger immediately. Otherwise, if we receive an event shortly
-- after a previous spin, use a shorter delay to avoid giving the
-- impression of a half-idle system.
let delay = case txt of
Nothing -> 0
Just _ ->
if (gap current lsPrevEndTime ^. microSecs) <
_spin_idle_us
then _spin_warm_us
else _spin_cool_us
spinTimer <- async $ spinnerHeartBeat delay _spin_rate_us spinner
loop ls { lsSpinTimer = Just spinTimer,
lsSpinCause = txt,
lsSpinFirstRender = True }
Right VereHideSpinner -> do
maybe (pure ()) cancel lsSpinTimer
-- We do a final flush of the spinner mvar to ensure we don't
-- have a lingering signal which will redisplay the spinner after
-- we call termRefreshLine below.
atomically $ tryTakeTMVar spinner
-- If we ever actually ran the spinner display callback, we need
-- to force a redisplay of the command prompt.
ls <- if not lsSpinFirstRender
then termRefreshLine t ls
else pure ls
endTime <- io $ now
loop ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime }
Left () -> do
let spinner = [spinners !! lsSpinFrame] ++ case lsSpinCause of
Nothing -> []
Just str -> leftBracket ++ str ++ rightBracket
io $ runTermOutput t $ termText spinner
termSpinnerMoveLeft t (length spinner)
loop ls { lsSpinFirstRender = False,
lsSpinFrame = (lsSpinFrame + 1) `mod` (length spinners)
}
-- Writes an individual blit to the screen
writeBlit :: Terminal -> LineState -> Blit -> RIO e LineState
@ -208,41 +299,49 @@ initializeLocalTerminal = do
-- Moves the cursor to the requested position
termShowCursor :: Terminal -> LineState -> Int -> RIO e LineState
termShowCursor t (LineState line pos) newPos = do
if newPos < pos then do
replicateM_ (pos - newPos) (runMaybeTermOutput t vtParmLeft)
pure (LineState line newPos)
else if newPos > pos then do
replicateM_ (newPos - pos) (runMaybeTermOutput t vtParmRight)
pure (LineState line newPos)
termShowCursor t ls@LineState{..} {-line pos)-} newPos = do
if newPos < lsCurPos then do
replicateM_ (lsCurPos - newPos) (runMaybeTermOutput t vtParmLeft)
pure ls { lsCurPos = newPos }
else if newPos > lsCurPos then do
replicateM_ (newPos - lsCurPos) (runMaybeTermOutput t vtParmRight)
pure ls { lsCurPos = newPos }
else
pure (LineState line pos)
pure ls
-- Moves the cursor left without any mutation of the LineState. Used only
-- in cursor spinning.
termSpinnerMoveLeft :: Terminal -> Int -> RIO e ()
termSpinnerMoveLeft t count =
replicateM_ count (runMaybeTermOutput t vtParmLeft)
-- Displays and sets the current line
termShowLine :: Terminal -> LineState -> String -> RIO e LineState
termShowLine t ls newStr = do
-- TODO: Really think about how term.c munged cus_w. Amidoinitrit?
io $ runTermOutput t $ termText newStr
pure (LineState newStr (length newStr))
pure ls { lsLine = newStr, lsCurPos = (length newStr) }
termShowClear :: Terminal -> LineState -> RIO e LineState
termShowClear t ls = do
io $ runTermOutput t $ termText "\r"
runMaybeTermOutput t vtClearToBegin
pure (LineState "" 0)
pure ls { lsLine = "", lsCurPos = 0 }
-- New Current Line
termShowMore :: Terminal -> LineState -> RIO e LineState
termShowMore t ls = do
io $ runTermOutput t $ termText "\r\n"
pure (LineState "" 0)
pure ls { lsLine = "", lsCurPos = 0 }
-- Redraw the current LineState, moving cursor to the end.
-- Redraw the current LineState, maintaining the current curpos
termRefreshLine :: Terminal -> LineState -> RIO e LineState
termRefreshLine t ls@(LineState line pos) = do
runMaybeTermOutput t vtClearToBegin
newLs <- termShowLine t ls line
termShowCursor t newLs pos
termRefreshLine t ls = do
let line = (lsLine ls)
curPos = (lsCurPos ls)
ls <- termShowClear t ls
ls <- termShowLine t ls line
termShowCursor t ls curPos
-- ring my bell
bell :: TQueue VereOutput -> RIO e ()

1
pkg/king/package.yaml
View File

@ -90,6 +90,7 @@ dependencies:
- unliftio
- unliftio-core
- unordered-containers
- urbit-hob
- utf8-string
- vector
- wai

46
pkg/king/test/AmesTests.hs
View File

@ -1,7 +1,6 @@
module AmesTests (tests) where
import Arvo
import Data.Acquire
import Data.Conduit
import Data.Conduit.List hiding (take)
import Data.Ord.Unicode
@ -16,9 +15,10 @@ import Vere.Ames
import Vere.Log
import Vere.Pier.Types
import Control.Concurrent (runInBoundThread, threadDelay)
import Control.Concurrent (runInBoundThread)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import KingApp (runApp)
import Network.Socket (tupleToHostAddress)
import qualified Vere.Log as Log
@ -35,11 +35,12 @@ turfEf = NewtEfTurf (0, ()) []
sendEf :: Galaxy -> Wen -> Bytes -> NewtEf
sendEf g w bs = NewtEfSend (0, ()) (ADGala w g) bs
runGala :: Word8 -> Acquire (TQueue Ev, EffCb NewtEf)
runGala :: Word8 -> RAcquire e (TQueue Ev, EffCb e NewtEf)
runGala point = do
q <- liftIO newTQueueIO
cb <- snd $ ames pid (fromIntegral point) Nothing (writeTQueue q)
liftIO $ cb turfEf
q <- newTQueueIO
let (_, runAmes) = ames pid (fromIntegral point) Nothing (writeTQueue q)
cb ← liftAcquire runAmes
rio $ cb turfEf
pure (q, cb)
waitForPacket :: TQueue Ev -> Bytes -> IO Bool
@ -51,37 +52,37 @@ waitForPacket q val = go
EvBlip (BlipEvAmes (AmesEvHear () _ bs)) -> pure (bs == val)
_ -> pure False
runAcquire :: Acquire a -> IO a
runAcquire acq = with acq pure
runRAcquire :: RAcquire e a -> RIO e a
runRAcquire acq = rwith acq pure
sendThread :: EffCb NewtEf -> (Galaxy, Bytes) -> Acquire ()
sendThread cb (to, val) = void $ mkAcquire start cancel
sendThread :: EffCb e NewtEf -> (Galaxy, Bytes) -> RAcquire e ()
sendThread cb (to, val) = void $ mkRAcquire start cancel
where
start = async $ forever $ do threadDelay 1_000
wen <- now
wen <- io $ now
cb (sendEf to wen val)
threadDelay 10_000
zodSelfMsg :: Property
zodSelfMsg = forAll arbitrary (ioProperty . runTest)
zodSelfMsg = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: Bytes -> IO Bool
runTest val = runAcquire $ do
runTest :: Bytes -> RIO e Bool
runTest val = runRAcquire $ do
(zodQ, zod) <- runGala 0
() <- sendThread zod (0, val)
liftIO (waitForPacket zodQ val)
twoTalk :: Property
twoTalk = forAll arbitrary (ioProperty . runTest)
twoTalk = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: (Word8, Word8, Bytes) -> IO Bool
runTest :: (Word8, Word8, Bytes) -> RIO e Bool
runTest (aliceShip, bobShip, val) =
if aliceShip == bobShip
then pure True
else go aliceShip bobShip val
go :: Word8 -> Word8 -> Bytes -> IO Bool
go aliceShip bobShip val = runAcquire $ do
go :: Word8 -> Word8 -> Bytes -> RIO e Bool
go aliceShip bobShip val = runRAcquire $ do
(aliceQ, alice) <- runGala aliceShip
(bobQ, bob) <- runGala bobShip
sendThread alice (Galaxy bobShip, val)
@ -129,6 +130,15 @@ genIpv4 = do
then genIpv4
else pure (Ipv4 x)
instance Arbitrary Text where
arbitrary = pack <$> arb
instance Arbitrary Cord where
arbitrary = Cord <$> arb
instance Arbitrary BigCord where
arbitrary = BigCord <$> arb
instance Arbitrary AmesDest where
arbitrary = oneof [ ADGala <$> arb <*> arb
, ADIpv4 <$> arb <*> arb <*> genIpv4

4
pkg/king/test/ArvoTests.hs
View File

@ -155,6 +155,10 @@ instance Arbitrary StdMethod where
instance Arbitrary Header where
arbitrary = Header <$> arb <*> arb
instance Arbitrary BigCord where
arbitrary = BigCord <$> arb
instance Arbitrary ServId where arbitrary = ServId <$> arb
instance Arbitrary UD where arbitrary = UD <$> arb

7
pkg/king/test/BehnTests.hs
View File

@ -19,6 +19,7 @@ import Vere.Pier.Types
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import KingApp (runApp)
import Network.Socket (tupleToHostAddress)
import qualified Urbit.Time as Time
@ -32,12 +33,12 @@ king = KingId 0
-- TODO Timers always fire immediatly. Something is wrong!
timerFires :: Property
timerFires = forAll arbitrary (ioProperty . runTest)
timerFires = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: () -> IO Bool
runTest :: () -> RIO e Bool
runTest () = do
q <- newTQueueIO
with (snd $ behn king (writeTQueue q)) $ \cb -> do
rwith (liftAcquire $ snd $ behn king (writeTQueue q)) $ \cb -> do
cb (BehnEfDoze (king, ()) (Just (2^20)))
t <- atomically $ readTQueue q
print t

67
pkg/king/test/LogTests.hs
View File

@ -11,16 +11,17 @@ import Vere.Pier.Types
import Data.Conduit
import Data.Conduit.List hiding (filter)
import Control.Concurrent (threadDelay, runInBoundThread)
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import KingApp (runApp, App)
import qualified Vere.Log as Log
-- Utils -----------------------------------------------------------------------
withTestDir :: (FilePath -> IO a) -> IO a
withTestDir :: (FilePath -> RIO e a) -> RIO e a
withTestDir = withTempDirectory "./" ".testlog."
data NotEqual = NotEqual String String
@ -28,10 +29,9 @@ data NotEqual = NotEqual String String
instance Exception NotEqual where
assertEqual :: (Show a, Eq a) => a -> a -> IO ()
assertEqual :: MonadIO m => (Show a, Eq a) => a -> a -> m ()
assertEqual x y = do
unless (x == y) $
throwIO (NotEqual (show x) (show y))
unless (x == y) $ io $ throwIO $ NotEqual (show x) (show y)
-- Database Operations ---------------------------------------------------------
@ -42,15 +42,15 @@ data Db = Db LogIdentity [ByteString] (Map Word64 ByteString)
addEvents :: Db -> [ByteString] -> Db
addEvents (Db id evs efs) new = Db id (evs <> new) efs
readDb :: EventLog -> IO Db
readDb :: EventLog -> RIO App Db
readDb log = do
events <- runConduit (streamEvents log 1 .| consume)
effects <- runConduit (streamEffectsRows log 0 .| consume)
pure $ Db (Log.identity log) events (mapFromList effects)
withDb :: FilePath -> Db -> (EventLog -> IO a) -> IO a
withDb :: FilePath -> Db -> (EventLog -> RIO App a) -> RIO App a
withDb dir (Db dId dEvs dFx) act = do
with (Log.new dir dId) $ \log -> do
rwith (Log.new dir dId) $ \log -> do
Log.appendEvents log (fromList dEvs)
for_ (mapToList dFx) $ \(k,v) ->
Log.writeEffectsRow log k v
@ -59,70 +59,75 @@ withDb dir (Db dId dEvs dFx) act = do
--------------------------------------------------------------------------------
tryReadIdentity :: Property
tryReadIdentity = forAll arbitrary (ioProperty . runTest)
tryReadIdentity = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: LogIdentity -> IO Bool
runTest :: LogIdentity -> RIO App Bool
runTest ident = do
runInBoundThread $
env <- ask
io $ runInBoundThread $ runRIO env $
withTestDir $ \dir -> do
with (Log.new dir ident) $ \log ->
rwith (Log.new dir ident) $ \log ->
assertEqual ident (Log.identity log)
with (Log.existing dir) $ \log ->
rwith (Log.existing dir) $ \log ->
assertEqual ident (Log.identity log)
with (Log.existing dir) $ \log ->
rwith (Log.existing dir) $ \log ->
assertEqual ident (Log.identity log)
pure True
tryReadDatabase :: Property
tryReadDatabase = forAll arbitrary (ioProperty . runTest)
tryReadDatabase = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: Db -> IO Bool
runTest :: Db -> RIO App Bool
runTest db = do
runInBoundThread $
env <- ask
io $ runInBoundThread $ runRIO env $
withTestDir $ \dir -> do
withDb dir db $ \log -> do
readDb log >>= assertEqual db
pure True
tryReadDatabaseFuzz :: Property
tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runTest)
tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: Db -> IO Bool
runTest :: Db -> RIO App Bool
runTest db = do
runInBoundThread $
env <- ask
io $ runInBoundThread $ runRIO env $
withTestDir $ \dir -> do
withDb dir db $ \log -> do
readDb log >>= assertEqual db
with (Log.existing dir) $ \log -> do
rwith (Log.existing dir) $ \log -> do
readDb log >>= assertEqual db
with (Log.existing dir) $ \log -> do
rwith (Log.existing dir) $ \log -> do
readDb log >>= assertEqual db
readDb log >>= assertEqual db
pure True
tryAppend :: Property
tryAppend = forAll arbitrary (ioProperty . runTest)
tryAppend = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: ([ByteString], Db) -> IO Bool
runTest :: ([ByteString], Db) -> RIO App Bool
runTest (extra, db) = do
runInBoundThread $
env <- ask
io $ runInBoundThread $ runRIO env $
withTestDir $ \dir -> do
db' <- pure (addEvents db extra)
withDb dir db $ \log -> do
readDb log >>= assertEqual db
Log.appendEvents log (fromList extra)
readDb log >>= assertEqual db'
with (Log.existing dir) $ \log -> do
rwith (Log.existing dir) $ \log -> do
readDb log >>= assertEqual db'
pure True
tryAppendHuge :: Property
tryAppendHuge = forAll arbitrary (ioProperty . runTest)
tryAppendHuge = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: ([ByteString], Db) -> IO Bool
runTest :: ([ByteString], Db) -> RIO App Bool
runTest (extra, db) = do
runInBoundThread $ do
extra <- do b <- readFile "/home/benajmin/r/urbit/bin/brass.pill"
env <- ask
io $ runInBoundThread $ runRIO env $ do
extra <- do b <- readFile "./bin/brass.pill"
pure (extra <> [b] <> extra)
withTestDir $ \dir -> do
db' <- pure (addEvents db extra)
@ -130,7 +135,7 @@ tryAppendHuge = forAll arbitrary (ioProperty . runTest)
readDb log >>= assertEqual db
Log.appendEvents log (fromList extra)
readDb log >>= assertEqual db'
with (Log.existing dir) $ \log -> do
rwith (Log.existing dir) $ \log -> do
readDb log >>= assertEqual db'
pure True

18
pkg/king/test/Main.hs
View File

@ -6,6 +6,7 @@ import Test.QuickCheck hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import RIO.Directory
import System.Environment (setEnv)
import Control.Concurrent (runInBoundThread)
@ -18,11 +19,12 @@ import qualified BehnTests
main :: IO ()
main = do
setEnv "TASTY_NUM_THREADS" "1"
runInBoundThread $ defaultMain $ testGroup "Urbit"
[ DeriveNounTests.tests
, ArvoTests.tests
, AmesTests.tests
, LogTests.tests
, BehnTests.tests
]
makeAbsolute "../.." >>= setCurrentDirectory
setEnv "TASTY_NUM_THREADS" "1"
runInBoundThread $ defaultMain $ testGroup "Urbit"
[ DeriveNounTests.tests
, ArvoTests.tests
, AmesTests.tests
, LogTests.tests
, BehnTests.tests
]

1
stack.yaml
View File

@ -8,6 +8,7 @@ extra-deps:
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38
- base58-bytestring-0.1.0@sha256:a1da72ee89d5450bac1c792d9fcbe95ed7154ab7246f2172b57bd4fd9b5eab79
- lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00
- urbit-hob-0.1.0@sha256:ad893bb71ffcf9500820213c12cfa2544e8757ab143ebb45f9c7cc48c7536e11
nix:
packages: