ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2025-01-04 13:19:48 +03:00
Code Issues Packages Projects Releases Wiki Activity

Module structure, doc strings

Browse Source
This commit is contained in:
Benjamin Summers 2020-01-22 20:16:09 -08:00
parent 7721bae18f
commit f1cd1bf750
58 changed files with 1115 additions and 1073 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,607 +1,2 @@
{-
# Event Pruning
- `king discard-events NUM_EVENTS`: Delete the last `n` events from
the event log.
- `king discard-events-interactive`: Iterate through the events in
the event log, from last to first, pretty-print each event, and
ask if it should be pruned.
# Implement subcommands to test event and effect parsing.
- `king * --collect-fx`: All effects that come from the serf get
written into the `effects` LMDB database.
- `king clear-fx PIER`: Deletes all collected effects.
- `king full-replay PIER`: Replays the whole event log events, print
any failures. On success, replace the snapshot.
# Full Replay -- An Integration Test
- Copy the event log:
- Create a new event log at the destination.
- Stream events from the first event log.
- Parse each event.
- Re-Serialize each event.
- Verify that the round-trip was successful.
- Write the event into the new database.
- Replay the event log at the destination.
- If `--collect-fx` is set, then record effects as well.
- Snapshot.
- Verify that the final mug is the same as it was before.
# Implement Remaining Serf Flags
- `DebugRam`: Memory debugging.
- `DebugCpu`: Profiling
- `CheckCorrupt`: Heap Corruption Tests
- `CheckFatal`: TODO What is this?
- `Verbose`: TODO Just the `-v` flag?
- `DryRun`: TODO Just the `-N` flag?
- `Quiet`: TODO Just the `-q` flag?
- `Hashless`: Don't use hashboard for jets.
-}
module Main (main) where
import UrbitPrelude
import Arvo
import Config
import Data.Acquire
import Data.Conduit
import Data.Conduit.List hiding (catMaybes, map, replicate, take)
import Data.RAcquire
import Network.HTTP.Client.TLS
import RIO.Directory
import Ur.Noun hiding (Parser)
import Ur.Noun.Atom
import Ur.Noun.Conversions (cordToUW)
import Vere.Dawn
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 King.App (runApp, runAppLogFile, runPierApp)
import King.App (HasConfigDir(..))
import RIO (logSticky, logStickyDone)
import Text.Show.Pretty (pPrint)
import Urbit.Time (Wen)
import Vere.LockFile (lockFile)
import qualified CLI as CLI
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified EventBrowser as EventBrowser
import qualified Network.HTTP.Client as C
import qualified System.Console.Terminal.Size as TSize
import qualified System.Environment as Sys
import qualified System.Exit as Sys
import qualified System.IO.LockFile.Internal as Lock
import qualified System.Posix.Signals as Sys
import qualified System.ProgressBar as PB
import qualified System.Random as Sys
import qualified Urbit.Ob as Ob
import qualified Vere.Log as Log
import qualified Vere.Pier as Pier
import qualified Vere.Serf as Serf
import qualified Vere.Term as Term
--------------------------------------------------------------------------------
zod :: Ship
zod = 0
--------------------------------------------------------------------------------
removeFileIfExists :: HasLogFunc env => FilePath -> RIO env ()
removeFileIfExists pax = do
exists <- doesFileExist pax
when exists $ do
removeFile pax
--------------------------------------------------------------------------------
toSerfFlags :: CLI.Opts -> Serf.Flags
toSerfFlags CLI.Opts{..} = catMaybes m
where
-- TODO: This is not all the flags.
m = [ from oQuiet Serf.Quiet
, from oTrace Serf.Trace
, from oHashless Serf.Hashless
, from oQuiet Serf.Quiet
, from oVerbose Serf.Verbose
, from oDryRun Serf.DryRun
]
from True flag = Just flag
from False _ = Nothing
toPierConfig :: FilePath -> CLI.Opts -> PierConfig
toPierConfig pierPath CLI.Opts{..} = PierConfig
{ _pcPierPath = pierPath
, _pcDryRun = oDryRun
}
toNetworkConfig :: CLI.Opts -> NetworkConfig
toNetworkConfig CLI.Opts{..} = NetworkConfig
{ ncNetworking = if oDryRun then NetworkNone
else if oOffline then NetworkNone
else if oLocalhost then NetworkLocalhost
else NetworkNormal
, ncAmesPort = oAmesPort
}
tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> Bool -> Pill -> Bool -> Serf.Flags -> Ship
-> LegacyBootEvent
-> RIO e ()
tryBootFromPill oExit pill lite flags ship boot =
runOrExitImmediately bootedPier oExit
where
bootedPier = do
view pierPathL >>= lockFile
rio $ logTrace "Starting boot"
sls <- Pier.booted pill lite flags ship boot
rio $ logTrace "Completed boot"
pure sls
runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> RAcquire e (Serf e, Log.EventLog, SerfState)
-> Bool
-> RIO e ()
runOrExitImmediately getPier oExit =
rwith getPier $ if oExit then shutdownImmediately else runPier
where
shutdownImmediately (serf, log, ss) = do
logTrace "Sending shutdown signal"
logTrace $ displayShow ss
io $ threadDelay 500000 -- Why is this here? Do I need to force a snapshot to happen?
ss <- shutdown serf 0
logTrace $ displayShow ss
logTrace "Shutdown!"
runPier sls = do
runRAcquire $ Pier.pier sls
tryPlayShip :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> Bool -> Bool -> Serf.Flags -> RIO e ()
tryPlayShip exitImmediately fullReplay flags = do
when fullReplay wipeSnapshot
runOrExitImmediately resumeShip exitImmediately
where
wipeSnapshot = do
shipPath <- view pierPathL
logTrace "wipeSnapshot"
logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
removeFileIfExists (north shipPath)
removeFileIfExists (south shipPath)
north shipPath = shipPath <> "/.urb/chk/north.bin"
south shipPath = shipPath <> "/.urb/chk/south.bin"
resumeShip = do
view pierPathL >>= lockFile
rio $ logTrace "RESUMING SHIP"
sls <- Pier.resumed flags
rio $ logTrace "SHIP RESUMED"
pure sls
runAcquire :: (MonadUnliftIO m, MonadIO m)
=> Acquire a -> m a
runAcquire act = with act pure
runRAcquire :: (MonadUnliftIO (m e), MonadIO (m e), MonadReader e (m e))
=> RAcquire e a -> m e a
runRAcquire act = rwith act pure
--------------------------------------------------------------------------------
checkEvs :: forall e. HasLogFunc e => FilePath -> Word64 -> Word64 -> RIO e ()
checkEvs pierPath first last = do
rwith (Log.existing logPath) $ \log -> do
let ident = Log.identity log
let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
logTrace (displayShow ident)
last <- Log.lastEv log <&> \lastReal -> min last lastReal
let evCount = fromIntegral (last - first)
pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())
runConduit $ Log.streamEvents log first
.| showEvents pb first (fromIntegral $ lifecycleLen ident)
where
logPath :: FilePath
logPath = pierPath <> "/.urb/log"
showEvents :: PB.ProgressBar () -> EventId -> EventId
-> ConduitT ByteString Void (RIO e) ()
showEvents pb eId _ | eId > last = pure ()
showEvents pb eId cycle = await >>= \case
Nothing -> do
lift $ PB.killProgressBar pb
lift $ logTrace "Everything checks out."
Just bs -> do
lift $ PB.incProgress pb 1
lift $ do
n <- io $ cueBSExn bs
when (eId > cycle) $ do
(mug, wen, evNoun) <- unpackJob n
fromNounErr evNoun & \case
Left err -> logError (displayShow (eId, err))
Right (_ ∷ Ev) -> pure ()
showEvents pb (succ eId) cycle
unpackJob :: Noun -> RIO e (Mug, Wen, Noun)
unpackJob = io . fromNounExn
--------------------------------------------------------------------------------
{-
This runs the serf at `$top/.tmpdir`, but we disable snapshots,
so this should never actually be created. We just do this to avoid
letting the serf use an existing snapshot.
-}
collectAllFx :: ∀e. HasLogFunc e => FilePath -> RIO e ()
collectAllFx top = do
logTrace $ display $ pack @Text top
rwith collectedFX $ \() ->
logTrace "Done collecting effects!"
where
tmpDir :: FilePath
tmpDir = top <> "/.tmpdir"
collectedFX :: RAcquire e ()
collectedFX = do
lockFile top
log <- Log.existing (top <> "/.urb/log")
serf <- Serf.run (Serf.Config tmpDir serfFlags)
rio $ Serf.collectFX serf log
serfFlags :: Serf.Flags
serfFlags = [Serf.Hashless, Serf.DryRun]
--------------------------------------------------------------------------------
{-
Interesting
-}
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
testPill pax showPil showSeq = do
putStrLn "Reading pill file."
pillBytes <- readFile pax
putStrLn "Cueing pill file."
pillNoun <- io $ cueBS pillBytes & either throwIO pure
putStrLn "Parsing pill file."
pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure
putStrLn "Using pill to generate boot sequence."
bootSeq <- generateBootSeq zod pill False (Fake $ Ship 0)
putStrLn "Validate jam/cue and toNoun/fromNoun on pill value"
reJam <- validateNounVal pill
putStrLn "Checking if round-trip matches input file:"
unless (reJam == pillBytes) $ do
putStrLn " Our jam does not match the file...\n"
putStrLn " This is surprising, but it is probably okay."
when showPil $ do
putStrLn "\n\n== Pill ==\n"
io $ pPrint pill
when showSeq $ do
putStrLn "\n\n== Boot Sequence ==\n"
io $ pPrint bootSeq
validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a)
=> a -> RIO e ByteString
validateNounVal inpVal = do
putStrLn " jam"
inpByt <- evaluate $ jamBS $ toNoun inpVal
putStrLn " cue"
outNon <- cueBS inpByt & either throwIO pure
putStrLn " fromNoun"
outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure
putStrLn " toNoun"
outNon <- evaluate (toNoun outVal)
putStrLn " jam"
outByt <- evaluate $ jamBS outNon
putStrLn "Checking if: x == cue (jam x)"
unless (inpVal == outVal) $
error "Value fails test: x == cue (jam x)"
putStrLn "Checking if: jam x == jam (cue (jam x))"
unless (inpByt == outByt) $
error "Value fails test: jam x == jam (cue (jam x))"
pure outByt
--------------------------------------------------------------------------------
pillFrom :: CLI.PillSource -> RIO e Pill
pillFrom (CLI.PillSourceFile pillPath) = do
putStrLn $ "boot: reading pill from " ++ pack pillPath
io (loadFile pillPath >>= either throwIO pure)
pillFrom (CLI.PillSourceURL url) = do
putStrLn $ "boot: retrieving pill from " ++ pack url
-- Get the jamfile with the list of stars accepting comets right now.
manager <- io $ C.newManager tlsManagerSettings
request <- io $ C.parseRequest url
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
let body = toStrict $ C.responseBody response
noun <- cueBS body & either throwIO pure
fromNounErr noun & either (throwIO . uncurry ParseErr) pure
newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
newShip CLI.New{..} opts
| CLI.BootComet <- nBootType = do
pill <- pillFrom nPillSource
putStrLn "boot: retrieving list of stars currently accepting comets"
starList <- dawnCometList
putStrLn ("boot: " ++ (tshow $ length starList) ++
" star(s) currently accepting comets")
putStrLn "boot: mining a comet"
eny <- io $ Sys.randomIO
let seed = mineComet (Set.fromList starList) eny
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
bootFromSeed pill seed
| CLI.BootFake name <- nBootType = do
pill <- pillFrom nPillSource
ship <- shipFrom name
runTryBootFromPill pill name ship (Fake ship)
| CLI.BootFromKeyfile keyFile <- nBootType = do
text <- readFileUtf8 keyFile
asAtom <- case cordToUW (Cord $ T.strip text) of
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
Just (UW a) -> pure a
asNoun <- cueExn asAtom
seed :: Seed <- case fromNoun asNoun of
Nothing -> error "Keyfile does not seem to contain a seed."
Just s -> pure s
pill <- pillFrom nPillSource
bootFromSeed pill seed
where
shipFrom :: Text -> RIO e Ship
shipFrom name = case Ob.parsePatp name of
Left x -> error "Invalid ship name"
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
pierPath :: Text -> FilePath
pierPath name = case nPierPath of
Just x -> x
Nothing -> "./" <> unpack name
nameFromShip :: Ship -> RIO e Text
nameFromShip s = name
where
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
name = case stripPrefix "~" nameWithSig of
Nothing -> error "Urbit.ob didn't produce string with ~"
Just x -> pure x
bootFromSeed :: Pill -> Seed -> RIO e ()
bootFromSeed pill seed = do
ethReturn <- dawnVent seed
case ethReturn of
Left x -> error $ unpack x
Right dawn -> do
let ship = sShip $ dSeed dawn
name <- nameFromShip ship
runTryBootFromPill pill name ship (Dawn dawn)
flags = toSerfFlags opts
-- Now that we have all the information for running an application with a
-- PierConfig, do so.
runTryBootFromPill pill name ship bootEvent = do
let pierConfig = toPierConfig (pierPath name) opts
let networkConfig = toNetworkConfig opts
io $ runPierApp pierConfig networkConfig $
tryBootFromPill True pill nLite flags ship bootEvent
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
runShip :: CLI.Run -> CLI.Opts -> IO ()
runShip (CLI.Run pierPath) opts = do
let pierConfig = toPierConfig pierPath opts
let networkConfig = toNetworkConfig opts
runPierApp pierConfig networkConfig $
tryPlayShip (CLI.oExit opts) (CLI.oFullReplay opts) (toSerfFlags opts)
startBrowser :: HasLogFunc e => FilePath -> RIO e ()
startBrowser pierPath = runRAcquire $ do
-- lockFile pierPath
log <- Log.existing (pierPath <> "/.urb/log")
rio $ EventBrowser.run log
checkDawn :: HasLogFunc e => FilePath -> RIO e ()
checkDawn keyfilePath = do
-- The keyfile is a jammed Seed then rendered in UW format
text <- readFileUtf8 keyfilePath
asAtom <- case cordToUW (Cord $ T.strip text) of
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
Just (UW a) -> pure a
asNoun <- cueExn asAtom
seed :: Seed <- case fromNoun asNoun of
Nothing -> error "Keyfile does not seem to contain a seed."
Just s -> pure s
print $ show seed
e <- dawnVent seed
print $ show e
checkComet :: HasLogFunc e => RIO e ()
checkComet = do
starList <- dawnCometList
putStrLn "Stars currently accepting comets:"
let starNames = map (Ob.renderPatp . Ob.patp . fromIntegral) starList
print starNames
putStrLn "Trying to mine a comet..."
eny <- io $ Sys.randomIO
let s = mineComet (Set.fromList starList) eny
print s
{-
The release executable links against a terminfo library that tries
to find the terminfo database in `/nix/store/...`. Hack around this
by setting `TERMINFO_DIRS` to the standard locations, but don't
overwrite it if it's already been set by the user.
-}
terminfoHack ∷ IO ()
terminfoHack =
Sys.lookupEnv var >>= maybe (Sys.setEnv var dirs) (const $ pure ())
where
var = "TERMINFO_DIRS"
dirs = intercalate ":"
[ "/usr/share/terminfo"
, "/lib/terminfo"
]
main :: IO ()
main = do
mainTid <- myThreadId
let onTermSig = throwTo mainTid UserInterrupt
Sys.installHandler Sys.sigTERM (Sys.Catch onTermSig) Nothing
terminfoHack
CLI.parseArgs >>= \case
CLI.CmdRun r o -> runShip r o
CLI.CmdNew n o -> runApp $ newShip n o
CLI.CmdBug (CLI.CollectAllFX pax) -> runApp $ collectAllFx pax
CLI.CmdBug (CLI.EventBrowser pax) -> runApp $ startBrowser pax
CLI.CmdBug (CLI.ValidatePill pax pil s) -> runApp $ testPill pax pil s
CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l
CLI.CmdBug (CLI.ValidateFX pax f l) -> runApp $ checkFx pax f l
CLI.CmdBug (CLI.CheckDawn pax) -> runApp $ checkDawn pax
CLI.CmdBug CLI.CheckComet -> runApp $ checkComet
CLI.CmdCon pier -> runAppLogFile $ connTerm pier
--------------------------------------------------------------------------------
connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
connTerm pier =
Term.runTerminalClient pier
--------------------------------------------------------------------------------
checkFx :: HasLogFunc e
=> FilePath -> Word64 -> Word64 -> RIO e ()
checkFx pierPath first last =
rwith (Log.existing logPath) $ \log ->
runConduit $ streamFX log first last
.| tryParseFXStream
where
logPath = pierPath <> "/.urb/log"
streamFX :: HasLogFunc e
=> Log.EventLog -> Word64 -> Word64
-> ConduitT () ByteString (RIO e) ()
streamFX log first last = do
Log.streamEffectsRows log first .| loop
where
loop = await >>= \case Nothing -> pure ()
Just (eId, bs) | eId > last -> pure ()
Just (eId, bs) -> yield bs >> loop
tryParseFXStream :: HasLogFunc e => ConduitT ByteString Void (RIO e) ()
tryParseFXStream = loop
where
loop = await >>= \case
Nothing -> pure ()
Just bs -> do
n <- liftIO (cueBSExn bs)
fromNounErr n & either (logError . displayShow) pure
loop
{-
tryCopyLog :: IO ()
tryCopyLog = do
let logPath = "/Users/erg/src/urbit/zod/.urb/falselog/"
falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog2/"
persistQ <- newTQueueIO
releaseQ <- newTQueueIO
(ident, nextEv, events) <-
with (do { log <- Log.existing logPath
; Pier.runPersist log persistQ (writeTQueue releaseQ)
; pure log
})
\log -> do
ident <- pure $ Log.identity log
events <- runConduit (Log.streamEvents log 1 .| consume)
nextEv <- Log.nextEv log
pure (ident, nextEv, events)
print ident
print nextEv
print (length events)
persistQ2 <- newTQueueIO
releaseQ2 <- newTQueueIO
with (do { log <- Log.new falselogPath ident
; Pier.runPersist log persistQ2 (writeTQueue releaseQ2)
; pure log
})
$ \log2 -> do
let writs = zip [1..] events <&> \(id, a) ->
(Writ id Nothing a, [])
print "About to write"
for_ writs $ \w ->
atomically (writeTQueue persistQ2 w)
print "About to wait"
replicateM_ 100 $ do
atomically $ readTQueue releaseQ2
print "Done"
-}
module Main (module Ur.King.Main) where
import Ur.King.Main

51
pkg/hs/king/app/TryTimers.hs
View File

@ -1,51 +0,0 @@
module TryTimers where
{-
import Prelude
import Control.Lens
import Control.Concurrent.MVar (takeMVar, putMVar, newEmptyMVar)
import Control.Concurrent (threadDelay, forkIO)
import Control.Monad (replicateM_, when)
import qualified Urbit.Timer as Timer
import qualified Urbit.Behn as Behn
import qualified Urbit.Time as Time
import qualified Data.Time.Clock.System as Sys
--------------------------------------------------------------------------------
benchTimer :: Timer.Timer -> IO ()
benchTimer timer = do
now <- Sys.getSystemTime
let wen = case now of Sys.MkSystemTime s ns ->
Sys.MkSystemTime s (ns + 5_000_000)
v <- newEmptyMVar
Timer.start timer wen (putMVar v ())
takeMVar v
end <- Timer.getSystemTime
print (Timer.sysTimeGapMicroSecs wen end)
bench :: Behn.Behn -> IO ()
bench behn = do
now <- Time.now
let wen = Time.addGap now (5 ^. from Time.milliSecs)
Behn.doze behn (Just wen)
() <- Behn.wait behn
aft <- Time.now
print (Time.gap wen aft ^. Time.microSecs)
main :: IO ()
main = do
behn <- Behn.init
timer <- Timer.init
putStrLn "<benchTimer>"
replicateM_ 10 (benchTimer timer)
putStrLn "</benchTimer>"
putStrLn "<bench>"
replicateM_ 10 (bench behn)
putStrLn "</bench>"
-}

13
pkg/hs/king/lib/Arvo.hs
View File

@ -1,13 +0,0 @@
module Arvo
( module Arvo.Common
, module Arvo.Effect
, module Arvo.Event
, FX
) where
import Arvo.Common
import Arvo.Effect
import Arvo.Event
import Ur.Noun.Conversions (Lenient)
type FX = [Lenient Ef]

5
pkg/hs/king/lib/Data/RAcquire.hs
View File

@ -1,3 +1,6 @@
{-|
RAcquire = ReaderT e Acquire a
-}
module Data.RAcquire where
{-
( RAcquire (..)
@ -18,8 +21,8 @@ import qualified Data.Acquire.Internal as Act
import Control.Applicative (Applicative(..))
import Control.Monad (ap, liftM)
import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO, withRunInIO)
import Data.Typeable (Typeable)
import Control.Monad.Reader
import Data.Typeable (Typeable)
import RIO (RIO, runRIO)

13
pkg/hs/king/lib/Ur/Arvo.hs Normal file
View File

@ -0,0 +1,13 @@
module Ur.Arvo
( module Ur.Arvo.Common
, module Ur.Arvo.Effect
, module Ur.Arvo.Event
, FX
) where
import Ur.Arvo.Common
import Ur.Arvo.Effect
import Ur.Arvo.Event
import Ur.Noun.Conversions (Lenient)
type FX = [Lenient Ef]

13
pkg/hs/king/lib/Arvo/Common.hs → pkg/hs/king/lib/Ur/Arvo/Common.hs
View File

@ -1,4 +1,7 @@
module Arvo.Common
{-|
Types used in both Events and Effects.
-}
module Ur.Arvo.Common
( KingId(..), ServId(..)
, Json, JsonNode(..)
, Desk(..), Mime(..)
@ -9,7 +12,7 @@ module Arvo.Common
, AmesDest(..), Ipv4(..), Ipv6(..), Patp(..), Galaxy, AmesAddress(..)
) where
import UrbitPrelude hiding (Term)
import Ur.Prelude hiding (Term)
import qualified Network.HTTP.Types.Method as H
import qualified Urbit.Ob as Ob
@ -17,7 +20,7 @@ import qualified Urbit.Ob as Ob
-- Misc Types ------------------------------------------------------------------
{-
{-|
Domain Name in TLD order:
["org", "urbit", "dns"] -> dns.urbit.org
@ -152,7 +155,7 @@ type AmesDest = Each Galaxy (Jammed AmesAddress)
-- Path+Tagged Restructuring ---------------------------------------------------
{-
{-|
This reorganized events and effects to be easier to parse. This is
complicated and gross, and a better way should be found!
@ -214,7 +217,7 @@ instance ToNoun ReOrg where
toNoun (ReOrg fst snd tag pax val) =
toNoun ((fst, snd, pax), (tag, val))
{-
{-|
Given something parsed from a ReOrg Noun, convert that back to
a ReOrg.

35
pkg/hs/king/lib/Arvo/Effect.hs → pkg/hs/king/lib/Ur/Arvo/Effect.hs
View File

@ -1,18 +1,21 @@
module Arvo.Effect where
{-|
Effect Types and Their Noun Conversions
-}
module Ur.Arvo.Effect where
import Urbit.Time
import UrbitPrelude
import Ur.Prelude
import Ur.Time
import Arvo.Common (KingId(..), ServId(..))
import Arvo.Common (Header, HttpEvent, HttpServerConf, Method, Mime)
import Arvo.Common (AmesDest, Turf)
import Arvo.Common (ReOrg(..), reorgThroughNoun)
import Arvo.Common (Desk)
import Ur.Arvo.Common (KingId(..), ServId(..))
import Ur.Arvo.Common (Header, HttpEvent, HttpServerConf, Method, Mime)
import Ur.Arvo.Common (AmesDest, Turf)
import Ur.Arvo.Common (ReOrg(..), reorgThroughNoun)
import Ur.Arvo.Common (Desk)
-- Newt Effects ----------------------------------------------------------------
{-
{-|
%turf -- Set which domain names we've bound.
%send -- Send a UDP packet.
-}
@ -34,7 +37,7 @@ data HttpClientReq = HttpClientReq
}
deriving (Eq, Ord, Show)
{-
{-|
%request -- TODO
%cancel-request -- TODO
-}
@ -49,7 +52,7 @@ deriveNoun ''HttpClientEf
-- HTTP Server Effects ---------------------------------------------------------
{-
{-|
%set-config -- Update HTTP server configuration.
%response -- Respond to an active HTTP request.
-}
@ -63,7 +66,7 @@ deriveNoun ''HttpServerEf
-- File System Effects ---------------------------------------------------------
{-
{-|
%hill -- TODO
%dirk -- mark mount dirty
%ergo -- TODO
@ -81,7 +84,7 @@ deriveNoun ''SyncEf
-- UDP Effects -----------------------------------------------------------------
{-
{-|
%init -- "I don't think that's something that can happen"
%west -- "Those also shouldn't happen"
%woot -- "Those also shouldn't happen"
@ -97,7 +100,7 @@ deriveNoun ''AmesEf
-- Timer Effects ---------------------------------------------------------------
{-
{-|
%doze -- Set or clear timer.
%void -- Nasty hack to make the parser not treat this as a record.
-}
@ -111,7 +114,7 @@ deriveNoun ''BehnEf
-- Terminal Effects ------------------------------------------------------------
{-
{-|
%bel -- TODO
%clr -- TODO
%hop -- TODO
@ -144,7 +147,7 @@ instance Show Blit where
show (Sav path _) = "Sav " ++ (show path)
show (Url c) = "Url " ++ (show c)
{-
{-|
%blip -- TODO
%init -- TODO
%logo -- Shutdown

17
pkg/hs/king/lib/Arvo/Event.hs → pkg/hs/king/lib/Ur/Arvo/Event.hs
View File

@ -1,13 +1,16 @@
module Arvo.Event where
{-|
Event Types and Noun Conversion
-}
module Ur.Arvo.Event where
import Ur.Noun.Tree (HoonMap, HoonSet)
import UrbitPrelude hiding (Term)
import Ur.Prelude hiding (Term)
import Arvo.Common (KingId(..), ServId(..))
import Arvo.Common (Desk, Mime)
import Arvo.Common (Header(..), HttpEvent)
import Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
import Arvo.Common (ReOrg(..), reorgThroughNoun)
import Ur.Arvo.Common (KingId(..), ServId(..))
import Ur.Arvo.Common (Desk, Mime)
import Ur.Arvo.Common (Header(..), HttpEvent)
import Ur.Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf)
import Ur.Arvo.Common (ReOrg(..), reorgThroughNoun)
import qualified Crypto.Sign.Ed25519 as Ed
import qualified Data.ByteString as BS

27
pkg/hs/king/lib/King/API.hs → pkg/hs/king/lib/Ur/King/API.hs
View File

@ -1,29 +1,26 @@
{-
{-|
TODO This has a bunch of stub logic that was intended for an
architecture with a single Urbit daemon running multiple
ships. Do it or strip it out.
-}
module King.API (King(..), kingAPI, readPortsFile) where
module Ur.King.API (King(..), kingAPI, readPortsFile) where
import UrbitPrelude
-- ort Data.Aeson
import RIO.Directory
import Ur.Prelude
import Arvo (Belt)
import King.App (HasConfigDir(..))
import Network.Socket (Socket)
import Prelude (read)
-- rt Vere.LockFile (lockFile)
import Ur.Arvo (Belt)
import Ur.King.App (HasConfigDir(..))
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import qualified Network.Wai.Handler.Warp as W
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
import qualified Vere.NounServ as NounServ
import qualified Vere.Term.API as Term
import qualified Ur.Vere.NounServ as NounServ
import qualified Ur.Vere.Term.API as Term
-- Types -----------------------------------------------------------------------
@ -32,7 +29,7 @@ type TermConn = NounServ.Conn Belt [Term.Ev]
type TermConnAPI = TVar (Maybe (TermConn -> STM ()))
{-
{-|
Daemon state.
-}
data King = King
@ -43,7 +40,7 @@ data King = King
--------------------------------------------------------------------------------
{-
{-|
Get the filepath of the urbit config directory and the ports file.
-}
portsFilePath :: HasConfigDir e => RIO e (FilePath, FilePath)
@ -52,7 +49,7 @@ portsFilePath = do
fil <- pure (dir </> ".king.ports")
pure (dir, fil)
{-
{-|
Write the ports file.
-}
portsFile :: HasConfigDir e => Word -> RAcquire e (FilePath, FilePath)
@ -65,7 +62,7 @@ portsFile por =
writeFile fil (encodeUtf8 $ tshow por)
pure (dir, fil)
{-
{-|
Get the HTTP port for the running Urbit daemon.
-}
readPortsFile :: HasConfigDir e => RIO e (Maybe Word)
@ -86,7 +83,7 @@ kingServer is =
tid <- async $ io $ W.runSettingsSocket opts sock $ app env api
pure (King tid api)
{-
{-|
Start the HTTP server and write to the ports file.
-}
kingAPI :: (HasConfigDir e, HasLogFunc e)

11
pkg/hs/king/lib/King/App.hs → pkg/hs/king/lib/Ur/King/App.hs
View File

@ -1,4 +1,7 @@
module King.App
{-|
Code for setting up the RIO environment.
-}
module Ur.King.App
( App
, runApp
, runAppLogFile
@ -7,8 +10,8 @@ module King.App
, HasConfigDir(..)
) where
import Config
import UrbitPrelude
import Ur.King.Config
import Ur.Prelude
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
@ -55,7 +58,7 @@ runAppLogFile inner = withLogFileHandle (\h -> runAppLogHandle h inner)
--------------------------------------------------------------------------------
-- A PierApp is like an App, except that it also provides a PierConfig
-- | A PierApp is like an App, except that it also provides a PierConfig
data PierApp = PierApp
{ _pierAppLogFunc :: !LogFunc
, _pierAppPierConfig :: !PierConfig

15
pkg/hs/king/app/CLI.hs → pkg/hs/king/lib/Ur/King/CLI.hs
View File

@ -1,8 +1,10 @@
{-# OPTIONS_GHC -Werror -Wall #-}
{-# LANGUAGE CPP #-}
module CLI (parseArgs, Cmd(..), BootType(..), PillSource(..), New(..), Run(..),
Bug(..), Opts(..)) where
{-|
Command line parsing.
-}
module Ur.King.CLI where
import ClassyPrelude
import Options.Applicative
@ -97,7 +99,7 @@ headNote _version = string $ intercalate "\n"
, "Version " <> VERSION_king
]
-- TODO This needs to be updated.
-- | TODO This needs to be updated.
footNote :: String -> Doc
footNote exe = string $ intercalate "\n"
[ "Development Usage:"
@ -134,14 +136,17 @@ parseArgs = do
--------------------------------------------------------------------------------
defaultPillURL :: String
defaultPillURL = "https://bootstrap.urbit.org/urbit-v" <> VERSION_king <> ".pill"
defaultPillURL = "https://bootstrap.urbit.org/urbit-v" <> ver <> ".pill"
where
ver = VERSION_king
--------------------------------------------------------------------------------
newComet :: Parser BootType
newComet = flag' BootComet
( long "comet"
<> help "Boot a new comet")
<> help "Boot a new comet"
)
newFakeship :: Parser BootType
newFakeship = BootFake <$> strOption

9
pkg/hs/king/lib/Config.hs → pkg/hs/king/lib/Ur/King/Config.hs
View File

@ -1,8 +1,11 @@
module Config where
{-|
Pier Configuration
-}
module Ur.King.Config where
import UrbitPrelude
import Ur.Prelude
{-
{-|
All the configuration data revolving around a ship and the current
execution options.
-}

18
pkg/hs/king/lib/EventBrowser.hs → pkg/hs/king/lib/Ur/King/EventBrowser.hs
View File

@ -1,22 +1,24 @@
{-
{-|
Interactive Event-Log Browser
TODO Handle CTRL-D
-}
module EventBrowser (run) where
module Ur.King.EventBrowser (run) where
import UrbitPrelude
import Ur.Prelude
import Arvo
import Data.Conduit
import Urbit.Time
import Vere.Pier.Types
import Ur.Arvo
import Ur.Time
import Ur.Vere.Pier.Types
import Control.Monad.Trans.Maybe (MaybeT(..))
import Vere.Log (EventLog)
import Ur.Vere.Log (EventLog)
import qualified Data.Conduit.Combinators as C
import qualified Vere.Log as Log
import qualified Ur.Vere.Log as Log
--------------------------------------------------------------------------------

611
pkg/hs/king/lib/Ur/King/Main.hs Normal file
View File

@ -0,0 +1,611 @@
{-# OPTIONS_GHC -Wwarn #-}
{-|
King Haskell Entry Point
# Event Pruning
- `king discard-events NUM_EVENTS`: Delete the last `n` events from
the event log.
- `king discard-events-interactive`: Iterate through the events in
the event log, from last to first, pretty-print each event, and
ask if it should be pruned.
# Implement subcommands to test event and effect parsing.
- `king * --collect-fx`: All effects that come from the serf get
written into the `effects` LMDB database.
- `king clear-fx PIER`: Deletes all collected effects.
- `king full-replay PIER`: Replays the whole event log events, print
any failures. On success, replace the snapshot.
# Full Replay -- An Integration Test
- Copy the event log:
- Create a new event log at the destination.
- Stream events from the first event log.
- Parse each event.
- Re-Serialize each event.
- Verify that the round-trip was successful.
- Write the event into the new database.
- Replay the event log at the destination.
- If `--collect-fx` is set, then record effects as well.
- Snapshot.
- Verify that the final mug is the same as it was before.
# Implement Remaining Serf Flags
- `DebugRam`: Memory debugging.
- `DebugCpu`: Profiling
- `CheckCorrupt`: Heap Corruption Tests
- `CheckFatal`: TODO What is this?
- `Verbose`: TODO Just the `-v` flag?
- `DryRun`: TODO Just the `-N` flag?
- `Quiet`: TODO Just the `-q` flag?
- `Hashless`: Don't use hashboard for jets.
-}
module Ur.King.Main (main) where
import Ur.Prelude
import Data.Acquire
import Data.Conduit
import Data.Conduit.List hiding (catMaybes, map, replicate, take)
import Data.RAcquire
import Network.HTTP.Client.TLS
import RIO.Directory
import Ur.Arvo
import Ur.King.Config
import Ur.Noun hiding (Parser)
import Ur.Noun.Atom
import Ur.Noun.Conversions (cordToUW)
import Ur.Vere.Dawn
import Ur.Vere.Pier
import Ur.Vere.Pier.Types
import Ur.Vere.Serf
import Control.Concurrent (myThreadId, runInBoundThread)
import Control.Exception (AsyncException(UserInterrupt))
import Control.Lens ((&))
import Data.Default (def)
import RIO (logSticky, logStickyDone)
import Text.Show.Pretty (pPrint)
import Ur.King.App (runApp, runAppLogFile, runPierApp)
import Ur.King.App (HasConfigDir(..))
import Ur.Time (Wen)
import Ur.Vere.LockFile (lockFile)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Network.HTTP.Client as C
import qualified System.Console.Terminal.Size as TSize
import qualified System.Environment as Sys
import qualified System.Exit as Sys
import qualified System.IO.LockFile.Internal as Lock
import qualified System.Posix.Signals as Sys
import qualified System.ProgressBar as PB
import qualified System.Random as Sys
import qualified Ur.King.CLI as CLI
import qualified Ur.King.EventBrowser as EventBrowser
import qualified Ur.Vere.Log as Log
import qualified Ur.Vere.Pier as Pier
import qualified Ur.Vere.Serf as Serf
import qualified Ur.Vere.Term as Term
import qualified Urbit.Ob as Ob
--------------------------------------------------------------------------------
zod :: Ship
zod = 0
--------------------------------------------------------------------------------
removeFileIfExists :: HasLogFunc env => FilePath -> RIO env ()
removeFileIfExists pax = do
exists <- doesFileExist pax
when exists $ do
removeFile pax
--------------------------------------------------------------------------------
toSerfFlags :: CLI.Opts -> Serf.Flags
toSerfFlags CLI.Opts{..} = catMaybes m
where
-- TODO: This is not all the flags.
m = [ from oQuiet Serf.Quiet
, from oTrace Serf.Trace
, from oHashless Serf.Hashless
, from oQuiet Serf.Quiet
, from oVerbose Serf.Verbose
, from oDryRun Serf.DryRun
]
from True flag = Just flag
from False _ = Nothing
toPierConfig :: FilePath -> CLI.Opts -> PierConfig
toPierConfig pierPath CLI.Opts{..} = PierConfig
{ _pcPierPath = pierPath
, _pcDryRun = oDryRun
}
toNetworkConfig :: CLI.Opts -> NetworkConfig
toNetworkConfig CLI.Opts{..} = NetworkConfig
{ ncNetworking = if oDryRun then NetworkNone
else if oOffline then NetworkNone
else if oLocalhost then NetworkLocalhost
else NetworkNormal
, ncAmesPort = oAmesPort
}
tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> Bool -> Pill -> Bool -> Serf.Flags -> Ship
-> LegacyBootEvent
-> RIO e ()
tryBootFromPill oExit pill lite flags ship boot =
runOrExitImmediately bootedPier oExit
where
bootedPier = do
view pierPathL >>= lockFile
rio $ logTrace "Starting boot"
sls <- Pier.booted pill lite flags ship boot
rio $ logTrace "Completed boot"
pure sls
runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> RAcquire e (Serf e, Log.EventLog, SerfState)
-> Bool
-> RIO e ()
runOrExitImmediately getPier oExit =
rwith getPier $ if oExit then shutdownImmediately else runPier
where
shutdownImmediately (serf, log, ss) = do
logTrace "Sending shutdown signal"
logTrace $ displayShow ss
io $ threadDelay 500000 -- Why is this here? Do I need to force a snapshot to happen?
ss <- shutdown serf 0
logTrace $ displayShow ss
logTrace "Shutdown!"
runPier sls = do
runRAcquire $ Pier.pier sls
tryPlayShip :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> Bool -> Bool -> Serf.Flags -> RIO e ()
tryPlayShip exitImmediately fullReplay flags = do
when fullReplay wipeSnapshot
runOrExitImmediately resumeShip exitImmediately
where
wipeSnapshot = do
shipPath <- view pierPathL
logTrace "wipeSnapshot"
logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
removeFileIfExists (north shipPath)
removeFileIfExists (south shipPath)
north shipPath = shipPath <> "/.urb/chk/north.bin"
south shipPath = shipPath <> "/.urb/chk/south.bin"
resumeShip = do
view pierPathL >>= lockFile
rio $ logTrace "RESUMING SHIP"
sls <- Pier.resumed flags
rio $ logTrace "SHIP RESUMED"
pure sls
runAcquire :: (MonadUnliftIO m, MonadIO m)
=> Acquire a -> m a
runAcquire act = with act pure
runRAcquire :: (MonadUnliftIO (m e), MonadIO (m e), MonadReader e (m e))
=> RAcquire e a -> m e a
runRAcquire act = rwith act pure
--------------------------------------------------------------------------------
checkEvs :: forall e. HasLogFunc e => FilePath -> Word64 -> Word64 -> RIO e ()
checkEvs pierPath first last = do
rwith (Log.existing logPath) $ \log -> do
let ident = Log.identity log
let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
logTrace (displayShow ident)
last <- Log.lastEv log <&> \lastReal -> min last lastReal
let evCount = fromIntegral (last - first)
pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())
runConduit $ Log.streamEvents log first
.| showEvents pb first (fromIntegral $ lifecycleLen ident)
where
logPath :: FilePath
logPath = pierPath <> "/.urb/log"
showEvents :: PB.ProgressBar () -> EventId -> EventId
-> ConduitT ByteString Void (RIO e) ()
showEvents pb eId _ | eId > last = pure ()
showEvents pb eId cycle = await >>= \case
Nothing -> do
lift $ PB.killProgressBar pb
lift $ logTrace "Everything checks out."
Just bs -> do
lift $ PB.incProgress pb 1
lift $ do
n <- io $ cueBSExn bs
when (eId > cycle) $ do
(mug, wen, evNoun) <- unpackJob n
fromNounErr evNoun & \case
Left err -> logError (displayShow (eId, err))
Right (_ ∷ Ev) -> pure ()
showEvents pb (succ eId) cycle
unpackJob :: Noun -> RIO e (Mug, Wen, Noun)
unpackJob = io . fromNounExn
--------------------------------------------------------------------------------
{-|
This runs the serf at `$top/.tmpdir`, but we disable snapshots,
so this should never actually be created. We just do this to avoid
letting the serf use an existing snapshot.
-}
collectAllFx :: ∀e. HasLogFunc e => FilePath -> RIO e ()
collectAllFx top = do
logTrace $ display $ pack @Text top
rwith collectedFX $ \() ->
logTrace "Done collecting effects!"
where
tmpDir :: FilePath
tmpDir = top <> "/.tmpdir"
collectedFX :: RAcquire e ()
collectedFX = do
lockFile top
log <- Log.existing (top <> "/.urb/log")
serf <- Serf.run (Serf.Config tmpDir serfFlags)
rio $ Serf.collectFX serf log
serfFlags :: Serf.Flags
serfFlags = [Serf.Hashless, Serf.DryRun]
--------------------------------------------------------------------------------
{-|
Interesting
-}
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
testPill pax showPil showSeq = do
putStrLn "Reading pill file."
pillBytes <- readFile pax
putStrLn "Cueing pill file."
pillNoun <- io $ cueBS pillBytes & either throwIO pure
putStrLn "Parsing pill file."
pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure
putStrLn "Using pill to generate boot sequence."
bootSeq <- generateBootSeq zod pill False (Fake $ Ship 0)
putStrLn "Validate jam/cue and toNoun/fromNoun on pill value"
reJam <- validateNounVal pill
putStrLn "Checking if round-trip matches input file:"
unless (reJam == pillBytes) $ do
putStrLn " Our jam does not match the file...\n"
putStrLn " This is surprising, but it is probably okay."
when showPil $ do
putStrLn "\n\n== Pill ==\n"
io $ pPrint pill
when showSeq $ do
putStrLn "\n\n== Boot Sequence ==\n"
io $ pPrint bootSeq
validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a)
=> a -> RIO e ByteString
validateNounVal inpVal = do
putStrLn " jam"
inpByt <- evaluate $ jamBS $ toNoun inpVal
putStrLn " cue"
outNon <- cueBS inpByt & either throwIO pure
putStrLn " fromNoun"
outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure
putStrLn " toNoun"
outNon <- evaluate (toNoun outVal)
putStrLn " jam"
outByt <- evaluate $ jamBS outNon
putStrLn "Checking if: x == cue (jam x)"
unless (inpVal == outVal) $
error "Value fails test: x == cue (jam x)"
putStrLn "Checking if: jam x == jam (cue (jam x))"
unless (inpByt == outByt) $
error "Value fails test: jam x == jam (cue (jam x))"
pure outByt
--------------------------------------------------------------------------------
pillFrom :: CLI.PillSource -> RIO e Pill
pillFrom (CLI.PillSourceFile pillPath) = do
putStrLn $ "boot: reading pill from " ++ pack pillPath
io (loadFile pillPath >>= either throwIO pure)
pillFrom (CLI.PillSourceURL url) = do
putStrLn $ "boot: retrieving pill from " ++ pack url
-- Get the jamfile with the list of stars accepting comets right now.
manager <- io $ C.newManager tlsManagerSettings
request <- io $ C.parseRequest url
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
let body = toStrict $ C.responseBody response
noun <- cueBS body & either throwIO pure
fromNounErr noun & either (throwIO . uncurry ParseErr) pure
newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
newShip CLI.New{..} opts
| CLI.BootComet <- nBootType = do
pill <- pillFrom nPillSource
putStrLn "boot: retrieving list of stars currently accepting comets"
starList <- dawnCometList
putStrLn ("boot: " ++ (tshow $ length starList) ++
" star(s) currently accepting comets")
putStrLn "boot: mining a comet"
eny <- io $ Sys.randomIO
let seed = mineComet (Set.fromList starList) eny
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
bootFromSeed pill seed
| CLI.BootFake name <- nBootType = do
pill <- pillFrom nPillSource
ship <- shipFrom name
runTryBootFromPill pill name ship (Fake ship)
| CLI.BootFromKeyfile keyFile <- nBootType = do
text <- readFileUtf8 keyFile
asAtom <- case cordToUW (Cord $ T.strip text) of
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
Just (UW a) -> pure a
asNoun <- cueExn asAtom
seed :: Seed <- case fromNoun asNoun of
Nothing -> error "Keyfile does not seem to contain a seed."
Just s -> pure s
pill <- pillFrom nPillSource
bootFromSeed pill seed
where
shipFrom :: Text -> RIO e Ship
shipFrom name = case Ob.parsePatp name of
Left x -> error "Invalid ship name"
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
pierPath :: Text -> FilePath
pierPath name = case nPierPath of
Just x -> x
Nothing -> "./" <> unpack name
nameFromShip :: Ship -> RIO e Text
nameFromShip s = name
where
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
name = case stripPrefix "~" nameWithSig of
Nothing -> error "Urbit.ob didn't produce string with ~"
Just x -> pure x
bootFromSeed :: Pill -> Seed -> RIO e ()
bootFromSeed pill seed = do
ethReturn <- dawnVent seed
case ethReturn of
Left x -> error $ unpack x
Right dawn -> do
let ship = sShip $ dSeed dawn
name <- nameFromShip ship
runTryBootFromPill pill name ship (Dawn dawn)
flags = toSerfFlags opts
-- Now that we have all the information for running an application with a
-- PierConfig, do so.
runTryBootFromPill pill name ship bootEvent = do
let pierConfig = toPierConfig (pierPath name) opts
let networkConfig = toNetworkConfig opts
io $ runPierApp pierConfig networkConfig $
tryBootFromPill True pill nLite flags ship bootEvent
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
runShip :: CLI.Run -> CLI.Opts -> IO ()
runShip (CLI.Run pierPath) opts = do
let pierConfig = toPierConfig pierPath opts
let networkConfig = toNetworkConfig opts
runPierApp pierConfig networkConfig $
tryPlayShip (CLI.oExit opts) (CLI.oFullReplay opts) (toSerfFlags opts)
startBrowser :: HasLogFunc e => FilePath -> RIO e ()
startBrowser pierPath = runRAcquire $ do
-- lockFile pierPath
log <- Log.existing (pierPath <> "/.urb/log")
rio $ EventBrowser.run log
checkDawn :: HasLogFunc e => FilePath -> RIO e ()
checkDawn keyfilePath = do
-- The keyfile is a jammed Seed then rendered in UW format
text <- readFileUtf8 keyfilePath
asAtom <- case cordToUW (Cord $ T.strip text) of
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
Just (UW a) -> pure a
asNoun <- cueExn asAtom
seed :: Seed <- case fromNoun asNoun of
Nothing -> error "Keyfile does not seem to contain a seed."
Just s -> pure s
print $ show seed
e <- dawnVent seed
print $ show e
checkComet :: HasLogFunc e => RIO e ()
checkComet = do
starList <- dawnCometList
putStrLn "Stars currently accepting comets:"
let starNames = map (Ob.renderPatp . Ob.patp . fromIntegral) starList
print starNames
putStrLn "Trying to mine a comet..."
eny <- io $ Sys.randomIO
let s = mineComet (Set.fromList starList) eny
print s
{-|
The release executable links against a terminfo library that tries
to find the terminfo database in `/nix/store/...`. Hack around this
by setting `TERMINFO_DIRS` to the standard locations, but don't
overwrite it if it's already been set by the user.
-}
terminfoHack ∷ IO ()
terminfoHack =
Sys.lookupEnv var >>= maybe (Sys.setEnv var dirs) (const $ pure ())
where
var = "TERMINFO_DIRS"
dirs = intercalate ":"
[ "/usr/share/terminfo"
, "/lib/terminfo"
]
main :: IO ()
main = do
mainTid <- myThreadId
let onTermSig = throwTo mainTid UserInterrupt
Sys.installHandler Sys.sigTERM (Sys.Catch onTermSig) Nothing
terminfoHack
CLI.parseArgs >>= \case
CLI.CmdRun r o -> runShip r o
CLI.CmdNew n o -> runApp $ newShip n o
CLI.CmdBug (CLI.CollectAllFX pax) -> runApp $ collectAllFx pax
CLI.CmdBug (CLI.EventBrowser pax) -> runApp $ startBrowser pax
CLI.CmdBug (CLI.ValidatePill pax pil s) -> runApp $ testPill pax pil s
CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l
CLI.CmdBug (CLI.ValidateFX pax f l) -> runApp $ checkFx pax f l
CLI.CmdBug (CLI.CheckDawn pax) -> runApp $ checkDawn pax
CLI.CmdBug CLI.CheckComet -> runApp $ checkComet
CLI.CmdCon pier -> runAppLogFile $ connTerm pier
--------------------------------------------------------------------------------
connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
connTerm pier =
Term.runTerminalClient pier
--------------------------------------------------------------------------------
checkFx :: HasLogFunc e
=> FilePath -> Word64 -> Word64 -> RIO e ()
checkFx pierPath first last =
rwith (Log.existing logPath) $ \log ->
runConduit $ streamFX log first last
.| tryParseFXStream
where
logPath = pierPath <> "/.urb/log"
streamFX :: HasLogFunc e
=> Log.EventLog -> Word64 -> Word64
-> ConduitT () ByteString (RIO e) ()
streamFX log first last = do
Log.streamEffectsRows log first .| loop
where
loop = await >>= \case Nothing -> pure ()
Just (eId, bs) | eId > last -> pure ()
Just (eId, bs) -> yield bs >> loop
tryParseFXStream :: HasLogFunc e => ConduitT ByteString Void (RIO e) ()
tryParseFXStream = loop
where
loop = await >>= \case
Nothing -> pure ()
Just bs -> do
n <- liftIO (cueBSExn bs)
fromNounErr n & either (logError . displayShow) pure
loop
{-
tryCopyLog :: IO ()
tryCopyLog = do
let logPath = "/Users/erg/src/urbit/zod/.urb/falselog/"
falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog2/"
persistQ <- newTQueueIO
releaseQ <- newTQueueIO
(ident, nextEv, events) <-
with (do { log <- Log.existing logPath
; Pier.runPersist log persistQ (writeTQueue releaseQ)
; pure log
})
\log -> do
ident <- pure $ Log.identity log
events <- runConduit (Log.streamEvents log 1 .| consume)
nextEv <- Log.nextEv log
pure (ident, nextEv, events)
print ident
print nextEv
print (length events)
persistQ2 <- newTQueueIO
releaseQ2 <- newTQueueIO
with (do { log <- Log.new falselogPath ident
; Pier.runPersist log persistQ2 (writeTQueue releaseQ2)
; pure log
})
$ \log2 -> do
let writs = zip [1..] events <&> \(id, a) ->
(Writ id Nothing a, [])
print "About to write"
for_ writs $ \w ->
atomically (writeTQueue persistQ2 w)
print "About to wait"
replicateM_ 100 $ do
atomically $ readTQueue releaseQ2
print "Done"
-}

5
pkg/hs/king/app/TryJamPill.hs → pkg/hs/king/lib/Ur/King/TryJamPill.hs
View File

@ -1,4 +1,7 @@
module TryJamPill where
{-|
Test jam/cue on pills.
-}
module Ur.King.TryJamPill where
import ClassyPrelude
import Control.Lens

7
pkg/hs/king/lib/Ur/Noun.hs
View File

@ -1,3 +1,8 @@
{-|
Noun Library
This module just re-exports things from submodules.
-}
module Ur.Noun
( module Ur.Noun.Atom
, module Data.Word
@ -19,7 +24,6 @@ import Control.Lens
import Data.Word
import Ur.Noun.Atom
import Ur.Noun.Tree
import Ur.Noun.Conversions
import Ur.Noun.Convert
import Ur.Noun.Core
@ -27,6 +31,7 @@ import Ur.Noun.Cue
import Ur.Noun.Jam
import Ur.Noun.Tank
import Ur.Noun.TH
import Ur.Noun.Tree
--------------------------------------------------------------------------------

11
pkg/hs/king/lib/Ur/Noun/Atom.hs
View File

@ -1,10 +1,13 @@
{-
{-# OPTIONS_GHC -Werror #-}
{-|
Atom implementation with fast conversions between bytestrings
and atoms.
TODO Support 32-bit archetectures.
TODO Support Big Endian.
-}
{-# OPTIONS_GHC -Werror #-}
module Ur.Noun.Atom
( Atom(..)
, atomBitWidth#, wordBitWidth#, wordBitWidth
@ -16,7 +19,7 @@ import ClassyPrelude
import Control.Lens hiding (Index)
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import GHC.Exts (sizeofByteArray#, Ptr(Ptr))
import GHC.Exts (Ptr(Ptr), sizeofByteArray#)
import GHC.Int (Int(..))
import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#)
import GHC.Integer.GMP.Internals (indexBigNat#)

4
pkg/hs/king/lib/Ur/Noun/Conversions.hs
View File

@ -1,5 +1,9 @@
{-# OPTIONS_GHC -Wwarn #-}
{-|
Large Library of conversion between various types and Nouns.
-}
module Ur.Noun.Conversions
( Nullable(..), Jammed(..), AtomCell(..)
, Word128, Word256, Word512

3
pkg/hs/king/lib/Ur/Noun/Convert.hs
View File

@ -1,3 +1,6 @@
{-|
Framework for writing conversions between types and nouns.
-}
module Ur.Noun.Convert
( ToNoun(toNoun)
, FromNoun(parseNoun), fromNoun, fromNounErr, fromNounExn

9
pkg/hs/king/lib/Ur/Noun/Core.hs
View File

@ -2,6 +2,13 @@
{-# LANGUAGE Strict #-}
{-# LANGUAGE StrictData #-}
{-|
Core Noun Implementation
Each cell has a pre-calculated hash and a `size` field. The size is
the total number of nodes under the tree of the cell. This is used
as a heuristic to choose a hash-table size for `jam` and `cue`.
-}
module Ur.Noun.Core
( Noun, nounSize
, pattern Cell, pattern Atom
@ -13,7 +20,7 @@ import ClassyPrelude hiding (hash)
import Ur.Noun.Atom
import Control.Lens (view, from, (&), (^.))
import Control.Lens (from, view, (&), (^.))
import Data.Bits (xor)
import Data.Hashable (hash)
import GHC.Natural (Natural)

7
pkg/hs/king/lib/Ur/Noun/Cue.hs
View File

@ -1,5 +1,10 @@
{-# OPTIONS_GHC -O2 #-}
{-|
Fast implementation of `cue :: Atom -> Maybe Noun`.
Implementation is based on the approach used in `flat`.
-}
module Ur.Noun.Cue (cue, cueExn, cueBS, cueBSExn, DecodeErr) where
import ClassyPrelude
@ -319,7 +324,7 @@ dWordBits !n = do
-- Fast Cue --------------------------------------------------------------------
{-
{-|
Get the exponent-prefix of an atom:
- Peek at the next word.

20
pkg/hs/king/lib/Ur/Noun/Jam.hs
View File

@ -1,5 +1,10 @@
{-# OPTIONS_GHC -O2 #-}
{-|
Fast implementation of Jam (Noun → Atom).
This is based on the implementation of `flat`.
-}
module Ur.Noun.Jam (jam, jamBS) where
import ClassyPrelude hiding (hash)
@ -68,7 +73,7 @@ newtype Put a = Put
getRef :: Put (Maybe Word)
getRef = Put $ \tbl s -> PutResult s <$> H.lookup tbl (pos s)
{-
{-|
1. Write the register to the output, and increment the output pointer.
-}
{-# INLINE flush #-}
@ -97,7 +102,7 @@ getS = Put $ \tbl s -> pure (PutResult s s)
putS :: S -> Put ()
putS s = Put $ \tbl _ -> pure (PutResult s ())
{-
{-|
To write a bit:
| reg |= 1 << off
@ -118,7 +123,7 @@ writeBit b = Put $ \tbl s@S{..} -> do
then runPut (flush >> setRegOff 0 0) tbl s'
else pure $ PutResult s' ()
{-
{-|
To write a 64bit word:
| reg |= w << off
@ -135,7 +140,7 @@ writeWord wor = do
, reg = shiftR wor (64 - off)
}
{-
{-|
To write some bits (< 64) from a word:
| wor = takeBits(wid, wor)
@ -163,7 +168,8 @@ writeBitsFromWord wid wor = do
when (wid + off oldSt >= 64) $ do
flush
setReg (shiftR wor (wid - off newSt))
{-
{-|
Write all of the the signficant bits of a direct atom.
-}
{-# INLINE writeAtomWord# #-}
@ -175,7 +181,7 @@ writeAtomWord# w = do
writeAtomWord :: Word -> Put ()
writeAtomWord (W# w) = writeAtomWord# w
{-
{-|
Write all of the the signficant bits of an indirect atom.
TODO Use memcpy when the bit-offset of the output is divisible by 8.
@ -252,7 +258,7 @@ doPut !tbl !sz m =
--------------------------------------------------------------------------------
{-
{-|
TODO Handle back references
-}
writeNoun :: Noun -> Put ()

1
pkg/hs/king/lib/Ur/Noun/Lens.hs
View File

@ -1 +0,0 @@
module Ur.Noun.Lens where

51
pkg/hs/king/lib/Ur/Noun/Rip.hs
View File

@ -1,51 +0,0 @@
module Ur.Noun.Rip where
import ClassyPrelude
import Data.Bits
import Ur.Noun.Atom
import Control.Lens (from, view, (&))
import qualified Data.Vector.Primitive as VP
--------------------------------------------------------------------------------
takeBits ∷ Word → Word → Word
takeBits 64 w = w
takeBits 0 w = 0
takeBits n w = w .&. (shiftL 1 (fromIntegral n) - 1)
divCeil ∷ Word → Word → Word
divCeil 0 y = 0
divCeil x y = 1 + ((x-1) `div` y)
--------------------------------------------------------------------------------
repn :: Word -> [Word] -> Atom
repn bits blox =
(bits > 64) & \case
True → error "repn only works with block sizes <= 64"
False → view (from atomWords)
$ VP.fromList
$ finish
$ foldl' f ([], 0, 0)
$ zip (repeat bits) blox
where
finish (acc, wor, n) = reverse
$ dropWhile (==0)
$ case n of { 0 -> acc; _ -> wor:acc }
slice size off wor = shiftL (takeBits size wor)
$ fromIntegral off
f (acc, wor, off) (remBlok, blok) =
let rem = 64 - off in
compare remBlok rem & \case
LT -> (acc, res, off+bits)
where res = wor .|. slice bits off blok
EQ -> (res:acc, 0, 0)
where res = (wor .|. slice bits off blok)
GT -> f (res:acc, 0, 0) (remBlok', blok')
where res = wor .|. slice rem off blok
remBlok' = remBlok-rem
blok' = shiftR blok (fromIntegral bits)

5
pkg/hs/king/lib/Ur/Noun/TH.hs
View File

@ -1,7 +1,6 @@
{-
Generate FromNoun and ToNoun instances.
{-|
Template Haskell Code to Generate FromNoun and ToNoun Instances
-}
module Ur.Noun.TH (deriveNoun, deriveToNoun, deriveFromNoun) where
import ClassyPrelude hiding (fromList)

4
pkg/hs/king/lib/Ur/Noun/Tank.hs
View File

@ -1,3 +1,7 @@
{-|
Pretty Printer Types
-}
module Ur.Noun.Tank where
import ClassyPrelude

6
pkg/hs/king/lib/Ur/Noun/Tree.hs
View File

@ -1,5 +1,9 @@
{-# LANGUAGE DuplicateRecordFields, DisambiguateRecordFields #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-|
Hoon's `map` and `set` types and conversions to/from Nouns.
-}
module Ur.Noun.Tree
( HoonSet, setToHoonSet, setFromHoonSet
, HoonMap, mapToHoonMap, mapFromHoonMap

10
pkg/hs/king/lib/UrbitPrelude.hs → pkg/hs/king/lib/Ur/Prelude.hs
View File

@ -1,4 +1,8 @@
module UrbitPrelude
{-|
Convenient Re-Exports
-}
module Ur.Prelude
( module ClassyPrelude
, module Control.Arrow
, module Control.Lens
@ -16,8 +20,8 @@ module UrbitPrelude
import ClassyPrelude
import Ur.Noun
import Control.Lens hiding (Index, cons, index, snoc, uncons, unsnoc, (<.>),
(<|), Each)
import Control.Lens hiding (Each, Index, cons, index, snoc, uncons, unsnoc,
(<.>), (<|))
import Control.Arrow ((<<<), (>>>))
import Data.Acquire (Acquire, mkAcquire, with)

6
pkg/hs/king/lib/Urbit/Time.hs → pkg/hs/king/lib/Ur/Time.hs
View File

@ -1,6 +1,8 @@
-- TODO This is slow.
{-|
TODO This is slow.
-}
module Urbit.Time where
module Ur.Time where
import Control.Lens
import Prelude

2
pkg/hs/king/lib/Urbit/Timer.hs → pkg/hs/king/lib/Ur/Timer.hs
View File

@ -1,4 +1,4 @@
module Urbit.Timer ( Timer(..), init, stop, start
module Ur.Timer ( Timer(..), init, stop, start
, Sys.getSystemTime, sysTimeGapMicroSecs
) where

21
pkg/hs/king/lib/Vere/Ames.hs → pkg/hs/king/lib/Ur/Vere/Ames.hs
View File

@ -1,18 +1,22 @@
module Vere.Ames (ames) where
{-|
Ames IO Driver -- UDP
-}
import UrbitPrelude
module Ur.Vere.Ames (ames) where
import Ur.Prelude
import Arvo hiding (Fake)
import Config
import Control.Monad.Extra hiding (mapM_)
import Network.Socket hiding (recvFrom, sendTo)
import Network.Socket.ByteString
import Vere.Pier.Types
import Ur.Arvo hiding (Fake)
import Ur.King.Config
import Ur.Vere.Pier.Types
import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Ur.Time as Time
import qualified Urbit.Ob as Ob
import qualified Urbit.Time as Time
-- Types -----------------------------------------------------------------------
@ -28,6 +32,7 @@ data AmesDrv = AmesDrv
data NetworkMode = Fake | Localhost | Real | NoNetwork
deriving (Eq, Ord, Show)
-- Utils -----------------------------------------------------------------------
galaxyPort :: NetworkMode -> Galaxy -> PortNumber
@ -74,9 +79,10 @@ _turfText = intercalate "." . reverse . fmap unCord . unTurf
renderGalaxy :: Galaxy -> Text
renderGalaxy = Ob.renderPatp . Ob.patp . fromIntegral . unPatp
--------------------------------------------------------------------------------
{-
{-|
inst -- Process instance number.
who -- Which ship are we?
enqueueEv -- Queue-event action.
@ -297,4 +303,3 @@ ames inst who isFake enqueueEv stderr =
queueSendToGalaxy :: SockAddr -> ByteString -> RIO e ()
queueSendToGalaxy inet packet = do
atomically $ writeTQueue outgoing (inet, packet)

20
pkg/hs/king/lib/Vere/Behn.hs → pkg/hs/king/lib/Ur/Vere/Behn.hs
View File

@ -1,14 +1,18 @@
module Vere.Behn (behn) where
{-|
Behn: Timer Driver
-}
import UrbitPrelude
import Arvo hiding (Behn)
import Vere.Pier.Types
module Ur.Vere.Behn (behn) where
import Urbit.Time (Wen)
import Urbit.Timer (Timer)
import Ur.Arvo hiding (Behn)
import Ur.Prelude
import Ur.Vere.Pier.Types
import qualified Urbit.Time as Time
import qualified Urbit.Timer as Timer
import Ur.Time (Wen)
import Ur.Timer (Timer)
import qualified Ur.Time as Time
import qualified Ur.Timer as Timer
-- Behn Stuff ------------------------------------------------------------------

51
pkg/hs/king/lib/Vere/Clay.hs → pkg/hs/king/lib/Ur/Vere/Clay.hs
View File

@ -1,9 +1,13 @@
module Vere.Clay (clay) where
{-|
UNIX Filesystem Driver
-}
import Arvo hiding (Term)
import Config
import UrbitPrelude
import Vere.Pier.Types
module Ur.Vere.Clay (clay) where
import Ur.Arvo hiding (Term)
import Ur.King.Config
import Ur.Prelude
import Ur.Vere.Pier.Types
import Conduit
import RIO.Directory
@ -13,6 +17,9 @@ import qualified Data.Conduit.Combinators as CC
import qualified Data.Map.Strict as M
import qualified Data.Set as S
--------------------------------------------------------------------------------
data ClayDrv = ClayDrv
{ cdMountPoints :: TVar (Map Desk (Map FilePath Int))
}
@ -20,10 +27,10 @@ data ClayDrv = ClayDrv
deskToPath :: Desk -> FilePath
deskToPath (Desk (Cord t)) = unpack t
-- The hard coded mime type of every file.
-- | The hard coded mime type of every file.
textPlain = Path [(MkKnot "text"), (MkKnot "plain")]
-- Filter for dotfiles, tempfiles and backup files.
-- | Filter for dotfiles, tempfiles and backup files.
validClaySyncPath :: FilePath -> Bool
validClaySyncPath fp = hasPeriod && notTildeFile && notDotHash && notDoubleHash
where
@ -34,8 +41,10 @@ validClaySyncPath fp = hasPeriod && notTildeFile && notDotHash && notDoubleHash
notDoubleHash =
not $ ("#" `isPrefixOf` fileName) && ("#" `isSuffixOf` fileName)
-- Returns a list of the result of running a function on each valid file in the
-- directory fp. Runnable in IO.
{-|
Returns a list of the result of running a function on each valid
file in the directory fp. Runnable in IO.
-}
foreachFileIn :: (MonadUnliftIO m)
=> FilePath -> (FilePath -> (ResourceT m) a) -> m [a]
foreachFileIn fp fun =
@ -44,17 +53,21 @@ foreachFileIn fp fun =
.| CC.mapM fun
.| sinkList
-- Note: Vere just reuses +mug, but since the actual hash function is an
-- implementation detail which doesn't leave the io driver, we just use the
-- standard hash.
{-|
Note: Vere just reuses +mug, but since the actual hash function is
an implementation detail which doesn't leave the io driver, we just
use the standard hash.
-}
getHashOfFile :: (MonadIO m) => FilePath -> m (FilePath, Int)
getHashOfFile fp = do
bs <- readFile fp
let !h = hash bs
pure (fp, h)
-- Takes an initial snapshot of the filesystem, recording what files exist and
-- what their hashes are.
{-|
Takes an initial snapshot of the filesystem, recording what files exist and
what their hashes are.
-}
takeFilesystemSnapshot :: FilePath -> RIO e (Map FilePath Int)
takeFilesystemSnapshot fp = do
exists <- doesDirectoryExist fp
@ -63,8 +76,10 @@ takeFilesystemSnapshot fp = do
else
M.fromList <$> foreachFileIn fp getHashOfFile
-- Check an existing filepath against a snapshot of files that existed on disk
-- the last time we checked. Returns Either (unchanged) (new file data).
{-|
Check an existing filepath against a snapshot of files that existed on disk
the last time we checked. Returns Either (unchanged) (new file data).
-}
checkFileForUpdates :: (MonadIO m)
=> Map FilePath Int -> FilePath
-> m (Either FilePath (FilePath, Mime, Int))
@ -77,7 +92,9 @@ checkFileForUpdates snapshot fp = do
Just i -> if i == newHash then Left fp
else Right (fp, (Mime textPlain (File (Octs bs))), newHash)
-- Given a previous snapshot of the filesystem, produces a list of changes
{-|
Given a previous snapshot of the filesystem, produces a list of changes
-}
buildActionListFromDifferences :: FilePath -> Map FilePath Int
-> RIO e [(FilePath, Maybe (Mime, Int))]
buildActionListFromDifferences fp snapshot = do

14
pkg/hs/king/lib/Vere/Dawn.hs → pkg/hs/king/lib/Ur/Vere/Dawn.hs
View File

@ -1,8 +1,12 @@
module Vere.Dawn where
{-|
Use etherium to access PKI information.
-}
import Arvo.Common
import Arvo.Event hiding (Address)
import UrbitPrelude hiding (Call, rights, to)
module Ur.Vere.Dawn where
import Ur.Arvo.Common
import Ur.Arvo.Event hiding (Address)
import Ur.Prelude hiding (Call, rights, to)
import Data.Bits (xor)
import Data.List (nub)
@ -14,7 +18,6 @@ import Network.Ethereum.Api.Types hiding (blockNumber)
import Network.Ethereum.Web3
import Network.HTTP.Client.TLS
import qualified Ur.Azimuth as AZ
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Crypto.Hash.SHA512 as SHA512
import qualified Crypto.Sign.Ed25519 as Ed
@ -24,6 +27,7 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import qualified Network.Ethereum.Ens as Ens
import qualified Network.HTTP.Client as C
import qualified Ur.Azimuth as AZ
import qualified Urbit.Ob as Ob
-- During boot, use the infura provider

8
pkg/hs/king/lib/Vere/Http.hs → pkg/hs/king/lib/Ur/Vere/Http.hs
View File

@ -1,10 +1,12 @@
-- zuse: +http -----------------------------------------------------------------
{-|
HTTP Driver
-}
module Vere.Http where
module Ur.Vere.Http where
import ClassyPrelude
import Ur.Arvo
import Ur.Noun
import Arvo
import qualified Data.CaseInsensitive as CI
import qualified Network.HTTP.Types as HT

20
pkg/hs/king/lib/Vere/Http/Client.hs → pkg/hs/king/lib/Ur/Vere/Http/Client.hs
View File

@ -1,17 +1,19 @@
{-
- TODO When making a request, handle the case where the request id is
{-|
Http Client Driver
TODO When making a request, handle the case where the request id is
already in use.
-}
module Vere.Http.Client where
module Ur.Vere.Http.Client where
import Arvo (BlipEv(..), Ev(..), HttpClientEf(..), HttpClientEv(..),
HttpClientReq(..), HttpEvent(..), KingId,
ResponseHeader(..))
import UrbitPrelude hiding (Builder)
import Vere.Pier.Types
import Ur.Arvo (BlipEv(..), Ev(..), HttpClientEf(..),
HttpClientEv(..), HttpClientReq(..), HttpEvent(..),
KingId, ResponseHeader(..))
import Ur.Prelude hiding (Builder)
import Ur.Vere.Pier.Types
import Vere.Http
import Ur.Vere.Http
import qualified Data.Map as M
import qualified Network.HTTP.Client as H

35
pkg/hs/king/lib/Vere/Http/Server.hs → pkg/hs/king/lib/Ur/Vere/Http/Server.hs
View File

@ -1,10 +1,8 @@
{-
{-|
Http Server Driver
TODO Make sure that HTTP sockets get closed on shutdown.
-}
{-# OPTIONS_GHC -Wwarn #-}
{-
TODO What is this about?
// if we don't explicitly set this field, h2o will send with
@ -24,21 +22,23 @@
"hosed";
-}
module Vere.Http.Server where
{-# OPTIONS_GHC -Wwarn #-}
module Ur.Vere.Http.Server where
import Arvo hiding (ServerId, reqBody, reqUrl, secure)
import Config
import Data.Conduit
import Ur.Arvo hiding (ServerId, reqBody, reqUrl, secure)
import Ur.King.Config
import Ur.Noun
import UrbitPrelude hiding (Builder)
import Vere.Pier.Types
import Ur.Prelude hiding (Builder)
import Ur.Vere.Pier.Types
import Data.Binary.Builder (Builder, fromByteString)
import Data.Bits (shiftL, (.|.))
import Network.Socket (SockAddr(..))
import System.Directory (doesFileExist, removeFile)
import System.Random (randomIO)
import Vere.Http (convertHeaders, unconvertHeaders)
import Ur.Vere.Http (convertHeaders, unconvertHeaders)
import qualified Network.HTTP.Types as H
import qualified Network.Socket as Net
@ -53,7 +53,7 @@ import qualified Network.Wai.Handler.WarpTLS as W
type ReqId = UD
type SeqId = UD -- Unused, always 1
{-
{-|
The sequence of actions on a given request *should* be:
[%head .] [%bloc .]* %done
@ -115,7 +115,7 @@ reorgHttpEvent = \case
-- Generic Service Stop/Restart -- Using an MVar for Atomicity -----------------
{-
{-|
Restart a running service.
This can probably be made simpler, but it
@ -295,7 +295,7 @@ data Resp
| RNone
deriving (Show)
{-
{-|
This accepts all action orderings so that there are no edge-cases
to be handled:
@ -313,7 +313,7 @@ getResp tmv = go []
RABloc ç -> go (ç : çunks)
RADone -> pure RNone
{-
{-|
- Immediatly yield all of the initial chunks
- Yield the data from %bloc action.
- Close the stream when we hit a %done action.
@ -389,7 +389,7 @@ app env sId liv plan which req respond =
-- Top-Level Driver Interface --------------------------------------------------
{-
{-|
Opens a socket on some port, accepting connections from `127.0.0.1`
if fake and `0.0.0.0` if real.
@ -429,9 +429,6 @@ openPort isFake = go
Left exn -> Net.close sok $> Left exn
Right por -> pure (Right (fromIntegral por, sok))
{-
TODO Need to find an open port.
-}
startServ :: (HasPierConfig e, HasLogFunc e)
=> Bool -> HttpServerConf -> (Ev -> STM ())
-> RIO e Serv

22
pkg/hs/king/lib/Vere/LMDB.hs → pkg/hs/king/lib/Ur/Vere/LMDB.hs
View File

@ -1,18 +1,20 @@
module Vere.LMDB where
{-|
Low-Level Inferface for LMDB Event Log.
-}
import UrbitPrelude hiding (init)
module Ur.Vere.LMDB where
import Ur.Prelude hiding (init)
import Data.RAcquire
-- import Data.Conduit
import Database.LMDB.Raw
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Vere.Pier.Types
import Ur.Vere.Pier.Types
import Foreign.Storable (peek, poke, sizeOf)
import qualified Data.ByteString.Unsafe as BU
-- import qualified Data.Vector as V
-- Types -----------------------------------------------------------------------
@ -38,7 +40,7 @@ instance Exception VereLMDBExn where
-- Transactions ----------------------------------------------------------------
{-
{-|
A read-only transaction that commits at the end.
Use this when opening database handles.
@ -49,7 +51,7 @@ openTxn env = mkRAcquire begin commit
begin = io $ mdb_txn_begin env Nothing True
commit = io . mdb_txn_commit
{-
{-|
A read-only transaction that aborts at the end.
Use this when reading data from already-opened databases.
@ -60,7 +62,7 @@ readTxn env = mkRAcquire begin abort
begin = io $ mdb_txn_begin env Nothing True
abort = io . mdb_txn_abort
{-
{-|
A read-write transaction that commits upon sucessful completion and
aborts on exception.
@ -315,11 +317,9 @@ putNoun flags txn db key val =
byteStringAsMdbVal (jamBS val) $ \mVal ->
mdb_put flags txn db mKey mVal
putBytes :: MonadIO m
=> MDB_WriteFlags -> Txn -> Dbi -> Word64 -> ByteString -> m Bool
putBytes flags txn db id bs =
io $
putBytes flags txn db id bs = io $
withWord64AsMDBval id $ \idVal ->
byteStringAsMdbVal bs $ \mVal ->
mdb_put flags txn db idVal mVal

8
pkg/hs/king/lib/Vere/LockFile.hs → pkg/hs/king/lib/Ur/Vere/LockFile.hs
View File

@ -1,6 +1,10 @@
module Vere.LockFile (lockFile) where
{-|
Acquire and release the vere lockfile.
-}
import UrbitPrelude
module Ur.Vere.LockFile (lockFile) where
import Ur.Prelude
import Data.Default (def)
import RIO.Directory (createDirectoryIfMissing)

24
pkg/hs/king/lib/Vere/Log.hs → pkg/hs/king/lib/Ur/Vere/Log.hs
View File

@ -1,21 +1,23 @@
{-
{-|
High-Level Event-Log Interface
TODO Effects storage logic is messy.
-}
module Vere.Log ( EventLog, identity, nextEv, lastEv
module Ur.Vere.Log ( EventLog, identity, nextEv, lastEv
, new, existing
, streamEvents, appendEvents, trimEvents
, streamEffectsRows, writeEffectsRow
) where
import UrbitPrelude hiding (init)
import Ur.Prelude hiding (init)
import Data.RAcquire
import Data.Conduit
import Data.RAcquire
import Database.LMDB.Raw
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Vere.Pier.Types
import Ur.Vere.Pier.Types
import Foreign.Storable (peek, poke, sizeOf)
@ -125,7 +127,7 @@ new dir id = mkRAcquire (create dir id) (close dir)
-- Read/Write Log Identity -----------------------------------------------------
{-
{-|
A read-only transaction that commits at the end.
Use this when opening database handles.
@ -136,7 +138,7 @@ _openTxn env = mkRAcquire begin commit
begin = io $ mdb_txn_begin env Nothing True
commit = io . mdb_txn_commit
{-
{-|
A read-only transaction that aborts at the end.
Use this when reading data from already-opened databases.
@ -147,7 +149,7 @@ readTxn env = mkRAcquire begin abort
begin = io $ mdb_txn_begin env Nothing True
abort = io . mdb_txn_abort
{-
{-|
A read-write transaction that commits upon sucessful completion and
aborts on exception.
@ -248,7 +250,6 @@ writeEffectsRow log k v = do
flags = compileWriteFlags []
--------------------------------------------------------------------------------
-- Read Events -----------------------------------------------------------------
trimEvents :: HasLogFunc e => EventLog -> Word64 -> RIO e ()
@ -285,7 +286,7 @@ streamEffectsRows log = go
for_ batch yield
go (next + fromIntegral (length batch))
{-
{-|
Read 1000 rows from the events table, starting from event `first`.
Throws `MissingEvent` if an event was missing from the log.
@ -322,7 +323,7 @@ readBatch log first = start
assertFound idx =<< io (mdb_cursor_get MDB_NEXT cur pKey pVal)
pure val
{-
{-|
Read 1000 rows from the database, starting from key `first`.
-}
readRowsBatch :: ∀e. HasLogFunc e
@ -420,7 +421,6 @@ putNoun flags txn db key val =
byteStringAsMdbVal (jamBS val) $ \mVal ->
mdb_put flags txn db mKey mVal
putBytes :: MonadIO m
=> MDB_WriteFlags -> Txn -> Dbi -> Word64 -> ByteString -> m Bool
putBytes flags txn db id bs =

8
pkg/hs/king/lib/Vere/NounServ.hs → pkg/hs/king/lib/Ur/Vere/NounServ.hs
View File

@ -1,4 +1,8 @@
module Vere.NounServ
{-|
Use websockets to pass nouns between a client and server.
-}
module Ur.Vere.NounServ
( Conn(..)
, Server(..)
, Client(..)
@ -10,7 +14,7 @@ module Vere.NounServ
, wsConn
) where
import UrbitPrelude
import Ur.Prelude
import qualified Network.Wai.Handler.Warp as W
import qualified Network.WebSockets as WS

46
pkg/hs/king/lib/Vere/Pier.hs → pkg/hs/king/lib/Ur/Vere/Pier.hs
View File

@ -1,38 +1,44 @@
{-# OPTIONS_GHC -Wwarn #-}
module Vere.Pier
{-|
Top-Level Pier Management
This is the code that starts the IO drivers and deals with
communication between the serf, the log, and the IO drivers.
-}
module Ur.Vere.Pier
( booted, resumed, pier, runPersist, runCompute, generateBootSeq
) where
import UrbitPrelude
import Ur.Prelude
import Arvo
import Config
import System.Random
import Vere.Pier.Types
import Ur.Arvo
import Ur.King.Config
import Ur.Vere.Pier.Types
import Data.Text (append)
import King.App (HasConfigDir(..))
import System.Posix.Files (ownerModes, setFileMode)
import Vere.Ames (ames)
import Vere.Behn (behn)
import Vere.Clay (clay)
import Vere.Http.Client (client)
import Vere.Http.Server (serv)
import Vere.Log (EventLog)
import Vere.Serf (Serf, SerfState(..), doJob, sStderr)
import Ur.King.App (HasConfigDir(..))
import Ur.Vere.Ames (ames)
import Ur.Vere.Behn (behn)
import Ur.Vere.Clay (clay)
import Ur.Vere.Http.Client (client)
import Ur.Vere.Http.Server (serv)
import Ur.Vere.Log (EventLog)
import Ur.Vere.Serf (Serf, SerfState(..), doJob, sStderr)
import RIO.Directory
import qualified King.API as King
import qualified System.Console.Terminal.Size as TSize
import qualified System.Entropy as Ent
import qualified Urbit.Time as Time
import qualified Vere.Log as Log
import qualified Vere.Serf as Serf
import qualified Vere.Term as Term
import qualified Vere.Term.API as Term
import qualified Vere.Term.Demux as Term
import qualified Ur.King.API as King
import qualified Ur.Time as Time
import qualified Ur.Vere.Log as Log
import qualified Ur.Vere.Serf as Serf
import qualified Ur.Vere.Term as Term
import qualified Ur.Vere.Term.API as Term
import qualified Ur.Vere.Term.Demux as Term
--------------------------------------------------------------------------------

19
pkg/hs/king/lib/Vere/Pier/Types.hs → pkg/hs/king/lib/Ur/Vere/Pier/Types.hs
View File

@ -1,14 +1,19 @@
module Vere.Pier.Types where
{-|
A bunch of common types.
import UrbitPrelude hiding (Term)
TODO Most of these could probably find better homes.
-}
module Ur.Vere.Pier.Types where
import Arvo
import Urbit.Time
import Ur.Prelude hiding (Term)
import Ur.Arvo
import Ur.Time
-- Avoid touching Nock values. -------------------------------------------------
{-
{-|
Nock values are raw nouns with tons of duplicated structure, so
printing or comparing them is insane.
-}
@ -90,8 +95,6 @@ data IODriver = IODriver
, startDriver :: (Ev -> STM ()) -> IO (Async (), Perform)
}
--------------------------------------------------------------------------------
-- Instances -------------------------------------------------------------------
@ -111,7 +114,7 @@ instance FromNoun LifeCyc where
(eid, Jammed (m, n)) <- parseNoun n
pure (LifeCyc eid m n)
-- No FromNoun instance, because it depends on context (lifecycle length)
-- | No FromNoun instance, because it depends on context (lifecycle length)
instance ToNoun Job where
toNoun (DoWork w) = toNoun w
toNoun (RunNok l) = toNoun l

32
pkg/hs/king/lib/Vere/Serf.hs → pkg/hs/king/lib/Ur/Vere/Serf.hs
View File

@ -1,23 +1,25 @@
{-# OPTIONS_GHC -Wwarn #-}
{-
- TODO: `recvLen` is not big-endian safe.
{-|
Serf Interface
TODO: `recvLen` is not big-endian safe.
-}
module Vere.Serf ( Serf, sStderr, SerfState(..), doJob
module Ur.Vere.Serf ( Serf, sStderr, SerfState(..), doJob
, run, shutdown, kill
, replay, bootFromSeq, snapshot
, collectFX
, Config(..), Flags, Flag(..)
) where
import UrbitPrelude
import Ur.Prelude
import Arvo
import Data.Conduit
import System.Process
import System.ProgressBar
import Vere.Pier.Types
import Ur.Arvo
import Ur.Vere.Pier.Types
import Data.Bits (setBit)
import Data.ByteString (hGet)
@ -33,8 +35,8 @@ import qualified Data.ByteString.Unsafe as BS
import qualified Data.Text as T
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
import qualified Ur.Time as Time
import qualified Ur.Vere.Log as Log
-- Serf Config -----------------------------------------------------------------
@ -121,9 +123,10 @@ deriveNoun ''Plea
-- Utils -----------------------------------------------------------------------
printTank :: HasLogFunc e => MVar (Text -> RIO e ()) -> Word32 -> Tank -> RIO e ()
printTank log _pri tank =
((printErr log) . unlines . fmap unTape . wash (WashCfg 0 80)) tank
printTank :: HasLogFunc e
=> MVar (Text -> RIO e ()) -> Word32 -> Tank
-> RIO e ()
printTank log _pri = printErr log . unlines . fmap unTape . wash (WashCfg 0 80)
guardExn :: (Exception e, MonadIO m) => Bool -> e -> m ()
guardExn ok = io . unless ok . throwIO
@ -137,6 +140,7 @@ printErr m txt = do
f <- readMVar m
f txt
-- Process Management ----------------------------------------------------------
run :: HasLogFunc e => Config -> RAcquire e (Serf e)
@ -276,7 +280,7 @@ snapshot serf ss = sendOrder serf $ OSave $ ssLastEv ss
shutdown :: HasLogFunc e => Serf e -> Word8 -> RIO e ()
shutdown serf code = sendOrder serf (OExit code)
{-
{-|
TODO Find a cleaner way to handle `PStdr` Pleas.
-}
recvPlea :: HasLogFunc e => Serf e -> RIO e Plea
@ -294,7 +298,7 @@ recvPlea w = do
_ -> do logTrace "recvPlea got something else"
pure p
{-
{-|
Waits for initial plea, and then sends boot IPC if necessary.
-}
handshake :: HasLogFunc e => Serf e -> LogIdentity -> RIO e SerfState
@ -414,7 +418,7 @@ bootFromSeq serf (BootSeq ident nocks ovums) = do
fakeStr True = "fake "
fakeStr False = ""
{-
{-|
The ship is booted, but it is behind. shove events to the worker
until it is caught up.
-}

47
pkg/hs/king/lib/Vere/Term.hs → pkg/hs/king/lib/Ur/Vere/Term.hs
View File

@ -1,4 +1,7 @@
module Vere.Term
{-|
Terminal Driver
-}
module Ur.Vere.Term
( module Term
, localClient
, connectToRemote
@ -7,8 +10,6 @@ module Vere.Term
, term
) where
import Arvo hiding (Term)
import Config
import Data.Char
import Foreign.Marshal.Alloc
import Foreign.Ptr
@ -16,27 +17,29 @@ import Foreign.Storable
import RIO.FilePath
import System.Posix.IO
import System.Posix.Terminal
import Urbit.Time
import UrbitPrelude hiding (getCurrentTime)
import Vere.Pier.Types
import Ur.Arvo hiding (Term)
import Ur.King.Config
import Ur.Prelude hiding (getCurrentTime)
import Ur.Time
import Ur.Vere.Pier.Types
import Data.List ((!!))
import King.API (readPortsFile)
import King.App (HasConfigDir(..))
import RIO.Directory (createDirectoryIfMissing)
import Vere.Term.API (Client(Client))
import Ur.King.API (readPortsFile)
import Ur.King.App (HasConfigDir(..))
import Ur.Vere.Term.API (Client(Client))
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.UTF8 as BS
import qualified System.Console.Terminal.Size as TSize
import qualified System.Console.Terminfo.Base as T
import qualified Vere.NounServ as Serv
import qualified Vere.Term.API as Term
import qualified Ur.Vere.NounServ as Serv
import qualified Ur.Vere.Term.API as Term
-- Types -----------------------------------------------------------------------
-- All stateful data in the printing to stdOutput.
-- | All stateful data in the printing to stdOutput.
data LineState = LineState
{ lsLine :: Text
, lsCurPos :: Int
@ -47,7 +50,7 @@ data LineState = LineState
, lsPrevEndTime :: Wen
}
-- A record used in reading data from stdInput.
-- | A record used in reading data from stdInput.
data ReadData = ReadData
{ rdBuf :: Ptr Word8
, rdEscape :: Bool
@ -56,7 +59,7 @@ data ReadData = ReadData
, rdUTF8width :: Int
}
-- Private data to the Client that we keep around for stop().
-- | Private data to the Client that we keep around for stop().
data Private = Private
{ pReaderThread :: Async ()
, pWriterThread :: Async ()
@ -92,7 +95,8 @@ _spin_idle_us = 500000
--------------------------------------------------------------------------------
runMaybeTermOutput :: T.Terminal -> (T.Terminal -> Maybe T.TermOutput) -> RIO e ()
runMaybeTermOutput :: T.Terminal -> (T.Terminal -> Maybe T.TermOutput)
-> RIO e ()
runMaybeTermOutput t getter = case (getter t) of
Nothing -> pure ()
Just x -> io $ T.runTermOutput t x
@ -103,9 +107,11 @@ rioAllocaBytes size action =
withRunInIO $ \run ->
allocaBytes size $ \x -> run (action x)
-- Because of legacy reasons, some file operations are in the terminal
-- driver. These should be filtered out and handled locally instead of in any
-- abstractly connected terminal.
{-|
Because of legacy reasons, some file operations are in the terminal
driver. These should be filtered out and handled locally instead of
in any abstractly connected terminal.
-}
isTerminalBlit :: Blit -> Bool
isTerminalBlit (Sav _ _) = False
isTerminalBlit (Sag _ _) = False
@ -158,7 +164,7 @@ runTerminalClient pier = runRAcquire $ do
runRAcquire :: RAcquire e () -> RIO e ()
runRAcquire act = rwith act $ const $ pure ()
{-
{-|
Initializes the generalized input/output parts of the terminal.
-}
localClient :: ∀e. HasLogFunc e
@ -511,6 +517,9 @@ localClient doneSignal = fst <$> mkRAcquire start stop
--------------------------------------------------------------------------------
{-|
Terminal Driver
-}
term :: forall e. (HasPierConfig e, HasLogFunc e)
=> (TSize.Window Word, Client)
-> (STM ())

11
pkg/hs/king/lib/Vere/Term/API.hs → pkg/hs/king/lib/Ur/Vere/Term/API.hs
View File

@ -1,13 +1,16 @@
module Vere.Term.API (Ev(..), Client(..), trace, spin, stopSpin) where
{-|
Interface Terminal API.
-}
module Ur.Vere.Term.API (Ev(..), Client(..), trace, spin, stopSpin) where
import UrbitPrelude hiding (trace)
import Ur.Prelude hiding (trace)
import Arvo (Blit, Belt)
import Ur.Arvo (Belt, Blit)
-- External Types --------------------------------------------------------------
{-
{-|
Input Event for terminal driver:
%blits -- list of blits from arvo.

16
pkg/hs/king/lib/Vere/Term/Demux.hs → pkg/hs/king/lib/Ur/Vere/Term/Demux.hs
View File

@ -1,18 +1,18 @@
{-
{-|
This allows multiple (zero or more) terminal clients to connect to
the *same* logical arvo terminal. Terminals that connect will be
given full event history since the creation of the demuxer.
-}
module Vere.Term.Demux (Demux, mkDemux, addDemux, useDemux) where
module Ur.Vere.Term.Demux (Demux, mkDemux, addDemux, useDemux) where
import UrbitPrelude
import Ur.Prelude
import Arvo (Belt)
import Vere.Term.API (Client(Client))
import Ur.Arvo (Belt)
import Ur.Vere.Term.API (Client(Client))
import qualified Vere.Term.API as Term
import qualified Vere.Term.Logic as Logic
import qualified Ur.Vere.Term.API as Term
import qualified Ur.Vere.Term.Logic as Logic
-- External --------------------------------------------------------------------
@ -69,7 +69,7 @@ dGive Demux{..} evs = do
conns <- readTVar dConns
for_ (_ksTable conns) $ \c -> Term.give c evs
{-
{-|
Returns Nothing if any connected client disconnected. A `Demux`
terminal lives forever, so you can continue to call this after it
returns `Nothing`.

16
pkg/hs/king/lib/Vere/Term/Logic.hs → pkg/hs/king/lib/Ur/Vere/Term/Logic.hs
View File

@ -1,4 +1,8 @@
module Vere.Term.Logic
{-|
Tracks terminal state so that new terminal connections can be brought
up to speed.
-}
module Ur.Vere.Term.Logic
( SpinnerCause(..), St, Ev(..), Ef(..)
, init
, step
@ -7,12 +11,12 @@ module Vere.Term.Logic
, toTermEv
) where
import UrbitPrelude hiding (init)
import Ur.Prelude hiding (init)
import Data.Sequence (Seq((:<|)))
import qualified Arvo
import qualified Vere.Term.API as Term
import qualified Ur.Arvo as Arvo
import qualified Ur.Vere.Term.API as Term
--------------------------------------------------------------------------------
@ -22,7 +26,7 @@ data SpinnerCause = User | Event Text
type SpinnerState = Maybe SpinnerCause
{-
{-|
%line -- Output a line above the edit line.
%spin -- Set the spinner state.
%bell -- Ring a bell (no change to the state).
@ -62,7 +66,7 @@ data St = St
init :: St
init = St mempty "" 0 Nothing
{-
{-|
When we process `EvMore`, we need to append a newline to the end of
the current line. During normal play, the ENTER key inserts the
newline for us, so we need to recreate that newline when we rebuild

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

@ -1,27 +1,27 @@
module AmesTests (tests) where
import Arvo
import Config
import Data.Conduit
import Data.Conduit.List hiding (take)
import Data.Ord.Unicode
import Ur.Noun
import Test.QuickCheck hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Urbit.Time
import UrbitPrelude
import Vere.Ames
import Vere.Log
import Vere.Pier.Types
import Ur.Arvo
import Ur.King.Config
import Ur.Noun
import Ur.Prelude
import Ur.Time
import Ur.Vere.Ames
import Ur.Vere.Log
import Ur.Vere.Pier.Types
import Control.Concurrent (runInBoundThread)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import Network.Socket (tupleToHostAddress)
import qualified Vere.Log as Log
import qualified Ur.Vere.Log as Log
-- Utils -----------------------------------------------------------------------

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

@ -1,6 +1,5 @@
module ArvoTests (tests) where
import Arvo
import Data.Acquire
import Data.Conduit
import Data.Conduit.List
@ -10,17 +9,18 @@ import Test.QuickCheck hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Urbit.Time
import UrbitPrelude
import Vere.Log
import Vere.Pier.Types
import Ur.Arvo
import Ur.Prelude
import Ur.Time
import Ur.Vere.Log
import Ur.Vere.Pier.Types
import Network.Socket (tupleToHostAddress)
import Control.Concurrent (threadDelay, runInBoundThread)
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import Network.Socket (tupleToHostAddress)
import qualified Vere.Log as Log
import qualified Ur.Vere.Log as Log
-- Utils -----------------------------------------------------------------------

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

@ -1,29 +1,29 @@
module BehnTests (tests) where
import Arvo
import Data.Acquire
import Data.Conduit
import Data.Conduit.List hiding (take)
import Data.Ord.Unicode
import Ur.Noun
import Test.QuickCheck hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Urbit.Time
import UrbitPrelude
import Vere.Behn
import Vere.Log
import Vere.Pier.Types
import Ur.Arvo
import Ur.Noun
import Ur.Prelude
import Ur.Time
import Ur.Vere.Behn
import Ur.Vere.Log
import Ur.Vere.Pier.Types
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import King.App (runApp)
import Network.Socket (tupleToHostAddress)
import Ur.King.App (runApp)
import qualified Urbit.Time as Time
import qualified Vere.Log as Log
import qualified Ur.Time as Time
import qualified Ur.Vere.Log as Log
--------------------------------------------------------------------------------

2
pkg/hs/king/test/ClayTests.hs
View File

@ -1,7 +1,7 @@
module ClayTests (tests) where
import Ur.Noun.Conversions
import UrbitPrelude
import Ur.Prelude
import Test.QuickCheck hiding ((.&.))
import Test.Tasty

6
pkg/hs/king/test/DawnTests.hs
View File

@ -1,14 +1,14 @@
module DawnTests (tests) where
import Arvo.Event
import Ur.Arvo.Event
import Ur.Noun.Conversions
import UrbitPrelude
import Ur.Prelude
import Test.Tasty
import Test.Tasty.HUnit
import qualified Ur.Vere.Dawn as Dawn
import qualified Urbit.Ob as Ob
import qualified Vere.Dawn as Dawn
--------------------------------------------------------------------------------

14
pkg/hs/king/test/DeriveNounTests.hs
View File

@ -1,21 +1,21 @@
module DeriveNounTests (tests) where
import Data.Acquire
import Data.Conduit
import Data.Conduit.List
import Test.QuickCheck hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import UrbitPrelude
import Vere.Log
import Vere.Pier.Types
import Data.Conduit
import Data.Conduit.List
import Ur.Prelude
import Ur.Vere.Log
import Ur.Vere.Pier.Types
import Control.Concurrent (threadDelay, runInBoundThread)
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import qualified Vere.Log as Log
import qualified Ur.Vere.Log as Log
-- Sum Types -------------------------------------------------------------------

2
pkg/hs/king/test/HoonMapSetTests.hs
View File

@ -1,7 +1,7 @@
module HoonMapSetTests (tests) where
import RIO.Directory
import UrbitPrelude hiding (encodeUtf8)
import Ur.Prelude hiding (encodeUtf8)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Numeric.Natural (Natural)

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

@ -1,10 +1,10 @@
module JamTests (tests) where
import Arvo.Event
import Ur.Arvo.Event
import Ur.Noun.Conversions
import Ur.Noun.Cue
import Ur.Noun.Jam
import UrbitPrelude
import Ur.Prelude
import GHC.Natural (Natural(..))
import Test.QuickCheck hiding ((.&.))

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

@ -1,22 +1,22 @@
module LogTests (tests) where
import Data.Acquire
import Data.Conduit
import Data.Conduit.List hiding (filter)
import Test.QuickCheck hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import UrbitPrelude
import Vere.Log
import Vere.Pier.Types
import Data.Conduit
import Data.Conduit.List hiding (filter)
import Ur.Prelude
import Ur.Vere.Log
import Ur.Vere.Pier.Types
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import King.App (App, runApp)
import Ur.King.App (App, runApp)
import qualified Vere.Log as Log
import qualified Ur.Vere.Log as Log
-- Utils -----------------------------------------------------------------------

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

@ -1,8 +1,8 @@
module NounConversionTests (tests) where
import Arvo.Event
import Ur.Arvo.Event
import Ur.Noun.Conversions
import UrbitPrelude
import Ur.Prelude
import Data.Maybe
import Test.QuickCheck hiding ((.&.))