mirror of
https://github.com/urbit/shrub.git
synced 2024-11-24 13:06:09 +03:00
Merge branch 'king-haskell' of https://github.com/urbit/urbit into king-auto-connect
This commit is contained in:
Isaac Visintainer
commit
e25d30163d
@ -5,7 +5,7 @@
|
||||
stack2nix-output-path ? "custom-stack2nix-output.nix",
|
||||
}:
|
||||
let
|
||||
cabalPackageName = "king";
|
||||
cabalPackageName = "urbit-king";
|
||||
compiler = "ghc865"; # matching stack.yaml
|
||||
|
||||
# Pin static-haskell-nix version.
|
||||
@ -24,7 +24,7 @@ let
|
||||
stack2nix-script = import "${static-haskell-nix}/static-stack2nix-builder/stack2nix-script.nix" {
|
||||
inherit pkgs;
|
||||
stack-project-dir = toString ./.; # where stack.yaml is
|
||||
hackageSnapshot = "2019-12-19T00:00:00Z"; # pins e.g. extra-deps without hashes or revisions
|
||||
hackageSnapshot = "2020-01-20T00:00:00Z"; # pins e.g. extra-deps without hashes or revisions
|
||||
};
|
||||
|
||||
static-stack2nix-builder = import "${static-haskell-nix}/static-stack2nix-builder/default.nix" {
|
||||
|
||||
@ -20,6 +20,7 @@ data Opts = Opts
|
||||
, oHashless :: Bool
|
||||
, oExit :: Bool
|
||||
, oDryRun :: Bool
|
||||
, oDryFrom :: Maybe Word64
|
||||
, oVerbose :: Bool
|
||||
, oAmesPort :: Maybe Word16
|
||||
, oTrace :: Bool
|
||||
@ -77,6 +78,10 @@ data Bug
|
||||
, bFirstEvt :: Word64
|
||||
, bFinalEvt :: Word64
|
||||
}
|
||||
| ReplayEvents
|
||||
{ bPierPath :: FilePath
|
||||
, bFinalEvt :: Word64
|
||||
}
|
||||
| CheckDawn
|
||||
{ bKeyfilePath :: FilePath
|
||||
}
|
||||
@ -204,11 +209,10 @@ new = do
|
||||
|
||||
opts :: Parser Opts
|
||||
opts = do
|
||||
oAmesPort <- option auto $ metavar "PORT"
|
||||
oAmesPort <- optional $ option auto $ metavar "PORT"
|
||||
<> short 'p'
|
||||
<> long "ames"
|
||||
<> help "Ames port number"
|
||||
<> value Nothing
|
||||
<> hidden
|
||||
|
||||
-- Always disable hashboard. Right now, urbit is almost unusable with this
|
||||
@ -238,6 +242,11 @@ opts = do
|
||||
<> help "Persist no events and turn off Ames networking"
|
||||
<> hidden
|
||||
|
||||
oDryFrom <- optional $ option auto $ metavar "EVENT"
|
||||
<> long "dry-from"
|
||||
<> help "Dry run from event number"
|
||||
<> hidden
|
||||
|
||||
oTrace <- switch $ short 't'
|
||||
<> long "trace"
|
||||
<> help "Enable tracing"
|
||||
@ -302,7 +311,7 @@ firstEv = option auto $ long "first"
|
||||
lastEv :: Parser Word64
|
||||
lastEv = option auto $ long "last"
|
||||
<> metavar "LAS"
|
||||
<> help "anding with event LAS"
|
||||
<> help "ending with event LAS"
|
||||
<> value maxBound
|
||||
|
||||
checkEvs :: Parser Bug
|
||||
@ -311,6 +320,9 @@ checkEvs = ValidateEvents <$> pierPath <*> firstEv <*> lastEv
|
||||
checkFx :: Parser Bug
|
||||
checkFx = ValidateFX <$> pierPath <*> firstEv <*> lastEv
|
||||
|
||||
replayEvs :: Parser Bug
|
||||
replayEvs = ReplayEvents <$> pierPath <*> lastEv
|
||||
|
||||
browseEvs :: Parser Bug
|
||||
browseEvs = EventBrowser <$> pierPath
|
||||
|
||||
@ -340,6 +352,10 @@ bugCmd = fmap CmdBug
|
||||
( info (checkFx <**> helper)
|
||||
$ progDesc "Parse all data in event log"
|
||||
)
|
||||
<> command "partial-replay"
|
||||
( info (replayEvs <**> helper)
|
||||
$ progDesc "Replay up to N events"
|
||||
)
|
||||
<> command "dawn"
|
||||
( info (checkDawn <**> helper)
|
||||
$ progDesc "Test run dawn"
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
{-|
|
||||
King Haskell Entry Point
|
||||
|
||||
@ -57,30 +55,23 @@ module Urbit.King.Main (main) where
|
||||
|
||||
import Urbit.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 Urbit.Arvo
|
||||
import Urbit.King.Config
|
||||
import Urbit.Noun hiding (Parser)
|
||||
import Urbit.Vere.Dawn
|
||||
import Urbit.Vere.Pier
|
||||
import Urbit.Vere.Pier.Types
|
||||
import Urbit.Vere.Serf
|
||||
|
||||
import Control.Concurrent (myThreadId, runInBoundThread)
|
||||
import Control.Concurrent (myThreadId)
|
||||
import Control.Exception (AsyncException(UserInterrupt))
|
||||
import Control.Lens ((&))
|
||||
import Data.Default (def)
|
||||
import RIO (logSticky, logStickyDone)
|
||||
import System.Process (system)
|
||||
import Text.Show.Pretty (pPrint)
|
||||
import Urbit.King.App (runApp, runAppLogFile, runAppNoLog, runPierApp)
|
||||
import Urbit.King.App (HasConfigDir(..))
|
||||
import Urbit.King.App (runApp, runAppLogFile, runPierApp)
|
||||
import Urbit.King.App (HasConfigDir(..))
|
||||
import Urbit.Noun.Conversions (cordToUW)
|
||||
import Urbit.Time (Wen)
|
||||
import Urbit.Vere.LockFile (lockFile)
|
||||
@ -88,10 +79,7 @@ import Urbit.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
|
||||
@ -127,7 +115,7 @@ toSerfFlags CLI.Opts{..} = catMaybes m
|
||||
, from oHashless Serf.Hashless
|
||||
, from oQuiet Serf.Quiet
|
||||
, from oVerbose Serf.Verbose
|
||||
, from oDryRun Serf.DryRun
|
||||
, from (oDryRun || isJust oDryFrom) Serf.DryRun
|
||||
]
|
||||
from True flag = Just flag
|
||||
from False _ = Nothing
|
||||
@ -136,12 +124,12 @@ toSerfFlags CLI.Opts{..} = catMaybes m
|
||||
toPierConfig :: FilePath -> CLI.Opts -> PierConfig
|
||||
toPierConfig pierPath CLI.Opts{..} = PierConfig
|
||||
{ _pcPierPath = pierPath
|
||||
, _pcDryRun = oDryRun
|
||||
, _pcDryRun = (oDryRun || isJust oDryFrom)
|
||||
}
|
||||
|
||||
toNetworkConfig :: CLI.Opts -> NetworkConfig
|
||||
toNetworkConfig CLI.Opts{..} = NetworkConfig
|
||||
{ ncNetworking = if oDryRun then NetworkNone
|
||||
{ ncNetworking = if (oDryRun || isJust oDryFrom) then NetworkNone
|
||||
else if oOffline then NetworkNone
|
||||
else if oLocalhost then NetworkLocalhost
|
||||
else NetworkNormal
|
||||
@ -178,7 +166,10 @@ runOrExitImmediately getPier oExit mStart =
|
||||
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?
|
||||
|
||||
-- Why is this here? Do I need to force a snapshot to happen?
|
||||
io $ threadDelay 500000
|
||||
|
||||
ss <- shutdown serf 0
|
||||
logTrace $ displayShow ss
|
||||
logTrace "Shutdown!"
|
||||
@ -189,8 +180,8 @@ runOrExitImmediately getPier oExit mStart =
|
||||
tryPlayShip :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
|
||||
, HasConfigDir e
|
||||
)
|
||||
=> Bool -> Bool -> Serf.Flags -> MVar ()-> RIO e ()
|
||||
tryPlayShip exitImmediately fullReplay flags mStart = do
|
||||
=> Bool -> Bool -> Maybe Word64 -> Serf.Flags -> MVar () -> RIO e ()
|
||||
tryPlayShip exitImmediately fullReplay playFrom flags mStart = do
|
||||
when fullReplay wipeSnapshot
|
||||
runOrExitImmediately resumeShip exitImmediately mStart
|
||||
where
|
||||
@ -208,14 +199,10 @@ tryPlayShip exitImmediately fullReplay flags mStart = do
|
||||
resumeShip = do
|
||||
view pierPathL >>= lockFile
|
||||
rio $ logTrace "RESUMING SHIP"
|
||||
sls <- Pier.resumed flags
|
||||
sls <- Pier.resumed playFrom 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
|
||||
@ -276,7 +263,7 @@ collectAllFx top = do
|
||||
logTrace "Done collecting effects!"
|
||||
where
|
||||
tmpDir :: FilePath
|
||||
tmpDir = top <> "/.tmpdir"
|
||||
tmpDir = top </> ".tmpdir"
|
||||
|
||||
collectedFX :: RAcquire e ()
|
||||
collectedFX = do
|
||||
@ -290,6 +277,41 @@ collectAllFx top = do
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
replayPartEvs :: ∀e. HasLogFunc e => FilePath -> Word64 -> RIO e ()
|
||||
replayPartEvs top last = do
|
||||
logTrace $ display $ pack @Text top
|
||||
fetchSnapshot
|
||||
rwith replayedEvs $ \() ->
|
||||
logTrace "Done replaying events!"
|
||||
where
|
||||
fetchSnapshot :: RIO e ()
|
||||
fetchSnapshot = do
|
||||
snap <- Pier.getSnapshot top last
|
||||
case snap of
|
||||
Nothing -> pure ()
|
||||
Just sn -> do
|
||||
liftIO $ system $ "cp -r \"" <> sn <> "\" \"" <> tmpDir <> "\""
|
||||
pure ()
|
||||
|
||||
tmpDir :: FilePath
|
||||
tmpDir = top </> ".partial-replay" </> show last
|
||||
|
||||
replayedEvs :: RAcquire e ()
|
||||
replayedEvs = do
|
||||
lockFile top
|
||||
log <- Log.existing (top <> "/.urb/log")
|
||||
serf <- Serf.run (Serf.Config tmpDir serfFlags)
|
||||
rio $ do
|
||||
ss <- Serf.replay serf log $ Just last
|
||||
Serf.snapshot serf ss
|
||||
io $ threadDelay 500000 -- Copied from runOrExitImmediately
|
||||
pure ()
|
||||
|
||||
serfFlags :: Serf.Flags
|
||||
serfFlags = [Serf.Hashless]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{-|
|
||||
Interesting
|
||||
-}
|
||||
@ -446,7 +468,6 @@ newShip CLI.New{..} opts
|
||||
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
|
||||
|
||||
|
||||
|
||||
runShip :: CLI.Run -> CLI.Opts -> Bool -> IO ()
|
||||
runShip (CLI.Run pierPath) opts daemon = do
|
||||
tid <- myThreadId
|
||||
@ -462,7 +483,12 @@ runShip (CLI.Run pierPath) opts daemon = do
|
||||
where
|
||||
runPier mStart =
|
||||
runPierApp pierConfig networkConfig daemon $
|
||||
tryPlayShip (CLI.oExit opts) (CLI.oFullReplay opts) (toSerfFlags opts) mStart
|
||||
tryPlayShip
|
||||
(CLI.oExit opts)
|
||||
(CLI.oFullReplay opts)
|
||||
(CLI.oDryFrom opts)
|
||||
(toSerfFlags opts)
|
||||
mStart
|
||||
pierConfig = toPierConfig pierPath opts
|
||||
networkConfig = toNetworkConfig opts
|
||||
|
||||
@ -537,6 +563,7 @@ main = do
|
||||
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.ReplayEvents pax l) -> runApp $ replayPartEvs pax l
|
||||
CLI.CmdBug (CLI.CheckDawn pax) -> runApp $ checkDawn pax
|
||||
CLI.CmdBug CLI.CheckComet -> runApp $ checkComet
|
||||
CLI.CmdCon pier -> runAppLogFile $ connTerm pier
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
{-|
|
||||
Large Library of conversion between various types and Nouns.
|
||||
-}
|
||||
@ -34,17 +32,13 @@ import GHC.Natural (Natural)
|
||||
import GHC.Types (Char(C#))
|
||||
import GHC.Word (Word32(W32#))
|
||||
import Prelude ((!!))
|
||||
import RIO (decodeUtf8Lenient)
|
||||
import RIO.FilePath (joinPath, splitDirectories, takeBaseName,
|
||||
takeDirectory, takeExtension, (<.>), (</>))
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Text.Show.Pretty (ppShow)
|
||||
takeDirectory, takeExtension, (<.>))
|
||||
import Urbit.Noun.Cue (cue)
|
||||
import Urbit.Noun.Jam (jam)
|
||||
|
||||
import qualified Data.Char as C
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Text.Encoding.Error as T
|
||||
|
||||
|
||||
-- Noun ------------------------------------------------------------------------
|
||||
@ -366,13 +360,12 @@ instance FromNoun a => FromNoun (Lenient a) where
|
||||
fromNounErr n & \case
|
||||
Right x -> pure (GoodParse x)
|
||||
Left err -> do
|
||||
traceM ("LENIENT.FromNoun: " <> show err)
|
||||
traceM (ppShow n)
|
||||
-- traceM ("LENIENT.FromNoun: " <> show err)
|
||||
-- traceM (ppShow n)
|
||||
pure (FailParse n)
|
||||
|
||||
instance ToNoun a => ToNoun (Lenient a) where
|
||||
toNoun (FailParse n) = trace ("LENIENT.ToNoun: " <> show n)
|
||||
n
|
||||
toNoun (FailParse n) = n -- trace ("LENIENT.ToNoun: " <> show n)
|
||||
toNoun (GoodParse x) = toNoun x
|
||||
|
||||
|
||||
@ -388,9 +381,8 @@ instance FromNoun a => FromNoun (Todo a) where
|
||||
parseNoun n = do
|
||||
fromNounErr n & \case
|
||||
Right x -> pure (Todo x)
|
||||
Left er -> do
|
||||
traceM ("[TODO]: " <> show er <> "\n" <> ppShow n <> "\n")
|
||||
fail (show er)
|
||||
Left er -> fail (show er)
|
||||
-- traceM ("[TODO]: " <> show er <> "\n" <> ppShow n <> "\n")
|
||||
|
||||
|
||||
-- Nullable --------------------------------------------------------------------
|
||||
|
||||
@ -22,8 +22,6 @@
|
||||
"hosed";
|
||||
-}
|
||||
|
||||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
module Urbit.Vere.Http.Server where
|
||||
|
||||
import Data.Conduit
|
||||
@ -416,8 +414,11 @@ openPort isFake = go
|
||||
|
||||
bindListenPort ∷ W.Port → Net.Socket → IO Net.PortNumber
|
||||
bindListenPort por sok = do
|
||||
bindAddr <- Net.inet_addr bindTo
|
||||
Net.bind sok (Net.SockAddrInet (fromIntegral por) bindAddr)
|
||||
bindAddr <- Net.getAddrInfo Nothing (Just bindTo) Nothing >>= \case
|
||||
[] -> error "this should never happen."
|
||||
x:_ -> pure (Net.addrAddress x)
|
||||
|
||||
Net.bind sok bindAddr
|
||||
Net.listen sok 1
|
||||
Net.socketPort sok
|
||||
|
||||
|
||||
@ -268,7 +268,6 @@ streamEvents :: HasLogFunc e
|
||||
=> EventLog -> Word64
|
||||
-> ConduitT () ByteString (RIO e) ()
|
||||
streamEvents log first = do
|
||||
last <- lift $ lastEv log
|
||||
batch <- lift $ readBatch log first
|
||||
unless (null batch) $ do
|
||||
for_ batch yield
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
{-|
|
||||
Top-Level Pier Management
|
||||
|
||||
@ -7,15 +5,17 @@
|
||||
communication between the serf, the log, and the IO drivers.
|
||||
-}
|
||||
module Urbit.Vere.Pier
|
||||
( booted, resumed, pier, runPersist, runCompute, generateBootSeq
|
||||
( booted, resumed, getSnapshot, pier, runPersist, runCompute, generateBootSeq
|
||||
) where
|
||||
|
||||
import Urbit.Prelude
|
||||
|
||||
import RIO.Directory
|
||||
import System.Random
|
||||
import Urbit.Arvo
|
||||
import Urbit.King.Config
|
||||
import Urbit.Vere.Pier.Types
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
import Data.Text (append)
|
||||
import System.Posix.Files (ownerModes, setFileMode)
|
||||
@ -28,8 +28,6 @@ import Urbit.Vere.Http.Server (serv)
|
||||
import Urbit.Vere.Log (EventLog)
|
||||
import Urbit.Vere.Serf (Serf, SerfState(..), doJob, sStderr)
|
||||
|
||||
import RIO.Directory
|
||||
|
||||
import qualified System.Console.Terminal.Size as TSize
|
||||
import qualified System.Entropy as Ent
|
||||
import qualified Urbit.King.API as King
|
||||
@ -130,18 +128,36 @@ booted pill lite flags ship boot = do
|
||||
-- Resume an existing ship. ----------------------------------------------------
|
||||
|
||||
resumed :: (HasPierConfig e, HasLogFunc e)
|
||||
=> Serf.Flags
|
||||
=> Maybe Word64 -> Serf.Flags
|
||||
-> RAcquire e (Serf e, EventLog, SerfState)
|
||||
resumed flags = do
|
||||
resumed event flags = do
|
||||
top <- view pierPathL
|
||||
tap <- fmap (fromMaybe top) $ rio $ runMaybeT $ do
|
||||
ev <- MaybeT (pure event)
|
||||
MaybeT (getSnapshot top ev)
|
||||
rio $ logTrace $ displayShow tap
|
||||
log <- Log.existing (top <> "/.urb/log")
|
||||
serf <- Serf.run (Serf.Config top flags)
|
||||
serfSt <- rio $ Serf.replay serf log
|
||||
serf <- Serf.run (Serf.Config tap flags)
|
||||
serfSt <- rio $ Serf.replay serf log event
|
||||
|
||||
rio $ Serf.snapshot serf serfSt
|
||||
|
||||
pure (serf, log, serfSt)
|
||||
|
||||
getSnapshot :: forall e. FilePath -> Word64 -> RIO e (Maybe FilePath)
|
||||
getSnapshot top last = do
|
||||
lastSnapshot <- lastMay <$> listReplays
|
||||
pure (replayToPath <$> lastSnapshot)
|
||||
where
|
||||
replayDir = top </> ".partial-replay"
|
||||
replayToPath eId = replayDir </> show eId
|
||||
|
||||
listReplays :: RIO e [Word64]
|
||||
listReplays = do
|
||||
createDirectoryIfMissing True replayDir
|
||||
snapshotNums <- mapMaybe readMay <$> listDirectory replayDir
|
||||
pure $ sort (filter (<= fromIntegral last) snapshotNums)
|
||||
|
||||
|
||||
-- Run Pier --------------------------------------------------------------------
|
||||
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
{-|
|
||||
Serf Interface
|
||||
|
||||
@ -29,12 +27,12 @@ import Foreign.Ptr (castPtr)
|
||||
import Foreign.Storable (peek, poke)
|
||||
import System.Exit (ExitCode)
|
||||
|
||||
import qualified Urbit.Ob as Ob
|
||||
|
||||
import qualified Data.ByteString.Unsafe as BS
|
||||
import qualified Data.Conduit.Combinators as CC
|
||||
import qualified Data.Text as T
|
||||
import qualified System.IO as IO
|
||||
import qualified System.IO.Error as IO
|
||||
import qualified Urbit.Ob as Ob
|
||||
import qualified Urbit.Time as Time
|
||||
import qualified Urbit.Vere.Log as Log
|
||||
|
||||
@ -437,12 +435,19 @@ replayJobs serf lastEv = go Nothing
|
||||
updateProgressBar start msg
|
||||
|
||||
|
||||
replay :: HasLogFunc e => Serf e -> Log.EventLog -> RIO e SerfState
|
||||
replay serf log = do
|
||||
replay :: HasLogFunc e
|
||||
=> Serf e -> Log.EventLog -> Maybe Word64 -> RIO e SerfState
|
||||
replay serf log last = do
|
||||
ss <- handshake serf (Log.identity log)
|
||||
|
||||
lastEv <- Log.lastEv log
|
||||
let numEvs = case last of
|
||||
Nothing -> ssNextEv ss
|
||||
Just la -> la - (ssNextEv ss) + 1
|
||||
|
||||
lastEv <- last & maybe (Log.lastEv log) pure
|
||||
|
||||
runConduit $ Log.streamEvents log (ssNextEv ss)
|
||||
.| CC.take (fromIntegral numEvs)
|
||||
.| toJobs (Log.identity log) (ssNextEv ss)
|
||||
.| replayJobs serf (fromIntegral lastEv) ss
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user