From f1cd1bf7503184880605e01c6037c03a13bbcdd3 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 22 Jan 2020 20:16:09 -0800 Subject: [PATCH] Module structure, doc strings --- pkg/hs/king/app/Main.hs | 609 +---------------- pkg/hs/king/app/TryTimers.hs | 51 -- pkg/hs/king/lib/Arvo.hs | 13 - pkg/hs/king/lib/Data/RAcquire.hs | 5 +- pkg/hs/king/lib/Ur/Arvo.hs | 13 + pkg/hs/king/lib/{ => Ur}/Arvo/Common.hs | 13 +- pkg/hs/king/lib/{ => Ur}/Arvo/Effect.hs | 35 +- pkg/hs/king/lib/{ => Ur}/Arvo/Event.hs | 17 +- pkg/hs/king/lib/{ => Ur}/King/API.hs | 27 +- pkg/hs/king/lib/{ => Ur}/King/App.hs | 11 +- pkg/hs/king/{app => lib/Ur/King}/CLI.hs | 17 +- pkg/hs/king/lib/{ => Ur/King}/Config.hs | 9 +- pkg/hs/king/lib/{ => Ur/King}/EventBrowser.hs | 18 +- pkg/hs/king/lib/Ur/King/Main.hs | 611 ++++++++++++++++++ .../king/{app => lib/Ur/King}/TryJamPill.hs | 5 +- pkg/hs/king/lib/Ur/Noun.hs | 7 +- pkg/hs/king/lib/Ur/Noun/Atom.hs | 15 +- pkg/hs/king/lib/Ur/Noun/Conversions.hs | 4 + pkg/hs/king/lib/Ur/Noun/Convert.hs | 17 +- pkg/hs/king/lib/Ur/Noun/Core.hs | 9 +- pkg/hs/king/lib/Ur/Noun/Cue.hs | 7 +- pkg/hs/king/lib/Ur/Noun/Jam.hs | 22 +- pkg/hs/king/lib/Ur/Noun/Lens.hs | 1 - pkg/hs/king/lib/Ur/Noun/Rip.hs | 51 -- pkg/hs/king/lib/Ur/Noun/TH.hs | 11 +- pkg/hs/king/lib/Ur/Noun/Tank.hs | 4 + pkg/hs/king/lib/Ur/Noun/Tree.hs | 6 +- .../lib/{UrbitPrelude.hs => Ur/Prelude.hs} | 10 +- pkg/hs/king/lib/{Urbit => Ur}/Time.hs | 6 +- pkg/hs/king/lib/{Urbit => Ur}/Timer.hs | 2 +- pkg/hs/king/lib/{ => Ur}/Vere/Ames.hs | 21 +- pkg/hs/king/lib/{ => Ur}/Vere/Behn.hs | 20 +- pkg/hs/king/lib/{ => Ur}/Vere/Clay.hs | 51 +- pkg/hs/king/lib/{ => Ur}/Vere/Dawn.hs | 14 +- pkg/hs/king/lib/{ => Ur}/Vere/Http.hs | 8 +- pkg/hs/king/lib/{ => Ur}/Vere/Http/Client.hs | 22 +- pkg/hs/king/lib/{ => Ur}/Vere/Http/Server.hs | 35 +- pkg/hs/king/lib/{ => Ur}/Vere/LMDB.hs | 28 +- pkg/hs/king/lib/{ => Ur}/Vere/LockFile.hs | 8 +- pkg/hs/king/lib/{ => Ur}/Vere/Log.hs | 24 +- pkg/hs/king/lib/{ => Ur}/Vere/NounServ.hs | 10 +- pkg/hs/king/lib/{ => Ur}/Vere/Pier.hs | 50 +- pkg/hs/king/lib/{ => Ur}/Vere/Pier/Types.hs | 25 +- pkg/hs/king/lib/{ => Ur}/Vere/Serf.hs | 32 +- pkg/hs/king/lib/{ => Ur}/Vere/Term.hs | 51 +- pkg/hs/king/lib/{ => Ur}/Vere/Term/API.hs | 11 +- pkg/hs/king/lib/{ => Ur}/Vere/Term/Demux.hs | 20 +- pkg/hs/king/lib/{ => Ur}/Vere/Term/Logic.hs | 30 +- pkg/hs/king/test/AmesTests.hs | 18 +- pkg/hs/king/test/ArvoTests.hs | 16 +- pkg/hs/king/test/BehnTests.hs | 20 +- pkg/hs/king/test/ClayTests.hs | 2 +- pkg/hs/king/test/DawnTests.hs | 8 +- pkg/hs/king/test/DeriveNounTests.hs | 14 +- pkg/hs/king/test/HoonMapSetTests.hs | 2 +- pkg/hs/king/test/JamTests.hs | 4 +- pkg/hs/king/test/LogTests.hs | 14 +- pkg/hs/king/test/NounConversionTests.hs | 4 +- 58 files changed, 1115 insertions(+), 1073 deletions(-) delete mode 100644 pkg/hs/king/app/TryTimers.hs delete mode 100644 pkg/hs/king/lib/Arvo.hs create mode 100644 pkg/hs/king/lib/Ur/Arvo.hs rename pkg/hs/king/lib/{ => Ur}/Arvo/Common.hs (98%) rename pkg/hs/king/lib/{ => Ur}/Arvo/Effect.hs (92%) rename pkg/hs/king/lib/{ => Ur}/Arvo/Event.hs (96%) rename pkg/hs/king/lib/{ => Ur}/King/API.hs (92%) rename pkg/hs/king/lib/{ => Ur}/King/App.hs (92%) rename pkg/hs/king/{app => lib/Ur/King}/CLI.hs (97%) rename pkg/hs/king/lib/{ => Ur/King}/Config.hs (93%) rename pkg/hs/king/lib/{ => Ur/King}/EventBrowser.hs (95%) create mode 100644 pkg/hs/king/lib/Ur/King/Main.hs rename pkg/hs/king/{app => lib/Ur/King}/TryJamPill.hs (95%) delete mode 100644 pkg/hs/king/lib/Ur/Noun/Lens.hs delete mode 100644 pkg/hs/king/lib/Ur/Noun/Rip.hs rename pkg/hs/king/lib/{UrbitPrelude.hs => Ur/Prelude.hs} (87%) rename pkg/hs/king/lib/{Urbit => Ur}/Time.hs (98%) rename pkg/hs/king/lib/{Urbit => Ur}/Timer.hs (96%) rename pkg/hs/king/lib/{ => Ur}/Vere/Ames.hs (97%) rename pkg/hs/king/lib/{ => Ur}/Vere/Behn.hs (77%) rename pkg/hs/king/lib/{ => Ur}/Vere/Clay.hs (88%) rename pkg/hs/king/lib/{ => Ur}/Vere/Dawn.hs (98%) rename pkg/hs/king/lib/{ => Ur}/Vere/Http.hs (81%) rename pkg/hs/king/lib/{ => Ur}/Vere/Http/Client.hs (92%) rename pkg/hs/king/lib/{ => Ur}/Vere/Http/Server.hs (98%) rename pkg/hs/king/lib/{ => Ur}/Vere/LMDB.hs (97%) rename pkg/hs/king/lib/{ => Ur}/Vere/LockFile.hs (87%) rename pkg/hs/king/lib/{ => Ur}/Vere/Log.hs (98%) rename pkg/hs/king/lib/{ => Ur}/Vere/NounServ.hs (97%) rename pkg/hs/king/lib/{ => Ur}/Vere/Pier.hs (92%) rename pkg/hs/king/lib/{ => Ur}/Vere/Pier/Types.hs (86%) rename pkg/hs/king/lib/{ => Ur}/Vere/Serf.hs (96%) rename pkg/hs/king/lib/{ => Ur}/Vere/Term.hs (95%) rename pkg/hs/king/lib/{ => Ur}/Vere/Term/API.hs (82%) rename pkg/hs/king/lib/{ => Ur}/Vere/Term/Demux.hs (89%) rename pkg/hs/king/lib/{ => Ur}/Vere/Term/Logic.hs (84%) diff --git a/pkg/hs/king/app/Main.hs b/pkg/hs/king/app/Main.hs index 557c75b5e..3bae07c0f 100644 --- a/pkg/hs/king/app/Main.hs +++ b/pkg/hs/king/app/Main.hs @@ -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 diff --git a/pkg/hs/king/app/TryTimers.hs b/pkg/hs/king/app/TryTimers.hs deleted file mode 100644 index b732bb541..000000000 --- a/pkg/hs/king/app/TryTimers.hs +++ /dev/null @@ -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 "" - replicateM_ 10 (benchTimer timer) - putStrLn "" - - putStrLn "" - replicateM_ 10 (bench behn) - putStrLn "" --} diff --git a/pkg/hs/king/lib/Arvo.hs b/pkg/hs/king/lib/Arvo.hs deleted file mode 100644 index 088cf6ce9..000000000 --- a/pkg/hs/king/lib/Arvo.hs +++ /dev/null @@ -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] diff --git a/pkg/hs/king/lib/Data/RAcquire.hs b/pkg/hs/king/lib/Data/RAcquire.hs index a0ea66c2d..618013aa5 100644 --- a/pkg/hs/king/lib/Data/RAcquire.hs +++ b/pkg/hs/king/lib/Data/RAcquire.hs @@ -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) diff --git a/pkg/hs/king/lib/Ur/Arvo.hs b/pkg/hs/king/lib/Ur/Arvo.hs new file mode 100644 index 000000000..4d172ac39 --- /dev/null +++ b/pkg/hs/king/lib/Ur/Arvo.hs @@ -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] diff --git a/pkg/hs/king/lib/Arvo/Common.hs b/pkg/hs/king/lib/Ur/Arvo/Common.hs similarity index 98% rename from pkg/hs/king/lib/Arvo/Common.hs rename to pkg/hs/king/lib/Ur/Arvo/Common.hs index 8f6f93878..81f1ac2cb 100644 --- a/pkg/hs/king/lib/Arvo/Common.hs +++ b/pkg/hs/king/lib/Ur/Arvo/Common.hs @@ -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. diff --git a/pkg/hs/king/lib/Arvo/Effect.hs b/pkg/hs/king/lib/Ur/Arvo/Effect.hs similarity index 92% rename from pkg/hs/king/lib/Arvo/Effect.hs rename to pkg/hs/king/lib/Ur/Arvo/Effect.hs index 8448296b8..1babaa08d 100644 --- a/pkg/hs/king/lib/Arvo/Effect.hs +++ b/pkg/hs/king/lib/Ur/Arvo/Effect.hs @@ -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 diff --git a/pkg/hs/king/lib/Arvo/Event.hs b/pkg/hs/king/lib/Ur/Arvo/Event.hs similarity index 96% rename from pkg/hs/king/lib/Arvo/Event.hs rename to pkg/hs/king/lib/Ur/Arvo/Event.hs index c852a0e19..f9472a3f5 100644 --- a/pkg/hs/king/lib/Arvo/Event.hs +++ b/pkg/hs/king/lib/Ur/Arvo/Event.hs @@ -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 diff --git a/pkg/hs/king/lib/King/API.hs b/pkg/hs/king/lib/Ur/King/API.hs similarity index 92% rename from pkg/hs/king/lib/King/API.hs rename to pkg/hs/king/lib/Ur/King/API.hs index 43b70932c..0f1790eaf 100644 --- a/pkg/hs/king/lib/King/API.hs +++ b/pkg/hs/king/lib/Ur/King/API.hs @@ -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) diff --git a/pkg/hs/king/lib/King/App.hs b/pkg/hs/king/lib/Ur/King/App.hs similarity index 92% rename from pkg/hs/king/lib/King/App.hs rename to pkg/hs/king/lib/Ur/King/App.hs index 3fe76a10f..382b95b1d 100644 --- a/pkg/hs/king/lib/King/App.hs +++ b/pkg/hs/king/lib/Ur/King/App.hs @@ -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 diff --git a/pkg/hs/king/app/CLI.hs b/pkg/hs/king/lib/Ur/King/CLI.hs similarity index 97% rename from pkg/hs/king/app/CLI.hs rename to pkg/hs/king/lib/Ur/King/CLI.hs index 6112b414b..77db4c75e 100644 --- a/pkg/hs/king/app/CLI.hs +++ b/pkg/hs/king/lib/Ur/King/CLI.hs @@ -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") + ( long "comet" + <> help "Boot a new comet" + ) newFakeship :: Parser BootType newFakeship = BootFake <$> strOption diff --git a/pkg/hs/king/lib/Config.hs b/pkg/hs/king/lib/Ur/King/Config.hs similarity index 93% rename from pkg/hs/king/lib/Config.hs rename to pkg/hs/king/lib/Ur/King/Config.hs index 4d9ca7975..c8bf9a6da 100644 --- a/pkg/hs/king/lib/Config.hs +++ b/pkg/hs/king/lib/Ur/King/Config.hs @@ -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. -} diff --git a/pkg/hs/king/lib/EventBrowser.hs b/pkg/hs/king/lib/Ur/King/EventBrowser.hs similarity index 95% rename from pkg/hs/king/lib/EventBrowser.hs rename to pkg/hs/king/lib/Ur/King/EventBrowser.hs index e48f4241d..c0b5a38e2 100644 --- a/pkg/hs/king/lib/EventBrowser.hs +++ b/pkg/hs/king/lib/Ur/King/EventBrowser.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/pkg/hs/king/lib/Ur/King/Main.hs b/pkg/hs/king/lib/Ur/King/Main.hs new file mode 100644 index 000000000..c946e41ef --- /dev/null +++ b/pkg/hs/king/lib/Ur/King/Main.hs @@ -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" +-} diff --git a/pkg/hs/king/app/TryJamPill.hs b/pkg/hs/king/lib/Ur/King/TryJamPill.hs similarity index 95% rename from pkg/hs/king/app/TryJamPill.hs rename to pkg/hs/king/lib/Ur/King/TryJamPill.hs index 826eeba04..301502206 100644 --- a/pkg/hs/king/app/TryJamPill.hs +++ b/pkg/hs/king/lib/Ur/King/TryJamPill.hs @@ -1,4 +1,7 @@ -module TryJamPill where +{-| + Test jam/cue on pills. +-} +module Ur.King.TryJamPill where import ClassyPrelude import Control.Lens diff --git a/pkg/hs/king/lib/Ur/Noun.hs b/pkg/hs/king/lib/Ur/Noun.hs index 41bb76aff..fcb4f4d47 100644 --- a/pkg/hs/king/lib/Ur/Noun.hs +++ b/pkg/hs/king/lib/Ur/Noun.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/pkg/hs/king/lib/Ur/Noun/Atom.hs b/pkg/hs/king/lib/Ur/Noun/Atom.hs index cf2bc15a6..1223a3439 100644 --- a/pkg/hs/king/lib/Ur/Noun/Atom.hs +++ b/pkg/hs/king/lib/Ur/Noun/Atom.hs @@ -1,10 +1,13 @@ -{- - TODO Support 32-bit archetectures. - TODO Support Big Endian. --} - {-# OPTIONS_GHC -Werror #-} +{-| + Atom implementation with fast conversions between bytestrings + and atoms. + + TODO Support 32-bit archetectures. + TODO Support Big Endian. +-} + 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#) diff --git a/pkg/hs/king/lib/Ur/Noun/Conversions.hs b/pkg/hs/king/lib/Ur/Noun/Conversions.hs index 7a35bb8ef..5127cf895 100644 --- a/pkg/hs/king/lib/Ur/Noun/Conversions.hs +++ b/pkg/hs/king/lib/Ur/Noun/Conversions.hs @@ -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 diff --git a/pkg/hs/king/lib/Ur/Noun/Convert.hs b/pkg/hs/king/lib/Ur/Noun/Convert.hs index cf29772ae..0d7d99f07 100644 --- a/pkg/hs/king/lib/Ur/Noun/Convert.hs +++ b/pkg/hs/king/lib/Ur/Noun/Convert.hs @@ -1,11 +1,14 @@ +{-| + Framework for writing conversions between types and nouns. +-} module Ur.Noun.Convert - ( ToNoun(toNoun) - , FromNoun(parseNoun), fromNoun, fromNounErr, fromNounExn - , Parser(..) - , ParseStack - , parseNounUtf8Atom - , named - ) where + ( ToNoun(toNoun) + , FromNoun(parseNoun), fromNoun, fromNounErr, fromNounExn + , Parser(..) + , ParseStack + , parseNounUtf8Atom + , named + ) where import ClassyPrelude hiding (hash) diff --git a/pkg/hs/king/lib/Ur/Noun/Core.hs b/pkg/hs/king/lib/Ur/Noun/Core.hs index 652800bb7..9e137d605 100644 --- a/pkg/hs/king/lib/Ur/Noun/Core.hs +++ b/pkg/hs/king/lib/Ur/Noun/Core.hs @@ -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) diff --git a/pkg/hs/king/lib/Ur/Noun/Cue.hs b/pkg/hs/king/lib/Ur/Noun/Cue.hs index ff1dd2e25..bfc00033d 100644 --- a/pkg/hs/king/lib/Ur/Noun/Cue.hs +++ b/pkg/hs/king/lib/Ur/Noun/Cue.hs @@ -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. diff --git a/pkg/hs/king/lib/Ur/Noun/Jam.hs b/pkg/hs/king/lib/Ur/Noun/Jam.hs index 24ad31b5e..ad69c41fd 100644 --- a/pkg/hs/king/lib/Ur/Noun/Jam.hs +++ b/pkg/hs/king/lib/Ur/Noun/Jam.hs @@ -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,8 +168,9 @@ 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. + +{-| + Write all of the the signficant bits of a direct atom. -} {-# INLINE writeAtomWord# #-} writeAtomWord# :: Word# -> Put () @@ -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 () diff --git a/pkg/hs/king/lib/Ur/Noun/Lens.hs b/pkg/hs/king/lib/Ur/Noun/Lens.hs deleted file mode 100644 index 3ecc0005b..000000000 --- a/pkg/hs/king/lib/Ur/Noun/Lens.hs +++ /dev/null @@ -1 +0,0 @@ -module Ur.Noun.Lens where diff --git a/pkg/hs/king/lib/Ur/Noun/Rip.hs b/pkg/hs/king/lib/Ur/Noun/Rip.hs deleted file mode 100644 index 2187cabc7..000000000 --- a/pkg/hs/king/lib/Ur/Noun/Rip.hs +++ /dev/null @@ -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) diff --git a/pkg/hs/king/lib/Ur/Noun/TH.hs b/pkg/hs/king/lib/Ur/Noun/TH.hs index df970b22e..8e1d8c46e 100644 --- a/pkg/hs/king/lib/Ur/Noun/TH.hs +++ b/pkg/hs/king/lib/Ur/Noun/TH.hs @@ -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) @@ -41,9 +40,9 @@ typeShape tyName = do conInf : cs -> splitFn (l, tagConInfo prefix conInf:r) cs pure $ (vars,) $ case cs of - [] -> Vod - [c] -> Tup c - cs -> uncurry Sum splits + [] -> Vod + [c] -> Tup c + cs -> uncurry Sum splits where badSynonym = "deriveFunctor: tyCon may not be a type synonym." diff --git a/pkg/hs/king/lib/Ur/Noun/Tank.hs b/pkg/hs/king/lib/Ur/Noun/Tank.hs index 42a1bd02c..53f63ea1a 100644 --- a/pkg/hs/king/lib/Ur/Noun/Tank.hs +++ b/pkg/hs/king/lib/Ur/Noun/Tank.hs @@ -1,3 +1,7 @@ +{-| + Pretty Printer Types +-} + module Ur.Noun.Tank where import ClassyPrelude diff --git a/pkg/hs/king/lib/Ur/Noun/Tree.hs b/pkg/hs/king/lib/Ur/Noun/Tree.hs index 135c2bdec..8b68e44e0 100644 --- a/pkg/hs/king/lib/Ur/Noun/Tree.hs +++ b/pkg/hs/king/lib/Ur/Noun/Tree.hs @@ -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 diff --git a/pkg/hs/king/lib/UrbitPrelude.hs b/pkg/hs/king/lib/Ur/Prelude.hs similarity index 87% rename from pkg/hs/king/lib/UrbitPrelude.hs rename to pkg/hs/king/lib/Ur/Prelude.hs index 3c2d04615..94fdd59af 100644 --- a/pkg/hs/king/lib/UrbitPrelude.hs +++ b/pkg/hs/king/lib/Ur/Prelude.hs @@ -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) diff --git a/pkg/hs/king/lib/Urbit/Time.hs b/pkg/hs/king/lib/Ur/Time.hs similarity index 98% rename from pkg/hs/king/lib/Urbit/Time.hs rename to pkg/hs/king/lib/Ur/Time.hs index 0c0202a02..70d9013c2 100644 --- a/pkg/hs/king/lib/Urbit/Time.hs +++ b/pkg/hs/king/lib/Ur/Time.hs @@ -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 diff --git a/pkg/hs/king/lib/Urbit/Timer.hs b/pkg/hs/king/lib/Ur/Timer.hs similarity index 96% rename from pkg/hs/king/lib/Urbit/Timer.hs rename to pkg/hs/king/lib/Ur/Timer.hs index 8664e8e88..483971061 100644 --- a/pkg/hs/king/lib/Urbit/Timer.hs +++ b/pkg/hs/king/lib/Ur/Timer.hs @@ -1,4 +1,4 @@ -module Urbit.Timer ( Timer(..), init, stop, start +module Ur.Timer ( Timer(..), init, stop, start , Sys.getSystemTime, sysTimeGapMicroSecs ) where diff --git a/pkg/hs/king/lib/Vere/Ames.hs b/pkg/hs/king/lib/Ur/Vere/Ames.hs similarity index 97% rename from pkg/hs/king/lib/Vere/Ames.hs rename to pkg/hs/king/lib/Ur/Vere/Ames.hs index d1b5c9a85..376313f60 100644 --- a/pkg/hs/king/lib/Vere/Ames.hs +++ b/pkg/hs/king/lib/Ur/Vere/Ames.hs @@ -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) - diff --git a/pkg/hs/king/lib/Vere/Behn.hs b/pkg/hs/king/lib/Ur/Vere/Behn.hs similarity index 77% rename from pkg/hs/king/lib/Vere/Behn.hs rename to pkg/hs/king/lib/Ur/Vere/Behn.hs index af6236f01..e49f31bc0 100644 --- a/pkg/hs/king/lib/Vere/Behn.hs +++ b/pkg/hs/king/lib/Ur/Vere/Behn.hs @@ -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 ------------------------------------------------------------------ diff --git a/pkg/hs/king/lib/Vere/Clay.hs b/pkg/hs/king/lib/Ur/Vere/Clay.hs similarity index 88% rename from pkg/hs/king/lib/Vere/Clay.hs rename to pkg/hs/king/lib/Ur/Vere/Clay.hs index bf925b9ae..a4aa79b60 100644 --- a/pkg/hs/king/lib/Vere/Clay.hs +++ b/pkg/hs/king/lib/Ur/Vere/Clay.hs @@ -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 diff --git a/pkg/hs/king/lib/Vere/Dawn.hs b/pkg/hs/king/lib/Ur/Vere/Dawn.hs similarity index 98% rename from pkg/hs/king/lib/Vere/Dawn.hs rename to pkg/hs/king/lib/Ur/Vere/Dawn.hs index 94fd2cc8a..eec64eeb3 100644 --- a/pkg/hs/king/lib/Vere/Dawn.hs +++ b/pkg/hs/king/lib/Ur/Vere/Dawn.hs @@ -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 diff --git a/pkg/hs/king/lib/Vere/Http.hs b/pkg/hs/king/lib/Ur/Vere/Http.hs similarity index 81% rename from pkg/hs/king/lib/Vere/Http.hs rename to pkg/hs/king/lib/Ur/Vere/Http.hs index 6acd32e9f..a90951687 100644 --- a/pkg/hs/king/lib/Vere/Http.hs +++ b/pkg/hs/king/lib/Ur/Vere/Http.hs @@ -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 diff --git a/pkg/hs/king/lib/Vere/Http/Client.hs b/pkg/hs/king/lib/Ur/Vere/Http/Client.hs similarity index 92% rename from pkg/hs/king/lib/Vere/Http/Client.hs rename to pkg/hs/king/lib/Ur/Vere/Http/Client.hs index 91911aa3b..9e8f54263 100644 --- a/pkg/hs/king/lib/Vere/Http/Client.hs +++ b/pkg/hs/king/lib/Ur/Vere/Http/Client.hs @@ -1,17 +1,19 @@ -{- - - TODO When making a request, handle the case where the request id is - already in use. +{-| + 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 diff --git a/pkg/hs/king/lib/Vere/Http/Server.hs b/pkg/hs/king/lib/Ur/Vere/Http/Server.hs similarity index 98% rename from pkg/hs/king/lib/Vere/Http/Server.hs rename to pkg/hs/king/lib/Ur/Vere/Http/Server.hs index 75e5c0295..06d5f2a7c 100644 --- a/pkg/hs/king/lib/Vere/Http/Server.hs +++ b/pkg/hs/king/lib/Ur/Vere/Http/Server.hs @@ -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 diff --git a/pkg/hs/king/lib/Vere/LMDB.hs b/pkg/hs/king/lib/Ur/Vere/LMDB.hs similarity index 97% rename from pkg/hs/king/lib/Vere/LMDB.hs rename to pkg/hs/king/lib/Ur/Vere/LMDB.hs index e25cec996..065fa75e8 100644 --- a/pkg/hs/king/lib/Vere/LMDB.hs +++ b/pkg/hs/king/lib/Ur/Vere/LMDB.hs @@ -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 $ - withWord64AsMDBval id $ \idVal -> - byteStringAsMdbVal bs $ \mVal -> - mdb_put flags txn db idVal mVal +putBytes flags txn db id bs = io $ + withWord64AsMDBval id $ \idVal -> + byteStringAsMdbVal bs $ \mVal -> + mdb_put flags txn db idVal mVal diff --git a/pkg/hs/king/lib/Vere/LockFile.hs b/pkg/hs/king/lib/Ur/Vere/LockFile.hs similarity index 87% rename from pkg/hs/king/lib/Vere/LockFile.hs rename to pkg/hs/king/lib/Ur/Vere/LockFile.hs index 529044314..dc8b40c93 100644 --- a/pkg/hs/king/lib/Vere/LockFile.hs +++ b/pkg/hs/king/lib/Ur/Vere/LockFile.hs @@ -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) diff --git a/pkg/hs/king/lib/Vere/Log.hs b/pkg/hs/king/lib/Ur/Vere/Log.hs similarity index 98% rename from pkg/hs/king/lib/Vere/Log.hs rename to pkg/hs/king/lib/Ur/Vere/Log.hs index 24818044f..1180bc4e6 100644 --- a/pkg/hs/king/lib/Vere/Log.hs +++ b/pkg/hs/king/lib/Ur/Vere/Log.hs @@ -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 = diff --git a/pkg/hs/king/lib/Vere/NounServ.hs b/pkg/hs/king/lib/Ur/Vere/NounServ.hs similarity index 97% rename from pkg/hs/king/lib/Vere/NounServ.hs rename to pkg/hs/king/lib/Ur/Vere/NounServ.hs index 728bbc12b..8e9d8c5cb 100644 --- a/pkg/hs/king/lib/Vere/NounServ.hs +++ b/pkg/hs/king/lib/Ur/Vere/NounServ.hs @@ -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 @@ -18,7 +22,7 @@ import qualified Network.WebSockets as WS -------------------------------------------------------------------------------- data Conn i o = Conn - { cRecv :: STM (Maybe i) + { cRecv :: STM (Maybe i) , cSend :: o -> STM () } diff --git a/pkg/hs/king/lib/Vere/Pier.hs b/pkg/hs/king/lib/Ur/Vere/Pier.hs similarity index 92% rename from pkg/hs/king/lib/Vere/Pier.hs rename to pkg/hs/king/lib/Ur/Vere/Pier.hs index 62f96f320..2cc8a4f9a 100644 --- a/pkg/hs/king/lib/Vere/Pier.hs +++ b/pkg/hs/king/lib/Ur/Vere/Pier.hs @@ -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 Data.Text (append) +import System.Posix.Files (ownerModes, setFileMode) +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 -------------------------------------------------------------------------------- diff --git a/pkg/hs/king/lib/Vere/Pier/Types.hs b/pkg/hs/king/lib/Ur/Vere/Pier/Types.hs similarity index 86% rename from pkg/hs/king/lib/Vere/Pier/Types.hs rename to pkg/hs/king/lib/Ur/Vere/Pier/Types.hs index 29f4ae267..ab03712f6 100644 --- a/pkg/hs/king/lib/Vere/Pier/Types.hs +++ b/pkg/hs/king/lib/Ur/Vere/Pier/Types.hs @@ -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. -} @@ -86,11 +91,9 @@ type EffCb e a = a -> RIO e () type Perform = Ef -> IO () data IODriver = IODriver - { bornEvent :: IO Ev - , startDriver :: (Ev -> STM ()) -> IO (Async (), Perform) - } - --------------------------------------------------------------------------------- + { bornEvent :: IO Ev + , 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 diff --git a/pkg/hs/king/lib/Vere/Serf.hs b/pkg/hs/king/lib/Ur/Vere/Serf.hs similarity index 96% rename from pkg/hs/king/lib/Vere/Serf.hs rename to pkg/hs/king/lib/Ur/Vere/Serf.hs index 3bc0658d0..a65c0e7a6 100644 --- a/pkg/hs/king/lib/Vere/Serf.hs +++ b/pkg/hs/king/lib/Ur/Vere/Serf.hs @@ -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. -} diff --git a/pkg/hs/king/lib/Vere/Term.hs b/pkg/hs/king/lib/Ur/Vere/Term.hs similarity index 95% rename from pkg/hs/king/lib/Vere/Term.hs rename to pkg/hs/king/lib/Ur/Vere/Term.hs index 9c8c590e7..000019337 100644 --- a/pkg/hs/king/lib/Vere/Term.hs +++ b/pkg/hs/king/lib/Ur/Vere/Term.hs @@ -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 Data.List ((!!)) +import RIO.Directory (createDirectoryIfMissing) +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 ()) diff --git a/pkg/hs/king/lib/Vere/Term/API.hs b/pkg/hs/king/lib/Ur/Vere/Term/API.hs similarity index 82% rename from pkg/hs/king/lib/Vere/Term/API.hs rename to pkg/hs/king/lib/Ur/Vere/Term/API.hs index d4b3ce752..712e9151e 100644 --- a/pkg/hs/king/lib/Vere/Term/API.hs +++ b/pkg/hs/king/lib/Ur/Vere/Term/API.hs @@ -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. diff --git a/pkg/hs/king/lib/Vere/Term/Demux.hs b/pkg/hs/king/lib/Ur/Vere/Term/Demux.hs similarity index 89% rename from pkg/hs/king/lib/Vere/Term/Demux.hs rename to pkg/hs/king/lib/Ur/Vere/Term/Demux.hs index 8926277f4..a898004f6 100644 --- a/pkg/hs/king/lib/Vere/Term/Demux.hs +++ b/pkg/hs/king/lib/Ur/Vere/Term/Demux.hs @@ -1,25 +1,25 @@ -{- +{-| 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 -------------------------------------------------------------------- data KeyedSet a = KeyedSet - { _ksTable :: IntMap a - , _nextKey :: Int + { _ksTable :: IntMap a + , _nextKey :: Int } instance Semigroup (KeyedSet a) where @@ -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`. diff --git a/pkg/hs/king/lib/Vere/Term/Logic.hs b/pkg/hs/king/lib/Ur/Vere/Term/Logic.hs similarity index 84% rename from pkg/hs/king/lib/Vere/Term/Logic.hs rename to pkg/hs/king/lib/Ur/Vere/Term/Logic.hs index 141ea7912..4cdb42638 100644 --- a/pkg/hs/king/lib/Vere/Term/Logic.hs +++ b/pkg/hs/king/lib/Ur/Vere/Term/Logic.hs @@ -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,14 +26,14 @@ 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). - %draw -- Redraw the current line (no change to the state). - %move -- Move the cursor position. - %edit -- Set the edit line, moving the cursor to the end. - %more -- Write the edit line to history, and clear it. +{-| + %line -- Output a line above the edit line. + %spin -- Set the spinner state. + %bell -- Ring a bell (no change to the state). + %draw -- Redraw the current line (no change to the state). + %move -- Move the cursor position. + %edit -- Set the edit line, moving the cursor to the end. + %more -- Write the edit line to history, and clear it. -} data Ev = EvLine Text @@ -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 diff --git a/pkg/hs/king/test/AmesTests.hs b/pkg/hs/king/test/AmesTests.hs index c8c1566b6..90600accf 100644 --- a/pkg/hs/king/test/AmesTests.hs +++ b/pkg/hs/king/test/AmesTests.hs @@ -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 ----------------------------------------------------------------------- diff --git a/pkg/hs/king/test/ArvoTests.hs b/pkg/hs/king/test/ArvoTests.hs index 16cb2029c..6c8bf1b12 100644 --- a/pkg/hs/king/test/ArvoTests.hs +++ b/pkg/hs/king/test/ArvoTests.hs @@ -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 ----------------------------------------------------------------------- diff --git a/pkg/hs/king/test/BehnTests.hs b/pkg/hs/king/test/BehnTests.hs index 497324571..ae39fe750 100644 --- a/pkg/hs/king/test/BehnTests.hs +++ b/pkg/hs/king/test/BehnTests.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/pkg/hs/king/test/ClayTests.hs b/pkg/hs/king/test/ClayTests.hs index d5c5ca27a..40ed94ed8 100644 --- a/pkg/hs/king/test/ClayTests.hs +++ b/pkg/hs/king/test/ClayTests.hs @@ -1,7 +1,7 @@ module ClayTests (tests) where import Ur.Noun.Conversions -import UrbitPrelude +import Ur.Prelude import Test.QuickCheck hiding ((.&.)) import Test.Tasty diff --git a/pkg/hs/king/test/DawnTests.hs b/pkg/hs/king/test/DawnTests.hs index 86a5b1956..361680532 100644 --- a/pkg/hs/king/test/DawnTests.hs +++ b/pkg/hs/king/test/DawnTests.hs @@ -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 Urbit.Ob as Ob -import qualified Vere.Dawn as Dawn +import qualified Ur.Vere.Dawn as Dawn +import qualified Urbit.Ob as Ob -------------------------------------------------------------------------------- diff --git a/pkg/hs/king/test/DeriveNounTests.hs b/pkg/hs/king/test/DeriveNounTests.hs index f7e6e4d65..98deab107 100644 --- a/pkg/hs/king/test/DeriveNounTests.hs +++ b/pkg/hs/king/test/DeriveNounTests.hs @@ -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 ------------------------------------------------------------------- diff --git a/pkg/hs/king/test/HoonMapSetTests.hs b/pkg/hs/king/test/HoonMapSetTests.hs index 242dd43f0..90e033bc5 100644 --- a/pkg/hs/king/test/HoonMapSetTests.hs +++ b/pkg/hs/king/test/HoonMapSetTests.hs @@ -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) diff --git a/pkg/hs/king/test/JamTests.hs b/pkg/hs/king/test/JamTests.hs index 72ad91b9b..b7890efd3 100644 --- a/pkg/hs/king/test/JamTests.hs +++ b/pkg/hs/king/test/JamTests.hs @@ -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 ((.&.)) diff --git a/pkg/hs/king/test/LogTests.hs b/pkg/hs/king/test/LogTests.hs index fe4ff16f3..12c05da46 100644 --- a/pkg/hs/king/test/LogTests.hs +++ b/pkg/hs/king/test/LogTests.hs @@ -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 ----------------------------------------------------------------------- diff --git a/pkg/hs/king/test/NounConversionTests.hs b/pkg/hs/king/test/NounConversionTests.hs index 6bab9af29..5d7e9dd64 100644 --- a/pkg/hs/king/test/NounConversionTests.hs +++ b/pkg/hs/king/test/NounConversionTests.hs @@ -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 ((.&.))