From 4b6509e7a315a06bfce3002c8e238eef823ac123 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 25 Apr 2019 14:02:19 -0700 Subject: [PATCH 001/431] Hello-world haskell package. --- nix/pkgs/uterm/default.nix | 37 +++++++++++++++++++++++++++++++++++++ pkg/uterm/Main.hs | 9 +++++++++ pkg/uterm/package.dhall | 27 +++++++++++++++++++++++++++ pkg/uterm/shell.nix | 1 + 4 files changed, 74 insertions(+) create mode 100644 nix/pkgs/uterm/default.nix create mode 100644 pkg/uterm/Main.hs create mode 100644 pkg/uterm/package.dhall create mode 100644 pkg/uterm/shell.nix diff --git a/nix/pkgs/uterm/default.nix b/nix/pkgs/uterm/default.nix new file mode 100644 index 000000000..5bf566990 --- /dev/null +++ b/nix/pkgs/uterm/default.nix @@ -0,0 +1,37 @@ +{ pkgs ? import ../../nixpkgs.nix }: + +let + + compiler = "default"; + doBenchmark = false; + + run-hpack = + "${pkgs.haskellPackages.hpack}/bin/hpack"; + + f = { mkDerivation, stdenv, + base, classy-prelude, lens, hpack, megaparsec }: + mkDerivation { + pname = "uterm"; + version = "0.1.0.0"; + src = ../../../pkg/uterm; + isLibrary = false; + isExecutable = true; + executableHaskellDepends = [ + base classy-prelude lens hpack megaparsec + ]; + license = stdenv.lib.licenses.lgpl3; + preConfigure = '' + ${run-hpack} + ''; + }; + + haskellPackages = if compiler == "default" + then pkgs.haskellPackages + else pkgs.haskell.packages.${compiler}; + + variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; + drv = variant (haskellPackages.callPackage f {}); + +in + + if pkgs.lib.inNixShell then drv.env else drv diff --git a/pkg/uterm/Main.hs b/pkg/uterm/Main.hs new file mode 100644 index 000000000..2e7443e3e --- /dev/null +++ b/pkg/uterm/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import ClassyPrelude +import Control.Lens + +-------------------------------------------------------------------------------- + +main :: IO () +main = "Hello World" & putStrLn diff --git a/pkg/uterm/package.dhall b/pkg/uterm/package.dhall new file mode 100644 index 000000000..898a389c5 --- /dev/null +++ b/pkg/uterm/package.dhall @@ -0,0 +1,27 @@ +{ name = + "uterm" +, version = + "0.1.0" +, license = + "AGPL-3.0-only" +, default-extensions = + [ "OverloadedStrings" + , "TypeApplications" + , "UnicodeSyntax" + , "FlexibleContexts" + , "TemplateHaskell" + , "QuasiQuotes" + , "LambdaCase" + , "NoImplicitPrelude" + , "ScopedTypeVariables" + , "DeriveAnyClass" + , "DeriveGeneric" + ] +, dependencies = + [ "base" + , "classy-prelude" + , "lens" + ] +, executables = + { pomo = { main = "Main.hs" } } +} diff --git a/pkg/uterm/shell.nix b/pkg/uterm/shell.nix new file mode 100644 index 000000000..71550a487 --- /dev/null +++ b/pkg/uterm/shell.nix @@ -0,0 +1 @@ +import ../../nix/pkgs/uterm/default.nix From ac8144114b89e1e9ac6648283338ff0180226e2d Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 29 Apr 2019 16:01:18 -0700 Subject: [PATCH 002/431] Some Haskell. Now how to build with nix? --- pkg/hs/.gitignore | 1 + pkg/hs/hoon/.gitignore | 13 + pkg/hs/hoon/ChangeLog.md | 3 + pkg/hs/hoon/LICENSE | 30 ++ pkg/hs/hoon/README.md | 1 + pkg/hs/hoon/Setup.hs | 2 + pkg/hs/hoon/package.yaml | 73 ++++ pkg/hs/hoon/src/AST/Parser.hs | 345 ++++++++++++++++++ pkg/hs/hoon/src/AST/Types.hs | 66 ++++ pkg/hs/hoon/src/Arvo.hs | 42 +++ pkg/hs/hoon/src/Desugar.hs | 187 ++++++++++ pkg/hs/hoon/src/IR/Desugar.hs | 183 ++++++++++ pkg/hs/hoon/src/IR/Infer.hs | 213 +++++++++++ pkg/hs/hoon/src/IR/Ty.hs | 660 ++++++++++++++++++++++++++++++++++ pkg/hs/hoon/src/IR/Wing.hs | 206 +++++++++++ pkg/hs/hoon/src/LL/Gen.hs | 80 +++++ pkg/hs/hoon/src/LL/Run.hs | 108 ++++++ pkg/hs/hoon/src/LL/Types.hs | 73 ++++ pkg/hs/hoon/src/Nock/Types.hs | 58 +++ pkg/hs/hoon/src/SpecToBunt.hs | 7 + pkg/hs/hoon/src/SpecToMold.hs | 9 + pkg/hs/hoon/src/Types.hs | 282 +++++++++++++++ pkg/hs/stack.yaml | 8 + pkg/hs/uterm/.gitignore | 1 + pkg/{ => hs}/uterm/Main.hs | 0 pkg/hs/uterm/package.yaml | 25 ++ pkg/uterm/package.dhall | 27 -- pkg/uterm/shell.nix | 1 - 28 files changed, 2676 insertions(+), 28 deletions(-) create mode 100644 pkg/hs/.gitignore create mode 100644 pkg/hs/hoon/.gitignore create mode 100644 pkg/hs/hoon/ChangeLog.md create mode 100644 pkg/hs/hoon/LICENSE create mode 100644 pkg/hs/hoon/README.md create mode 100644 pkg/hs/hoon/Setup.hs create mode 100644 pkg/hs/hoon/package.yaml create mode 100644 pkg/hs/hoon/src/AST/Parser.hs create mode 100644 pkg/hs/hoon/src/AST/Types.hs create mode 100644 pkg/hs/hoon/src/Arvo.hs create mode 100644 pkg/hs/hoon/src/Desugar.hs create mode 100644 pkg/hs/hoon/src/IR/Desugar.hs create mode 100644 pkg/hs/hoon/src/IR/Infer.hs create mode 100644 pkg/hs/hoon/src/IR/Ty.hs create mode 100644 pkg/hs/hoon/src/IR/Wing.hs create mode 100644 pkg/hs/hoon/src/LL/Gen.hs create mode 100644 pkg/hs/hoon/src/LL/Run.hs create mode 100644 pkg/hs/hoon/src/LL/Types.hs create mode 100644 pkg/hs/hoon/src/Nock/Types.hs create mode 100644 pkg/hs/hoon/src/SpecToBunt.hs create mode 100644 pkg/hs/hoon/src/SpecToMold.hs create mode 100644 pkg/hs/hoon/src/Types.hs create mode 100644 pkg/hs/stack.yaml create mode 100644 pkg/hs/uterm/.gitignore rename pkg/{ => hs}/uterm/Main.hs (100%) create mode 100644 pkg/hs/uterm/package.yaml delete mode 100644 pkg/uterm/package.dhall delete mode 100644 pkg/uterm/shell.nix diff --git a/pkg/hs/.gitignore b/pkg/hs/.gitignore new file mode 100644 index 000000000..8ee1bf948 --- /dev/null +++ b/pkg/hs/.gitignore @@ -0,0 +1 @@ +.stack-work diff --git a/pkg/hs/hoon/.gitignore b/pkg/hs/hoon/.gitignore new file mode 100644 index 000000000..f476396fc --- /dev/null +++ b/pkg/hs/hoon/.gitignore @@ -0,0 +1,13 @@ +.stack-work/ +hoon-hs.cabal +*~ +*. + +# Swap +[._]*.s[a-v][a-z] +[._]*.sw[a-p] +[._]s[a-rt-v][a-z] +[._]ss[a-gi-z] +[._]sw[a-p] + +.DS_Store diff --git a/pkg/hs/hoon/ChangeLog.md b/pkg/hs/hoon/ChangeLog.md new file mode 100644 index 000000000..dd46edd71 --- /dev/null +++ b/pkg/hs/hoon/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for hoon-hs + +## Unreleased changes diff --git a/pkg/hs/hoon/LICENSE b/pkg/hs/hoon/LICENSE new file mode 100644 index 000000000..102126f58 --- /dev/null +++ b/pkg/hs/hoon/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/pkg/hs/hoon/README.md b/pkg/hs/hoon/README.md new file mode 100644 index 000000000..0ddf296ac --- /dev/null +++ b/pkg/hs/hoon/README.md @@ -0,0 +1 @@ +# hoon-hs diff --git a/pkg/hs/hoon/Setup.hs b/pkg/hs/hoon/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/pkg/hs/hoon/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pkg/hs/hoon/package.yaml b/pkg/hs/hoon/package.yaml new file mode 100644 index 000000000..cdf636f1c --- /dev/null +++ b/pkg/hs/hoon/package.yaml @@ -0,0 +1,73 @@ +name: hoon-hs +version: 0.1.0.0 +github: "urbit/hoon-hs" +license: BSD3 + +library: + source-dirs: src + +extra-source-files: + - README.md + - ChangeLog.md + +dependencies: + - base + - classy-prelude + - containers + - data-fix + - integer-gmp + - ghc-prim + - lens + - megaparsec + - mtl + - multimap + - para + - pretty-show + - QuickCheck + - semigroups + - smallcheck + - tasty + - tasty-quickcheck + - tasty-th + - text + - these + - unordered-containers + - vector + +ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -fwarn-incomplete-patterns + +default-extensions: + - ApplicativeDo + - BangPatterns + - DeriveFoldable + - DeriveGeneric + - DeriveTraversable + - EmptyDataDecls + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - NoImplicitPrelude + - OverloadedStrings + - PartialTypeSignatures + - Rank2Types + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - UnicodeSyntax + - ViewPatterns + - BlockArguments + - NamedFieldPuns + - TemplateHaskell diff --git a/pkg/hs/hoon/src/AST/Parser.hs b/pkg/hs/hoon/src/AST/Parser.hs new file mode 100644 index 000000000..b7ee71ddf --- /dev/null +++ b/pkg/hs/hoon/src/AST/Parser.hs @@ -0,0 +1,345 @@ +-- TODO Handle comments + +module AST.Parser where + +import AST.Types +import ClassyPrelude hiding (head, many, some, try) +import Control.Lens +import Text.Megaparsec +import Text.Megaparsec.Char +import Control.Monad.State.Lazy +import Data.List.NonEmpty (NonEmpty(..)) + +import Data.Void (Void) +import Prelude (head) +import Text.Format.Para (formatParas) + +import qualified Data.MultiMap as MM +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.IO as LT +import qualified Prelude + + +-- Parser Monad ------------------------------------------------------------------------------------ + +data Mode = Wide | Tall + deriving (Eq, Ord, Show) + +type Parser = StateT Mode (Parsec Void Text) + +withLocalState :: Monad m => s -> StateT s m a -> StateT s m a +withLocalState val x = do { old <- get; put val; x <* put old } + +inWideMode :: Parser a -> Parser a +inWideMode = withLocalState Wide + + +-- Simple Lexers --------------------------------------------------------------- + +ace, pal, par ∷ Parser () +ace = void (char ' ') +pal = void (char '(') +par = void (char ')') + +gap ∷ Parser () +gap = choice [ char ' ' >> void (some spaceChar) + , newline >> void (many spaceChar) + ] + +whitespace ∷ Parser () +whitespace = ace <|> void gap + + +-- Literals -------------------------------------------------------------------- + +alpha ∷ Parser Char +alpha = oneOf (['a'..'z'] ++ ['A'..'Z']) + +sym ∷ Parser Sym +sym = bucSym <|> some alpha + where bucSym = char '$' *> pure "" + +atom ∷ Parser Nat +atom = do + init ← some digitChar + rest ← many (char '.' *> some digitChar) + guard True -- TODO Validate '.'s + pure (Prelude.read $ concat $ init:rest) + +nat ∷ Parser Nat +nat = Prelude.read <$> some digitChar + +limb ∷ Parser (Either Nat Sym) +limb = (Right <$> sym) <|> (char '+' >> Left <$> nat) + +wing ∷ Parser Wing +wing = + subjt <|> limbs + where + subjt ∷ Parser Wing + subjt = pure [] <* char '.' + limbs ∷ Parser Wing + limbs = do s ← limb + ss ← many (char '.' >> limb) + pure (s:ss) + +tape ∷ Parser Text +tape = do + between (char '"') (char '"') $ + pack <$> many (label "tape char" (anySingleBut '"')) + +cord ∷ Parser Text +cord = do + between (char '\'') (char '\'') $ + pack <$> many (label "cord char" (anySingleBut '\'')) + +literal ∷ Parser Hoon +literal = choice + [ Atom <$> atom + , Wing <$> wing + , pure Yes <* string "%.y" + , pure No <* string "%.n" + , pure Pam <* char '&' + , pure Bar <* char '|' + , pure Sig <* char '~' + , pure Lus <* char '+' + , pure Hep <* char '-' + , Cord <$> cord + , Tape <$> tape + ] + +-- Rune Helpers ------------------------------------------------------------------------------------ + +{- + - If the parser is in `Wide` mode, only accept the `wide` form. + - If the parser is in `Tall` mode, either + - accept the `tall` form or: + - swich to `Wide` mode and then accept the wide form. +-} +parseRune ∷ Parser a → Parser a → Parser a +parseRune tall wide = get >>= \case + Wide → wide + Tall → tall <|> inWideMode wide + +rune1 ∷ (a→b) → Parser a → Parser b +rune1 node x = parseRune tall wide + where tall = do gap; p←x; pure (node p) + wide = do pal; p←x; par; pure (node p) + +rune2 ∷ (a→b→c) → Parser a → Parser b → Parser c +rune2 node x y = parseRune tall wide + where tall = do gap; p←x; gap; q←y; pure (node p q) + wide = do pal; p←x; ace; q←y; par; pure (node p q) + +rune3 ∷ (a→b→c→d) → Parser a → Parser b → Parser c → Parser d +rune3 node x y z = parseRune tall wide + where tall = do gap; p←x; gap; q←y; gap; r←z; pure (node p q r) + wide = do pal; p←x; ace; q←y; ace; r←z; par; pure (node p q r) + +rune4 ∷ (a→b→c→d→e) → Parser a → Parser b → Parser c → Parser d → Parser e +rune4 node x y z g = parseRune tall wide + where tall = do gap; p←x; gap; q←y; gap; r←z; gap; s←g; pure (node p q r s) + wide = do pal; p←x; ace; q←y; ace; r←z; ace; s←g; pure (node p q r s) + +runeN ∷ ([a]→b) → Parser a → Parser b +runeN node elem = node <$> parseRune tall wide + where tall = gap >> elems + where elems = term <|> elemAnd + elemAnd = do x ← elem; gap; xs ← elems; pure (x:xs) + term = string "==" *> pure [] + wide = pal *> option [] elems <* par + where elems = (:) <$> elem <*> many (ace >> elem) + +runeNE ∷ (NonEmpty a → b) → Parser a → Parser b +runeNE node elem = node <$> parseRune tall wide + where tall = do + let elems = term <|> elemAnd + elemAnd = do x ← elem; gap; xs ← elems; pure (x:xs) + term = string "==" *> pure [] + fst <- gap *> elem + rst <- gap *> elems + pure (fst :| rst) + wide = mzero -- No wide form for cores + +-- Irregular Syntax -------------------------------------------------------------------------------- + +inc ∷ Parser Hoon -- +(3) +inc = do + string "+(" + h ← hoon + char ')' + pure h + +equals ∷ Parser (Hoon, Hoon) -- =(3 4) +equals = do + string "=(" + x ← hoon + ace + y ← hoon + char ')' + pure (x, y) + +tuple ∷ ∀a. Parser a → Parser [a] +tuple p = char '[' >> elems + where + xs ∷ Parser [a] + xs = do { x ← p; (x:) <$> tail } + + tail ∷ Parser [a] + tail = (pure [] <* char ']') + <|> (ace >> elems) + + elems ∷ Parser [a] + elems = (pure [] <* char ']') <|> xs + +irregular ∷ Parser Hoon +irregular = + inWideMode $ + choice [ Tupl <$> tuple hoon + , IncrIrr <$> inc + , uncurry IsEqIrr <$> equals + ] + +-- Runes ------------------------------------------------------------------------------------------- + +cRune ∷ (Map Sym Hoon → a) → Parser a +cRune f = do + mode ← get + guard (mode == Tall) + gap + f . mapFromList <$> arms -- TODO Complain about duplicated arms + where + arms :: Parser [(Sym, Hoon)] + arms = many arm <* string "--" + + arm :: Parser (Sym, Hoon) + arm = do + string "++" + gap + s ← sym + gap + h ← hoon + gap + pure (s, h) + +data Skin + +rune ∷ Parser Hoon +rune = runeSwitch [ ("|=", rune2 BarTis hoon hoon) + , ("|-", rune1 BarHep hoon) + , (":-", rune2 ColHep hoon hoon) + , (":+", rune3 ColLus hoon hoon hoon) + , (":^", rune4 ColKet hoon hoon hoon hoon) + , (":*", runeN ColTar hoon) + , (":~", runeN ColSig hoon) + , ("^-", rune2 KetHep spec hoon) + , ("=<", rune2 TisGal hoon hoon) + , ("=>", rune2 TisGar hoon hoon) + , ("?:", rune3 WutCol hoon hoon hoon) + , ("?=", rune2 WutTis spec hoon) + , ("?@", rune3 WutPat hoon hoon hoon) + , ("?^", rune3 WutKet hoon hoon hoon) + , (".+", rune1 Incr hoon) + , (".=", rune2 IsEq hoon hoon) + , ("^=", rune2 KetTis sym hoon) + , ("=.", rune3 TisDot wing hoon hoon) + , ("|%", cRune BarCen) + ] + +runeSwitch ∷ [(Text, Parser a)] → Parser a +runeSwitch = choice . fmap (\(s, p) → string s *> p) + +-- runeSwitch ∷ [(String, Parser a)] → Parser a +-- runeSwitch = parseBasedOnRune +-- . fmap (\([x,y], p) → (x, (y,p))) +-- where +-- parseBasedOnRune ∷ [(Char, (Char, Parser a))] → Parser a +-- parseBasedOnRune = combine . restructure +-- where combine = lexThen . overSnd lexThen +-- overSnd f = fmap (\(x,y) → (x,f y)) +-- lexThen = choice . fmap (\(x,y) → char x *> y) +-- restructure = MM.assocs +-- . MM.fromList + +-- Infix Syntax ------------------------------------------------------------------------------------ + +colInfix ∷ Parser Hoon +colInfix = do + x ← try (hoonNoInfix <* char ':') + y ← hoon + pure (ColOp x y) + +faceOp ∷ Parser Hoon +faceOp = FaceOp <$> try (sym <* char '=') + <*> hoon + +infixOp ∷ Parser Hoon +infixOp = do + inWideMode (colInfix <|> faceOp) + +-- Hoon Parser ------------------------------------------------------------------------------------- + +hoonNoInfix ∷ Parser Hoon +hoonNoInfix = irregular <|> rune <|> literal + +hoon ∷ Parser Hoon +hoon = infixOp <|> hoonNoInfix + +-- Entry Point ------------------------------------------------------------------------------------- + +hoonFile = do + option () whitespace + h ← hoon + option () whitespace + eof + pure h + +parse :: Text -> Either Text Hoon +parse txt = + runParser (evalStateT hoonFile Tall) "stdin" txt & \case + Left e -> Left (pack $ errorBundlePretty e) + Right x -> pure x + +parseHoonTest ∷ Text → IO () +parseHoonTest = parseTest (evalStateT hoonFile Tall) + +main ∷ IO () +main = (head <$> getArgs) >>= parseHoonTest + + +-- Parse Spec ------------------------------------------------------------------ + +base :: Parser Base +base = choice [ BVoid <$ char '!' + , BNull <$ char '~' + , BFlag <$ char '?' + , BNoun <$ char '*' + , BCell <$ char '^' + , BAtom <$ char '@' + ] + +specTuple ∷ Parser Spec +specTuple = tuple spec >>= \case + [] -> mzero + x:xs -> pure (STuple (x :| xs)) + +specFace ∷ Parser Spec +specFace = SFaceOp <$> try (sym <* char '=') <*> spec + +specIrregular ∷ Parser Spec +specIrregular = inWideMode (specTuple <|> specFace) + +spec :: Parser Spec +spec = specIrregular <|> specRune <|> fmap SBase base + +specRune ∷ Parser Spec +specRune = choice + [ string "$:" >> runeNE SBucCol spec + , string "$-" >> rune2 SBucHep spec spec + , string "$=" >> rune2 SBucTis sym spec + , string "$?" >> runeNE SBucWut spec + , string "$@" >> rune2 SBucPat spec spec + , string "$^" >> rune2 SBucKet spec spec + , string "$%" >> runeNE SBucCen spec + ] diff --git a/pkg/hs/hoon/src/AST/Types.hs b/pkg/hs/hoon/src/AST/Types.hs new file mode 100644 index 000000000..6632c11c1 --- /dev/null +++ b/pkg/hs/hoon/src/AST/Types.hs @@ -0,0 +1,66 @@ +-- TODO Handle comments + +module AST.Types where + +import ClassyPrelude +import Data.List.NonEmpty (NonEmpty) + +-- AST Types ------------------------------------------------------------------- + +type Nat = Int +type Sym = String +type Wing = [Either Nat Sym] + +data Base = BVoid | BNull | BFlag | BNoun | BCell | BAtom + deriving (Eq, Ord, Show) + +data Spec + = SBase Base -- ^, ? + | SFaceOp Sym Spec -- x=@ + | SBucCol (NonEmpty Spec) -- $: + | SBucHep Spec Spec -- $-, function core + | SBucTis Sym Spec -- $=, name + | SBucWut (NonEmpty Spec) -- $?, full pick + | SBucPat Spec Spec -- $@, atom pick + | SBucKet Spec Spec -- $^, cons pick + | SBucCen (NonEmpty Spec) -- $%, head pick + | STuple (NonEmpty Spec) -- [@ @] + deriving (Eq, Ord, Show) + +data Hoon + = WutCol Hoon Hoon Hoon -- ?:(c t f) + | WutTis Spec Hoon -- ?=(@ 0) + | WutPat Hoon Hoon Hoon -- ?@(c t f) + | WutKet Hoon Hoon Hoon -- ?^(c t f) + | KetTis Sym Hoon -- ^=(x 3) + | ColHep Hoon Hoon -- :-(a b) + | ColLus Hoon Hoon Hoon -- :+(a b c) + | ColKet Hoon Hoon Hoon Hoon -- :^(a b c d) + | ColTar [Hoon] -- :*(a as ...) + | ColSig [Hoon] -- :~(a as ...) + | KetHep Spec Hoon -- ^-(s h) + | TisGal Hoon Hoon -- =<(a b) + | TisGar Hoon Hoon -- =>(a b) + | BarTis Hoon Hoon -- |=(s h) + | BarHep Hoon -- |-(a) + | TisDot Wing Hoon Hoon -- =.(a 3 a) + | BarCen (Map Sym Hoon) -- |% ++ a 3 -- + | ColOp Hoon Hoon -- [+ -]:[3 4] + | Tupl [Hoon] -- [a b] + | FaceOp Sym Hoon -- x=y + | Wing Wing -- ., a, a.b + | Atom Nat -- 3 + | Cord Text -- 'cord' + | Tape Text -- "tape" + | Incr Hoon -- .+(3) + | IncrIrr Hoon -- +(3) + | IsEq Hoon Hoon -- .=(3 4) + | IsEqIrr Hoon Hoon -- =(3 4) + | Lus -- + + | Hep -- - + | Pam -- & + | Bar -- | + | Yes -- %.y + | No -- %.n + | Sig -- ~ + deriving (Eq, Ord, Show) diff --git a/pkg/hs/hoon/src/Arvo.hs b/pkg/hs/hoon/src/Arvo.hs new file mode 100644 index 000000000..9909ff93d --- /dev/null +++ b/pkg/hs/hoon/src/Arvo.hs @@ -0,0 +1,42 @@ +module Arvo where + +import ClassyPrelude + +-------------------------------------------------------------------------------- + +data Event = Event +data Effect = Effect + +data ArvoFn = MkArvoFn (Event -> ([Effect], ArvoFn)) + +data Arvo r + = Yield [Effect] (Event -> Arvo r) + | Pure r + + +-- Arvo is a Monad ------------------------------------------------------------- + +bind :: Arvo a -> (a -> Arvo b) -> Arvo b +bind (Pure x) f = f x +bind (Yield fx k) f = Yield fx (\ev -> bind (k ev) f) + +instance Functor Arvo where + fmap f (Pure v) = Pure (f v) + fmap f (Yield fx cont) = Yield fx (fmap (fmap f) cont) + +instance Applicative Arvo where + pure = Pure + mx <*> y = mx `bind` (\f -> f <$> y) + +instance Monad Arvo where + (>>=) = bind + +-------------------------------------------------------------------------------- + +yield :: [Effect] -> Arvo Event +yield fx = Yield fx Pure + +example :: Arvo a +example = do + Event <- yield [Effect, Effect] + example diff --git a/pkg/hs/hoon/src/Desugar.hs b/pkg/hs/hoon/src/Desugar.hs new file mode 100644 index 000000000..b172489f2 --- /dev/null +++ b/pkg/hs/hoon/src/Desugar.hs @@ -0,0 +1,187 @@ +module Desugar (desugar) where + +import Prelude + +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.Map as Map + +import Nock.Types +import Types +import SpecToMold +import SpecToBunt + +-- open:ap +desugar :: Bool -> Hoon -> BHoon +desugar fab = go + where + -- things that are already desugared + go (HAutocons hs) = BAutocons (map go hs) + go (HDebug s h) = BDebug s (go h) + go (Hand t nk) = BHand t nk + -- but open:ap also strips note + go (Note note h) = BNote note (go h) + go (Fits h w) = BFits (go h) w + go (Sand n nou) = BSand n nou + go (Rock n nou) = BRock n nou + go (Tune t) = BTune t + go (Lost h) = BLost (go h) + -- + go (BarCen n b) = BBarCen n (Map.map (Map.map (\(w, h) -> (w, go h))) b) + go (BarPat n b) = BBarPat n (Map.map (Map.map (\(w, h) -> (w, go h))) b) + -- + go (CenTis w cs) = BCenTis w (map (\(w, h) -> (w, go h)) cs) + -- + go (DotKet s h) = BDotKet s (go h) + go (DotLus h) = BDotLus (go h) + go (DotTar h j) = BDotTar (go h) (go j) + go (DotTis h j) = BDotTis (go h) (go j) + go (DotWut h) = BDotWut (go h) + -- + go (KetBar h) = BKetBar (go h) + go (KetCen h) = BKetCen (go h) + go (KetLus h j) = BKetLus (go h) (go j) + go (KetPam h) = BKetPam (go h) + go (KetSig h) = BKetSig (go h) + go (KetWut h) = BKetWut (go h) + -- + go (SigGar hint mh j) = BSigGar hint (fmap go mh) (go j) + go (SigZap h j) = BSigZap (go h) (go j) + -- + go (TisGar h j) = BTisGar (go h) (go j) + go (TisCom h j) = BTisCom (go h) (go j) + -- + go (WutCol h j k) = BWutCol (go h) (go j) (go k) + go (WutHax s w) = BWutHax s w + -- + go (ZapCom h j) = BZapCom (go h) (go j) + go (ZapMic h j) = BZapMic (go h) (go j) + go (ZapTis h) = BZapTis (go h) + go (ZapPat ws h j) = BZapPat ws (go h) (go j) + go ZapZap = BZapZap + + + go (H_ axis) = (BCenTis [AxisLimb axis] []) + -- + go (HBase basetype) = go (specToMold fab (SBase basetype)) + go (Bust basetype) = go (specToBunt fab (SBase basetype)) + go (KetCol spec) = go (specToMold fab spec) + -- writen into open:ap even though mint:ut uses handles debug case directly + -- go (Debug h) = go h + go (Error msg) = error ("%slog.[0 leaf/" ++ msg ++ "]") + -- + go (Knit woofs) = error "TODO: implement %knit desugar" + -- + go (HLeaf name atom) = go (specToMold fab (SLeaf name atom)) + go (Limb name) = (BCenTis [NameLimb name] []) + go (Wing wing) = (BCenTis wing []) + go (Tell hs) = go (CenCol (Limb "noah") [ZapGar (ColTar hs)]) + go (Yell hs) = go (CenCol (Limb "cain") [ZapGar (ColTar hs)]) + go (Xray _) = error "TODO: %xray not implemented" + -- + -- TODO implement bars + -- + go (ColKet h1 h2 h3 h4) = BAutocons (map go [h1, h2, h3, h4]) + go (ColLus h1 h2 h3) = BAutocons (map go [h1, h2, h3]) + go (ColCab h1 h2) = BAutocons (map go [h2, h1]) + go (ColHep h1 h2) = BAutocons (map go [h1, h2]) + go (ColSig hs) = BAutocons (map go hs ++ [BRock "n" (Atom 0)]) + go (ColTar (h :| hs)) = BAutocons (go h : map go hs) + -- + go (KetTar spec) = BKetSig (go (specToBunt fab spec)) + -- + -- CenTis, but the product is cast to the type of the old value + go (CenCab wing changes) = BKetLus (go (Wing wing)) + (BCenTis wing (desugarChanges changes)) + go (CenDot h1 h2) = go (CenCol h2 [h1]) + go (CenKet h1 h2 h3 h4) = go (CenCol h1 [h2, h3, h4]) + go (CenLus h1 h2 h3) = go (CenCol h1 [h2, h3]) + go (CenHep h1 h2) = go (CenCol h1 [h2]) + -- the implementation that "probably should work, but doesn't" + go (CenCol h hs) + = go (CenTar [NameLimb ""] h [([AxisLimb 6], HAutocons hs)]) + -- in lieu of the "electroplating" implementation + go (CenSig wing h hs) = go (CenTar wing h [([AxisLimb 6], HAutocons hs)]) + go (CenTar wing h changes) + | null changes = BTisGar (go (Wing wing)) (go h) + | otherwise = go (TisLus h (CenTis (wing ++ [AxisLimb 2]) changes)) + -- + go (KetDot h j) = BKetLus (go (CenCol h [j])) (go j) + go (KetHep spec h) = BKetLus (go (specToBunt fab spec)) (go h) + go (KetTis skin h) = go (grip skin h) + -- + go (SigBar h j) = BSigGar "mean" (Just (hint h)) (go j) + where + hint (Sand "tas" x) = (BRock "tas" x) + hint (HDebug _ h) = hint h + hint h = go (BarDot (CenCol (Limb "cain") [ZapGar (TisGar (H_ 3) h)])) + go (SigCab h j) = BSigGar "mean" (Just (go (BarDot h))) (go j) + go (SigCen chum h tyre j) = error "desugar: TODO ~% not supported" + go (SigFas chum h) = error "desugar: TODO ~/ not supported" + go (SigLed n mh j) = BTisGar (go j) (BSigGar n (fmap go mh) (go (H_ 1))) + go (SigBuc name h) + = BSigGar "live" (Just (BRock "" (nameToAtom name))) (go h) + go (SigLus atom h) = BSigGar "memo" (Just (BRock "" (Atom atom))) (go h) + go (SigPam atom h j) + = BSigGar + "slog" + (Just (BAutocons [BSand "" (Atom atom) + , go (CenCol (Limb "cain") [ZapGar j])])) + (go j) + go (SigTis h j) = BSigGar "germ" (Just (go h)) (go j) + go (SigWut atom h j k) + = go (TisLus + (WutDot j (Bust SNull) (HAutocons [Bust SNull, k])) + (WutSig + [AxisLimb 2] + (TisGar (H_ 3) k) + (SigPam atom (H_ 5) (TisGar (H_ 3) k)))) + -- + -- TODO mic runes + -- + go (TisBar h j) = go (TisLus (specToBunt fab h) j) + --go (TisTar name Nothing h j) = BTisGar (BTune Tone) j + --go (TisTar name (Just spec) h j) = undefined + go (TisCol chs h) = BTisGar (go (CenCab [AxisLimb 1] chs)) (go h) + go (TisFas skin h j) = go (TisLus (KetTis skin h) j) + go (TisDot w h j) = BTisGar (go (CenCab [AxisLimb 1] [(w, h)])) (go j) + go (TisWut w h j k) = go (TisDot w (WutCol h j (Wing w)) k) + --go (TisKet skin wing h j) + -- = BTisGar + -- (go (KetTis + go (TisLed h j) = BTisGar (go j) (go h) + go (TisLus h j) = BTisGar (go (HAutocons [h, (H_ 1)])) (go j) + go (TisHep h j) = go (TisLus j h) + go (TisSig hs) = foldr BTisGar (go (H_ 1)) (map go hs) + -- + go (WutBar hs) + = foldr + (\h r -> BWutCol (go h) (BRock "f" (Atom 0)) r) + (BRock "f" (Atom 1)) + hs + go (WutPam hs) + = foldr + (\h r -> BWutCol (go h) r (BRock"f" (Atom 1))) + (BRock "f" (Atom 0)) + hs + go (WutDot h j k) = BWutCol (go h) (go k) (go j) + go (WutLed h j) = BWutCol (go h) BZapZap (go j) + go (WutGar h j) = BWutCol (go h) (go j) BZapZap + go (WutKet wing h j) + = BWutCol (go (WutTis (SBase (SAtom "")) wing)) (go h) (go j) + + --go (WutKet + -- + go (ZapWut (Left vers) h) + | vers >= hoonVersion = go h + | otherwise = error "hoon-version" + go (ZapWut (Right (lower, upper)) h) + | lower <= hoonVersion && hoonVersion <= upper = go h + | otherwise = error "hoon-version" + + desugarChanges = map (\(w, h) -> (w, go h)) + +grip :: Skin -> Hoon -> Hoon +grip = error "grip not implemented" + + + diff --git a/pkg/hs/hoon/src/IR/Desugar.hs b/pkg/hs/hoon/src/IR/Desugar.hs new file mode 100644 index 000000000..270dfc763 --- /dev/null +++ b/pkg/hs/hoon/src/IR/Desugar.hs @@ -0,0 +1,183 @@ +module IR.Desugar where + +import ClassyPrelude hiding (union) + +import IR.Ty +import Control.Lens + +import Data.Foldable (foldr1) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Char (ord) +import Text.Show.Pretty (pPrint) + +import qualified AST.Parser as AST +import qualified AST.Types as AST +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified IR.Infer as IR +import qualified IR.Ty as IR +import qualified LL.Run as LL +import qualified LL.Types as LL +import qualified Prelude +import qualified System.Exit as Sys + +-------------------------------------------------------------------------------- + +list :: [IR.Hoon] -> IR.Hoon +list [] = HAtom 0 +list (x:xs) = HCons x (list xs) + +tuple :: NonEmpty IR.Hoon -> IR.Hoon +tuple (x :| []) = x +tuple (x :| y : zs) = HCons x (tuple (y :| zs)) + +baseToTy :: AST.Base -> Ty +baseToTy = \case + AST.BVoid -> bot + AST.BNull -> tyNull + AST.BFlag -> tyBool + AST.BNoun -> top + AST.BCell -> tyAnyCell `union` tyAnyCore + AST.BAtom -> tyAnyAtom + +gateTy :: Ty -> Ty -> Ty -> Ty +gateTy ctx arg result = tyCore batt ctx + where + batt = mapFromList [("", result)] + ctx = tyCell arg ctx + +specToTy :: AST.Spec -> Ty +specToTy = \case + AST.SBase b -> baseToTy b + AST.SFaceOp f s -> specToTy (AST.SBucTis f s) + AST.STuple specs -> specToTy (AST.SBucCol specs) + AST.SBucCol specs -> foldr1 tyCell (specToTy <$> specs) + AST.SBucHep a r -> gateTy top (specToTy a) (specToTy r) -- TODO Ctx type + AST.SBucTis s y -> let y' = specToTy y + in y' { tFace = Set.insert s (tFace y') } + AST.SBucWut specs -> foldr1 union (specToTy <$> specs) + AST.SBucPat x y -> specToTy x `union` specToTy x + AST.SBucKet x y -> specToTy x `union` specToTy y + AST.SBucCen specs -> foldr1 union (specToTy <$> specs) + +armNm "" = "$" +armNm nm = nm + +arm :: Sym -> AST.Hoon -> Either String (Ty, AST.Hoon) +arm _ (AST.KetHep s h) = pure (specToTy s, h) +arm nm _ = Left msg + where msg = mconcat [ "Arm ", armNm nm, " needs a type declaration" ] + +axisPath :: Nat -> Maybe TreePath +axisPath 0 = Nothing +axisPath 1 = Just [] +axisPath 2 = Just [False] +axisPath 3 = Just [True] +axisPath n + | 0==(n `rem` 2) = (++) <$> axisPath (n `quot` 2) <*> axisPath 2 + | otherwise = (++) <$> axisPath (n `quot` 2) <*> axisPath 3 + +mbErr :: String -> Maybe a -> Either String a +mbErr err = \case Nothing -> Left err + Just a -> pure a + +wing :: AST.Wing -> Either String Wing +wing = traverse \case + Left a -> WAxis <$> mbErr "+0 is not valid" (axisPath a) + Right n -> Right (WName n) + +core :: Map Sym AST.Hoon -> Either String (Map Sym (Ty, AST.Hoon)) +core = Map.traverseWithKey arm + +desugar :: AST.Hoon -> Either String IR.Hoon +desugar = \case + AST.Sig -> pure (HAtom 0) + AST.No -> pure (HAtom 1) + AST.Yes -> pure (HAtom 0) + AST.Bar -> pure (HAtom 1) + AST.Pam -> pure (HAtom 0) + AST.Hep -> pure (HRef [WAxis [False]]) + AST.Lus -> pure (HRef [WAxis [True]]) + AST.IsEqIrr x y -> desugar (AST.IsEq x y) + AST.IsEq x y -> HEq <$> desugar x <*> desugar y + AST.IncrIrr x -> desugar (AST.Incr x) + AST.Incr x -> HSucc <$> desugar x + AST.Tape t -> pure (list (HAtom . ord <$> unpack t)) + AST.Cord _ -> pure (HAtom 1337) + AST.Atom a -> pure (HAtom a) + AST.Wing ss -> HRef <$> wing ss + AST.FaceOp n h -> desugar (AST.KetTis n h) + AST.KetTis n h -> HFace n <$> desugar h + AST.Tupl xs -> desugar (AST.ColTar xs) + AST.ColOp x y -> desugar (AST.TisGal x y) + AST.BarCen arms -> do bat <- core arms >>= traverse (traverseOf _2 desugar) + pure (HCore bat) + AST.TisDot w x y -> do x <- desugar x + y <- desugar y + w <- wing w + pure (HWith + (HEdit w + (HLike (HRef w) x) + (HRef [])) + y) + AST.BarTis s h -> desugar (AST.TisGar + (AST.Tupl [s, AST.Wing []]) + (AST.BarCen (mapFromList [("", h)]))) + AST.BarHep x -> do (t, x') <- arm "" x + x'' <- desugar x' + pure (HWith + (HCore (mapFromList [("", (t, x''))])) + (HRef [WName ""])) + AST.TisGal x y -> desugar (AST.TisGar y x) + AST.TisGar x y -> HWith <$> desugar x <*> desugar y + AST.KetHep s x -> HCast (specToTy s) <$> desugar x + AST.ColSig xs -> list <$> traverse desugar xs + AST.ColTar [] -> Left "empty tuple" + AST.ColTar (x:xs) -> tuple <$> traverse desugar (x :| xs) + AST.ColHep x y -> desugar (AST.ColTar [x, y]) + AST.ColLus x y z -> desugar (AST.ColTar [x, y, z]) + AST.ColKet x y z a -> desugar (AST.ColTar [x, y, z, a]) + AST.WutTis s h -> do h <- desugar h + pure (HNest (Pat $ specToTy s) h) + AST.WutKet x y z -> desugar (AST.WutPat x z y) + AST.WutPat x y z -> do x <- desugar x + y <- desugar y + z <- desugar z + pure (HIf (HNest (Pat tyAnyAtom) x) y z) + AST.WutCol x y z -> HIf <$> desugar x <*> desugar y <*> desugar z + +getRightAndShow :: Show r => (l -> Text) -> Either l r -> IO r +getRightAndShow err = \case + Left e -> putStrLn (err e) >> Sys.exitFailure + Right x -> pPrint x >> putStrLn "" >> pure x + +main :: IO () +main = do + ex <- Prelude.head <$> getArgs + putStrLn "== Parsing ==" + ast <- getRightAndShow id (AST.parse ex) + putStrLn "== Desugaring ==" + ir <- getRightAndShow pack (desugar ast) + putStrLn "== Type Inferring ==" + ty <- getRightAndShow pack (IR.infer tyNull ir) + putStrLn "== Compiling ==" + ll <- getRightAndShow pack (IR.down tyNull ir) + putStrLn "== Result Type ==" + _ <- getRightAndShow pack (Right (ll ^. LL.llTy)) + putStrLn "== Result ==" + res <- getRightAndShow pack (LL.runLL (LL.VAtom 0) ll) + pure () + +sugar :: LL.LL a -> AST.Hoon +sugar = \case + LL.LWith _ x y -> AST.ColOp (sugar y) (sugar x) + LL.LAxis _ p -> undefined + LL.LEdit _ p x y -> AST.TisDot undefined undefined undefined + LL.LFire _ s _ -> AST.Wing [Right s] + LL.LAtom _ n -> AST.Atom n + LL.LPair _ x y -> AST.Tupl [sugar x, sugar y] + LL.LCore _ _bat -> undefined + LL.LSucc _ x -> AST.IncrIrr (sugar x) + LL.LTest _ x y z -> AST.WutCol (sugar x) (sugar y) (sugar z) + LL.LCelQ _ x -> AST.WutKet (sugar x) (AST.Atom 0) (AST.Atom 1) + LL.LEqlQ _ x y -> AST.IsEqIrr (sugar x) (sugar y) diff --git a/pkg/hs/hoon/src/IR/Infer.hs b/pkg/hs/hoon/src/IR/Infer.hs new file mode 100644 index 000000000..6ddd835a5 --- /dev/null +++ b/pkg/hs/hoon/src/IR/Infer.hs @@ -0,0 +1,213 @@ +module IR.Infer where + +import ClassyPrelude hiding (union, intersect, subtract, negate) +import Control.Monad.Fix +import Data.Void +import IR.Ty + +import Data.List.NonEmpty +import LL.Types hiding (L, R, Ctx) +import Control.Category ((>>>)) +import Control.Lens +import Data.Function ((&)) +import Data.Maybe (fromJust) + +import qualified LL.Types as LL +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified IR.Wing as Wing +import qualified Prelude + + +-- Code Inference -------------------------------------------------------------- + +infer :: Ty -> Hoon -> Either String Ty +infer sut h = view llTy <$> down sut h + +splitPattern :: Ty -> Ty -> (Ty, Ty) +splitPattern pat sut = (pat `intersect` sut, pat `diff` sut) + +traversePair :: Applicative f => (f a, f b) -> f (a, b) +traversePair (mx, my) = (,) <$> mx <*> my + +refine :: Wing -> Ty -> Ty -> Either String (Ty, Ty) +refine w pat sut = do + (_,oldTy) <- Wing.resolve w sut + + let matchBr = pat `intersect` oldTy + elseBr = pat `diff` oldTy + update = \t -> snd <$> Wing.edit w t sut + + traversePair (update matchBr, update elseBr) + +extractRefinement :: Ty -> Hoon -> Either String (Ty, Ty) +extractRefinement sut (HNest (Pat p) h@(HRef w)) = refine w p sut +extractRefinement sut _ = pure (sut, sut) + + +-- Resolve Names and Infer Types ----------------------------------------------- + +splitHoonPath :: HoonPath -> Either HoonPath (HoonPath, Sym, Core Ty) +splitHoonPath pp = pp ^? _Snoc & \case + Just (xs, Arm n c) -> Right (xs, n, c) + _ -> Left pp + +fromHoonPath :: HoonPath -> LLPath +fromHoonPath = catMaybes . fmap \case + Dot -> Nothing + Arm _ _ -> Nothing + L -> pure LL.L + R -> pure LL.R + Ctx -> pure LL.Ctx + +resolve :: Ty -> Wing -> Either String LLTy +resolve sut w = do + (hoonPath, resTy) <- Wing.resolve w sut + pure $ splitHoonPath hoonPath & \case + Left p -> LAxis resTy (fromHoonPath p) + Right (p, arm, core) -> lFire resTy (fromHoonPath p) arm core + + where + lFire :: Ty -> LLPath -> Sym -> Core Ty -> LLTy + lFire ty [] arm (Core bat ctx) = LFire ty arm bat + lFire ty axis arm (Core bat ctx) = LWith ty (LFire ty arm bat) + (LAxis (tyCore bat ctx) axis) + +-- TODO Should we produce an LFire if we edit an arm? +mkEdit :: Ty -> Wing -> LLTy -> LLTy -> Either String LLTy +mkEdit sut w v x = do + (p,ty) <- Wing.edit w (x ^. llTy) (v ^. llTy) + p <- pure (fromHoonPath p) + pure (LEdit ty p v x) + +disjoin, conjoin :: LLTy -> LLTy -> LLTy +disjoin x y = LTest tyBool x llYes y +conjoin x y = LTest tyBool x y llNo + +negate :: LLTy -> LLTy +negate x = LTest tyBool x llNo llYes + +reduce1 :: (a -> a -> a) -> a -> [a] -> a +reduce1 f z [] = z +reduce1 f z (x:xs) = foldl' f x xs + +disjoinAll, conjoinAll :: [LLTy] -> LLTy +disjoinAll = reduce1 disjoin llYes +conjoinAll = reduce1 conjoin llNo + +fishAtom :: (LLPath, Ty) -> Nat -> Either String LLTy +fishAtom (p, t) n = pure (LEqlQ tyBool (LAxis t p) (LAtom (tyConst n) n)) + +-- TODO maybe this is wrong? +fishCell :: (LLPath, Ty) -> Cell Ty -> Either String LLTy +fishCell (p, sut) (Cell l r) = + let cellSut = bot { tCell = tCell sut } + in if cellSut == bot then pure llNo else do + lef <- Wing.getPath [L] cellSut + rit <- Wing.getPath [R] cellSut + left <- fishTy (p ++ [LL.L], lef) l + right <- fishTy (p ++ [LL.R], rit) r + pure (conjoin left right) + +fishCore :: (LLPath, Ty) -> Core Ty -> Either String LLTy +fishCore _ _ = Left "Can't fish using core type." + +fishHappy :: Ord a + => ((LLPath, Ty) -> a -> Either String LLTy) + -> (LLPath, Ty) + -> Happy a + -> Either String LLTy +fishHappy f p (Fork (setToList -> xs)) = disjoinAll <$> traverse (f p) xs +fishHappy f p (Isnt (setToList -> xs)) = conjoinAll <$> traverse (fmap negate . (f p)) xs + +fishFork :: Ord a + => ((LLPath, Ty) -> a -> Either String LLTy) + -> (LLPath, Ty) + -> Fork a + -> Either String LLTy +fishFork f _ Top = pure llYes +fishFork f p (FFork (setToList -> xs)) = disjoinAll <$> traverse (f p) xs + +fishTy :: (LLPath, Ty) -> Ty -> Either String LLTy +fishTy (p, sut) t@Ty{..} = do + atomic <- fishHappy fishAtom (p, sut) tAtom + core <- fishHappy fishCore (p, sut) tCore + cellular <- fishFork fishCell (p, sut) tCell + let atomic' = conjoin (negate (LCelQ tyBool (LAxis sut p))) atomic + cellular' = conjoin (LCelQ tyBool (LAxis sut p)) cellular + pure (disjoinAll [atomic, core, cellular]) + +doesNest :: LLTy -> Pat -> Either String LLTy +doesNest (LAxis t p) (Pat ref) = fishTy (p, t) ref +doesNest h (Pat ref) = do + j <- fishTy ([], (h ^. llTy)) ref + pure (LWith tyBool h (simplify j)) + +simplify :: LLTy -> LLTy +simplify = \case + LTest t c x y -> simplify c & \case + LAtom _ 0 -> simplify x + LAtom _ 1 -> simplify y + c' -> LTest t c' (simplify x) (simplify y) + LWith t x y -> LWith t (simplify x) (simplify y) + LEdit t p x y -> LEdit t p (simplify x) (simplify y) + LPair t x y -> LPair t (simplify x) (simplify y) + LCore t b -> LCore t (simplify <$> b) + LSucc t x -> LSucc t (simplify x) + LCelQ t x -> LCelQ t (simplify x) + LEqlQ t x y -> LEqlQ t (simplify x) (simplify y) + ll -> ll + +mbErr :: String -> Maybe a -> Either String a +mbErr err = \case Nothing -> Left err + Just a -> pure a + +down :: Ty -> Hoon -> Either String LLTy +down sut = \case + HRef w -> resolve sut w + HCast t h -> do h <- down sut h + let nestFail = mconcat [ show (h ^. llTy) + , " does not nest in " + , show t + ] + mbErr nestFail $ guard (view llTy h `nest` t) + pure (h & set llTy t) + HFace f h -> over llTy (addFace f) <$> down sut h + HLike x y -> do x <- down sut x + down sut (HCast (view llTy x) y) + HEdit w v x -> do v <- down sut v + x <- down sut x + mkEdit sut w v x + HEq h j -> do h <- down sut h + j <- down sut j + let (ht, jt) = (h ^. llTy, j ^. llTy) + let nestFail = mconcat [ "type mismatch: " + , show ht + , " vs " + , show jt + ] + mbErr nestFail $ guard (nest ht jt || nest jt ht) + pure (LEqlQ tyBool h j) + HAtom a -> pure (LAtom (tyConst a) a) + HCons h j -> do h <- down sut h + j <- down sut j + let ty = tyCell (h ^. llTy) (j ^. llTy) + pure (LPair ty h j) + HSucc h -> LSucc tyAnyAtom <$> down sut (HCast tyAnyAtom h) + HIf c l r -> do (lSut, rSut) <- extractRefinement sut c + c <- down sut c + l <- down lSut l + r <- down rSut r + let nestFail = show c <> " is not a boolean value" + mbErr nestFail $ guard (nest (c ^. llTy) tyBool) + let res = view llTy l `union` view llTy r + pure (LTest res c l r) + HWith h j -> do h <- down sut h + j <- down (h ^. llTy) j + pure (LWith (j ^. llTy) h j) + HNest p h -> do h <- down sut h + doesNest h p + HCore arms -> do let coreTy = tyCore (fst <$> arms) sut + let go decl arm = down coreTy (HCast decl arm) + arms <- traverse (uncurry go) arms + pure (LCore coreTy arms) diff --git a/pkg/hs/hoon/src/IR/Ty.hs b/pkg/hs/hoon/src/IR/Ty.hs new file mode 100644 index 000000000..1ec8c3ad6 --- /dev/null +++ b/pkg/hs/hoon/src/IR/Ty.hs @@ -0,0 +1,660 @@ +module IR.Ty where + +import ClassyPrelude hiding (union, intersect) +import Control.Lens +import Control.Lens.TH +import Control.Monad.Fix +import Data.Void + +import Control.Category ((>>>)) +import Data.Function ((&)) +import Data.Maybe (fromJust) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Prelude + +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck as QC +import Test.QuickCheck + + +-- Happy and Fork -------------------------------------------------------------- + +data Fork a = Top | FFork (Set a) + deriving (Eq, Ord) + +showHappy :: (Show a, Ord a) => String -> Set a -> String +showHappy i xs = intercalate i (show <$> setToList xs) + +instance (Ord a, Show a) => Show (Fork a) + where + show Top = "Top" + show (FFork alts) | null alts = "Bot" + show (FFork (setToList -> [x])) = show x + show (FFork alts) = + "(" <> showHappy " ∪ " alts <> ")" + +data Happy a = Fork (Set a) | Isnt (Set a) + deriving (Eq, Ord) + +instance (Ord a, Show a) => Show (Happy a) + where + show (Isnt alts) | null alts = "Top" + show (Fork alts) | null alts = "Bot" + show (Fork (setToList -> [x])) = show x + show (Isnt (setToList -> [x])) = "not:" <> show x + show (Fork alts) = showHappy " ∪ " alts + show (Isnt alts) = "not:" <> showHappy " ∩ " alts + +_HappyFork :: Ord a => Prism' (Happy a) (Fork a) +_HappyFork = prism' mk get + where + mk Top = Isnt mempty + mk (FFork f) = Fork f + get (Isnt i) = if null i then pure Top else Nothing + get (Fork h) = pure (FFork h) + +_Singleton :: Ord a => Prism' (Fork a) a +_Singleton = prism' mk get + where + mk a = FFork (Set.singleton a) + get = \case FFork (setToList -> [x]) -> Just x + _ -> Nothing + +nullHappy :: Ord a => Happy a -> Bool +nullHappy (Fork f) = null f +nullHappy (Isnt i) = False + +nullFork :: Ord a => Fork a -> Bool +nullFork = nullHappy . review _HappyFork + +traverseSet :: (Applicative f, Ord a, Ord b) => (a -> f b) -> Set a -> f (Set b) +traverseSet f = fmap setFromList . traverse f . setToList + +mapFork :: Ord b => Fork b -> (a -> b) -> Fork a -> Fork b +mapFork top _ Top = top +mapFork _ f (FFork k) = FFork (Set.map f k) + +traverseFork :: (Applicative f, Ord a, Ord b) + => f (Fork b) -> (a -> f b) -> Fork a -> f (Fork b) +traverseFork top f = \case + Top -> top + FFork k -> FFork <$> traverseSet f k + +traverseHappyFork :: (Applicative f, Ord a) + => (a -> f a) -> Happy a -> f (Happy a) +traverseHappyFork f = \case + Isnt k -> pure (Isnt k) + Fork k -> Fork <$> traverseSet f k + +-- Type Types ------------------------------------------------------------------ + +type Sym = String +type Nat = Int + +data Cell t = Cell t t + deriving (Eq, Ord) + +instance Show t => Show (Cell t) where + show (Cell l r) = mconcat [ "[" + , filter (/= '"') (show l) + , " " + , filter (/= '"') (show r) + , "]" + ] + +data Core t = Core (Map Sym t) t + deriving (Eq, Ord) + +instance Show t => Show (Core t) where + show (Core batt ctx) = mconcat [ "%:(" + , filter (/= '"') (show ctx) + , " → " + , filter (/= '"') (show $ mapToList batt) + , ")" + ] + +data Func t = Func t t + deriving (Eq, Ord, Show) + +data Ty = Ty { tFace :: Set Sym + , tAtom :: Happy Nat + , tCore :: Happy (Core Ty) + , tCell :: Fork (Cell Ty) + -- , tFunc :: Func Ty + } + deriving (Eq, Ord) + +instance Show Ty + where + show t = "\"" <> showTy t <> "\"" + +showTy :: Ty -> String +showTy t@Ty{..} = faces <> niceTy + where + niceTy = let tyNoFace = t { tFace = mempty } in + if top == tyNoFace then "*" else + if tyBool == tyNoFace then "?" else + t ^? _Discrim & \case + Just d -> show d + Nothing -> let alts = catMaybes [ atoms, cores, cells ] + in "(" <> intercalate " ∪ " alts <> ")" + faces = if null tFace then "" else unpack (intercalate "," tFace <> "=") + atoms = if tAtom == bot then Nothing + else if tAtom == top then Just "@" + else Just (show tAtom) + cores = if tCore == bot then Nothing + else if tCore == top then Just "%" + else Just (show tCore) + cells = if tCell == bot then Nothing + else if tCell == top then Just "^" + else Just (show tCell) + +-- IR Types -------------------------------------------------------------------- + +type TreePath = [Bool] + +data Limb + = WName Sym + | WAxis TreePath + | WDot + deriving (Eq, Ord, Show) + +type Wing = [Limb] + +newtype Pat = Pat Ty + deriving (Eq, Ord, Show) + +data Hoon + = HRef Wing + | HNest Pat Hoon + | HSucc Hoon + | HEq Hoon Hoon + | HIf Hoon Hoon Hoon + | HAtom Nat + | HCons Hoon Hoon + | HEdit Wing Hoon Hoon + | HWith Hoon Hoon + | HFace Sym Hoon + | HCore (Map Sym (Ty, Hoon)) + | HCast Ty Hoon + | HLike Hoon Hoon + deriving (Eq, Ord, Show) + + +-- Path Types ------------------------------------------------------------------ + +data HoonDir = Dot | L | R | Ctx | Arm Sym (Core Ty) + deriving (Eq, Ord, Show) + +type HoonPath = [HoonDir] + + +-- Type Discrimination --------------------------------------------------------- + +data Discrim + = DAtom (Fork Nat) + | DCore (Fork (Core Ty)) -- TODO: Should this be Core Discrim + | DCell (Fork (Cell Ty)) + | DCoreAndCell (Fork (Core Ty)) (Fork (Cell Ty)) + deriving (Eq, Ord) + +instance Show Discrim where + show = \case + DAtom Top -> "@" + DCore Top -> "%" + DCell Top -> "^" + + DAtom (FFork (setToList -> [])) -> "!" + DCell (FFork (setToList -> [])) -> "!" + DCore (FFork (setToList -> [])) -> "!" + + DAtom (FFork (setToList -> [x])) -> show x + DCell (FFork (setToList -> [x])) -> show x + DCore (FFork (setToList -> [x])) -> show x + + DAtom (FFork xs) -> showHappy " ∪ " xs + DCell (FFork xs) -> showHappy " ∪ " xs + DCore (FFork xs) -> showHappy " ∪ " xs + DCoreAndCell k p -> showHappy " ∪ " (setFromList [DCore k, DCell p]) + + +-- Boolean algebras ------------------------------------------------------------ + +class BoolAlg a where + top :: a + bot :: a + complement :: a -> a + union :: a -> a -> a + intersect :: a -> a -> a + nest :: a -> a -> Bool + + diff :: a -> a -> a + diff x y = intersect x (complement y) + + +-- Ur Elements ----------------------------------------------------------------- + +class Ord a => Ur a + +instance Ur Nat +instance (Ord t) => Ur (Core t) + + +-- Happy BoolAlg --------------------------------------------------------------- + +instance Ur a => BoolAlg (Happy a) where + bot = Fork Set.empty + top = Isnt Set.empty + + complement (Fork x) = Isnt x + complement (Isnt x) = Fork x + + union (Fork x) (Fork y) = Fork (Set.union x y) + union (Isnt x) (Isnt y) = Isnt (Set.intersection x y) + union (Isnt x) (Fork y) = Isnt (Set.difference x y) + union (Fork x) (Isnt y) = Isnt (Set.difference y x) + + intersect (Fork x) (Fork y) = Fork (Set.intersection x y) + intersect (Isnt x) (Isnt y) = Isnt (Set.union x y) + intersect (Isnt x) (Fork y) = Fork (Set.difference y x) + intersect (Fork x) (Isnt y) = Fork (Set.difference x y) + + nest (Fork xs) (Fork ys) = xs `Set.isSubsetOf` ys + nest (Isnt xs) (Isnt ys) = ys `Set.isSubsetOf` xs + nest (Fork xs) (Isnt ys) = Set.null (ys `Set.intersection` xs) + nest (Isnt xs) (Fork ys) = False + + +-- (Fork Cell) BoolAlg --------------------------------------------------------- + +instance (Ord t, BoolAlg t) => BoolAlg (Fork (Cell t)) where + bot = FFork mempty + top = Top + + complement Top = bot + complement (FFork cs) = FFork $ Set.fromList do + (Cell x y) <- toList cs + id [ Cell (complement x) y + , Cell x (complement y) + , Cell (complement x) (complement y) + ] + + union Top _ = Top + union _ Top = Top + union (FFork xs) (FFork ys) = FFork (Set.union xs ys) + + nest _ Top = True + nest Top _ = False + nest (FFork xs) (FFork ys) = all (\x -> any (cellNest x) ys) xs + where + cellNest (Cell x1 y1) (Cell x2 y2) = nest x1 x2 && nest y1 y2 + + intersect Top f = f + intersect f Top = f + intersect (FFork xs) (FFork ys) = FFork $ Set.fromList do + (Cell x1 x2) <- toList xs + (Cell y1 y2) <- toList ys + let z1 = (intersect x1 y1) + z2 = (intersect x2 y2) + guard (z1 /= bot && z2 /= bot) + pure (Cell z1 z2) + + +-- Func BoolAlg ---------------------------------------------------------------- + +instance BoolAlg t => BoolAlg (Func t) where + bot = Func top bot + top = Func bot top + + complement (Func x y) = Func (complement x) (complement y) + + union (Func x1 y1) (Func x2 y2) = Func (intersect x1 x2) (union y1 y2) + intersect (Func x1 y1) (Func x2 y2) = Func (union x1 x2) (union y1 y2) + + nest (Func x1 y1) (Func x2 y2) = nest x2 x1 && nest y1 y2 + +-- Ty BoolAlg ------------------------------------------------------------------ + +instance BoolAlg Ty where + bot = Ty mempty bot bot bot + top = Ty mempty top top top + + complement = \case + Ty{tFace,tAtom,tCore,tCell} -> + Ty { tFace = mempty + , tAtom = complement tAtom + , tCore = complement tCore + , tCell = complement tCell + } + + union p q = + Ty { tFace = tFace p `Set.intersection` tFace q + , tAtom = tAtom p `union` tAtom q + , tCore = tCore p `union` tCore q + , tCell = tCell p `union` tCell q + } + + intersect p q = + Ty { tFace = Set.union (tFace p) (tFace q) + , tAtom = tAtom p `intersect` tAtom q + , tCore = tCore p `intersect` tCore q + , tCell = tCell p `intersect` tCell q + } + + nest p q = + and [ nest (tAtom p) (tAtom q) + , nest (tCell p) (tCell q) + , nest (tCore p) (tCore q) + ] + + diff p q = + Ty { tFace = Set.union (tFace p) (tFace q) + , tAtom = tAtom p `diff` tAtom q + , tCore = tCore p `diff` tCore q + , tCell = tCell p `diff` tCell q + } + + +-- Basic Types ----------------------------------------------------------------- + +tyAnyCell, tyAnyAtom, tyAnyCore :: Ty +tyAnyAtom = bot { tAtom = top } +tyAnyCell = bot { tCell = top } +tyAnyCore = bot { tCore = top } + +tyConst :: Nat -> Ty +tyConst x = bot { tAtom = Fork (singleton x) } + +tyCell :: Ty -> Ty -> Ty +tyCell x y = bot { tCell = _Singleton # Cell x y } + +tyCore :: Map Sym Ty -> Ty -> Ty +tyCore arms ctx = bot { tCore = Fork (singleton (Core arms ctx)) } + +tyNull, tyYes, tyNo, tyBool :: Ty +tyNull = tyConst 0 +tyYes = tyConst 0 +tyNo = tyConst 1 +tyBool = tyYes `union` tyNo + +addFace :: Sym -> Ty -> Ty +addFace fc t = t { tFace = Set.insert fc (tFace t) } + + +-- Lenses ---------------------------------------------------------------------- + +{- + TODO The review case is not quite right. If we do + `DAtom nullFork # _HappyFork`, we will get `tyNull`. So + this law is broken: + + Just f == (f # _HappyFork) ^? _HappyFork +-} +_Discrim :: Prism' Ty Discrim +_Discrim = prism' mk get + where + mk = \case + DAtom f -> bot { tAtom = _HappyFork # f } + DCore f -> bot { tCore = _HappyFork # f } + DCell f -> bot { tCell = f } + + DCoreAndCell core cell -> + bot { tCell = cell, tCore = _HappyFork # core } + + get Ty{..} = + (nullHappy tCore, nullFork tCell, nullHappy tAtom) & \case + ( False, True, True ) -> DCore <$> tCore ^? _HappyFork + ( True, False, True ) -> DCell <$> pure tCell + ( True, True, False ) -> DAtom <$> tAtom ^? _HappyFork + ( False, False, True ) -> DCoreAndCell <$> tCore ^? _HappyFork + <*> pure tCell + _ -> Nothing + +makePrisms ''HoonDir +makePrisms ''Discrim + +_Cell :: Prism' Ty (Fork (Cell Ty)) +_Cell = _Discrim . _DCell + +_Core :: Prism' Ty (Fork (Core Ty)) +_Core = _Discrim . _DCore + +_Atom :: Prism' Ty (Fork Nat) +_Atom = _Discrim . _DAtom + +_CoreAndCell :: Prism' Ty (Fork (Core Ty), Fork (Cell Ty)) +_CoreAndCell = _Discrim . _DCoreAndCell + + +-- Cast cores to cells. -------------------------------------------------------- + +castCoreToCell :: (BoolAlg t) => Core t -> Cell t +castCoreToCell (Core _ c) = Cell top c + +castTyToCell :: Ty -> Maybe Ty +castTyToCell = fmap (review _Cell . cast) . preview _CoreAndCell + where + cast (cores, cells) = union cells (mapFork Top castCoreToCell cores) + + +-- Testing: Generators --------------------------------------------------------- + +-- prop_example :: Int -> Int -> Bool +-- prop_example a b = a + b == b + a + +-- tests :: TestTree +-- tests = $(testGroupGenerator) + + +perms :: forall a. Show a => [a] -> [[a]] +perms as = do + ii <- iis (length as) + pure (foldr f [] (zip ii as)) + where + f (True, x) xs = x:xs + f (False, x) xs = xs + + iis :: Int -> [[Bool]] + iis 0 = pure [True, False] + iis n = do + x <- iis (n - 1) + b <- [True, False] + pure (b:x) + +genFace :: Gen (Set Sym) +genFace = do + xs <- oneof (pure <$> perms ["p", "q"]) + pure (setFromList xs) + +instance Arbitrary Ty where + arbitrary = do + getSize >>= \case + 0 -> oneof [pure top, pure bot] + 1 -> resize 0 (Ty <$> genFace <*> arbitrary <*> arbitrary <*> arbitrary) + n -> Ty <$> genFace <*> arbitrary <*> arbitrary <*> resize 1 arbitrary + +instance (Arbitrary t, Ord t) => Arbitrary (Happy (Core t)) where + -- TODO + arbitrary = oneof [ pure (Fork mempty), pure (Isnt mempty) ] + +instance (Arbitrary t, Ord t) => Arbitrary (Fork t) where + arbitrary = oneof [ pure Top, FFork <$> setFromList <$> listOf arbitrary ] + +instance Arbitrary t => Arbitrary (Cell t) where + arbitrary = Cell <$> arbitrary <*> arbitrary + +instance Arbitrary (Happy Nat) where + arbitrary = do + xs <- oneof (pure <$> perms [0, 1]) + b <- arbitrary + pure case b of + True -> Fork (setFromList xs) + False -> Isnt (setFromList xs) + +instance Arbitrary t => Arbitrary (Func t) where + arbitrary = Func <$> arbitrary <*> arbitrary + +-- can we make this ==? +equiv :: (BoolAlg a) => a -> a -> Bool +equiv x y = nest x y && nest y x + +nestRefl :: (Arbitrary a, BoolAlg a) => a -> Bool +nestRefl x = nest x x + +subGivesBot :: (Arbitrary a, Eq a, BoolAlg a) => a -> Bool +subGivesBot x = bot == diff x x + +nestTrans :: (Arbitrary a, BoolAlg a) => a -> a -> a -> Property +nestTrans a b c = (nest a b && nest b c) ==> nest a c + +nestUnion :: (Arbitrary a, BoolAlg a) => a -> a -> Bool +nestUnion x y = nest x u && nest y u + where u = x `union` y + +nestIntersect :: (Arbitrary a, BoolAlg a) => a -> a -> Bool +nestIntersect x y = nest u x && nest u y + where u = x `intersect` y + +unionId :: (Arbitrary a, BoolAlg a) => a -> Bool +unionId x = union x bot `equiv` x + +intersectId :: (Arbitrary a, BoolAlg a) => a -> Bool +intersectId x = intersect x top `equiv` x + +unionAbsorbs :: (Arbitrary a, BoolAlg a) => a -> Bool +unionAbsorbs x = union x top `equiv` top + +intersectAbsorbs :: (Arbitrary a, BoolAlg a) => a -> Bool +intersectAbsorbs x = intersect x bot `equiv` bot + +unionCommutes :: (Arbitrary a, BoolAlg a) => a -> a -> Bool +unionCommutes x y = union x y `equiv` union y x + +intersectCommutes :: (Arbitrary a, BoolAlg a) => a -> a -> Bool +intersectCommutes x y = intersect x y `equiv` intersect y x + +unionAssociates :: (Arbitrary a, BoolAlg a) => a -> a -> a -> Bool +unionAssociates x y z = union x (union y z) `equiv` union (union x y) z + +intersectAssociates :: (Arbitrary a, BoolAlg a) => a -> a -> a -> Bool +intersectAssociates x y z = intersect x (intersect y z) + `equiv` intersect (intersect x y) z + +unionDistributes :: (Arbitrary a, BoolAlg a) => a -> a -> a -> Bool +unionDistributes x y z = union x (intersect y z) + `equiv` intersect (union x y) (union x z) + +intersectDistributes :: (Arbitrary a, BoolAlg a) => a -> a -> a -> Bool +intersectDistributes x y z = intersect x (union y z) + `equiv` union (intersect x y) (intersect x z) + +doubleCompl :: (Arbitrary a, BoolAlg a) => a -> Bool +doubleCompl x = equiv x (complement (complement x)) + +complSub :: (Arbitrary a, BoolAlg a) => a -> a -> Bool +complSub x y = diff x y `equiv` intersect x (complement y) + +deMorganUnion :: (Arbitrary a, BoolAlg a) => a -> a -> Bool +deMorganUnion x y = complement (union x y) `equiv` intersect (complement x) (complement y) + +deMorganIntersect :: (Arbitrary a, BoolAlg a) => a -> a -> Bool +deMorganIntersect x y = complement (intersect x y) `equiv` union (complement x) (complement y) + + +prop_nestReflAtom = nestRefl @(Happy Nat) +prop_nestTransAtom = nestTrans @(Happy Nat) +prop_nestUnionAtom = nestUnion @(Happy Nat) +prop_nestIntersectAtom = nestIntersect @(Happy Nat) +prop_unionIdAtom = unionId @(Happy Nat) +prop_intersectIdAtom = intersectId @(Happy Nat) +prop_unionAbsorbsAtom = unionAbsorbs @(Happy Nat) +prop_intersectAbsorbsAtom = intersectAbsorbs @(Happy Nat) +prop_unionCommutesAtom = unionCommutes @(Happy Nat) +prop_intersectCommutesAtom = intersectCommutes @(Happy Nat) +prop_unionAssociatesAtom = unionAssociates @(Happy Nat) +prop_intersectAssociatesAtom = intersectAssociates @(Happy Nat) +prop_unionDistributesAtom = unionDistributes @(Happy Nat) +prop_intersectDistributesAtom = intersectDistributes @(Happy Nat) +prop_doubleComplAtom = doubleCompl @(Happy Nat) +prop_complSubAtom = complSub @(Happy Nat) +prop_deMorganUnionAtom = deMorganUnion @(Happy Nat) +prop_deMorganIntersectAtom = deMorganIntersect @(Happy Nat) + +prop_nestReflCore = nestRefl @(Happy (Core (Happy Nat))) +prop_nestTransCore = nestTrans @(Happy (Core (Happy Nat))) +prop_nestUnionCore = nestUnion @(Happy (Core (Happy Nat))) +prop_nestIntersectCore = nestIntersect @(Happy (Core (Happy Nat))) +prop_unionIdCore = unionId @(Happy (Core (Happy Nat))) +prop_intersectIdCore = intersectId @(Happy (Core (Happy Nat))) +prop_unionAbsorbsCore = unionAbsorbs @(Happy (Core (Happy Nat))) +prop_intersectAbsorbsCore = intersectAbsorbs @(Happy (Core (Happy Nat))) +prop_unionCommutesCore = unionCommutes @(Happy (Core (Happy Nat))) +prop_intersectCommutesCore = intersectCommutes @(Happy (Core (Happy Nat))) +prop_unionAssociatesCore = unionAssociates @(Happy (Core (Happy Nat))) +prop_intersectAssociatesCore = intersectAssociates @(Happy (Core (Happy Nat))) +prop_unionDistributesCore = unionDistributes @(Happy (Core (Happy Nat))) +prop_intersectDistributesCore = intersectDistributes @(Happy (Core (Happy Nat))) +prop_doubleComplCore = doubleCompl @(Happy (Core (Happy Nat))) +prop_complSubCore = complSub @(Happy (Core (Happy Nat))) +prop_deMorganUnionCore = deMorganUnion @(Happy (Core (Happy Nat))) +prop_deMorganIntersectCore = deMorganIntersect @(Happy (Core (Happy Nat))) + +prop_nestReflCell = nestRefl @(Fork (Cell (Happy Nat))) +prop_nestTransCell = nestTrans @(Fork (Cell (Happy Nat))) +prop_nestUnionCell = nestUnion @(Fork (Cell (Happy Nat))) +prop_nestIntersectCell = nestIntersect @(Fork (Cell (Happy Nat))) +prop_unionIdCell = unionId @(Fork (Cell (Happy Nat))) +prop_intersectIdCell = intersectId @(Fork (Cell (Happy Nat))) +prop_unionAbsorbsCell = unionAbsorbs @(Fork (Cell (Happy Nat))) +prop_intersectAbsorbsCell = intersectAbsorbs @(Fork (Cell (Happy Nat))) +prop_unionCommutesCell = unionCommutes @(Fork (Cell (Happy Nat))) +prop_intersectCommutesCell = intersectCommutes @(Fork (Cell (Happy Nat))) +prop_unionAssociatesCell = unionAssociates @(Fork (Cell (Happy Nat))) +prop_intersectAssociatesCell = intersectAssociates @(Fork (Cell (Happy Nat))) +prop_unionDistributesCell = unionDistributes @(Fork (Cell (Happy Nat))) +prop_intersectDistributesCell = intersectDistributes @(Fork (Cell (Happy Nat))) +prop_doubleComplCell = doubleCompl @(Fork (Cell (Happy Nat))) +prop_complSubCell = complSub @(Fork (Cell (Happy Nat))) +prop_deMorganUnionCell = deMorganUnion @(Fork (Cell (Happy Nat))) +prop_deMorganIntersectCell = deMorganIntersect @(Fork (Cell (Happy Nat))) + +prop_nestReflFunc = nestRefl @(Func (Happy Nat)) +prop_nestTransFunc = nestTrans @(Func (Happy Nat)) +prop_nestUnionFunc = nestUnion @(Func (Happy Nat)) +prop_nestIntersectFunc = nestIntersect @(Func (Happy Nat)) +prop_unionIdFunc = unionId @(Func (Happy Nat)) +prop_intersectIdFunc = intersectId @(Func (Happy Nat)) +prop_unionAbsorbsFunc = unionAbsorbs @(Func (Happy Nat)) +prop_intersectAbsorbsFunc = intersectAbsorbs @(Func (Happy Nat)) +prop_unionCommutesFunc = unionCommutes @(Func (Happy Nat)) +prop_intersectCommutesFunc = intersectCommutes @(Func (Happy Nat)) +prop_unionAssociatesFunc = unionAssociates @(Func (Happy Nat)) +prop_intersectAssociatesFunc = intersectAssociates @(Func (Happy Nat)) +prop_unionDistributesFunc = unionDistributes @(Func (Happy Nat)) +prop_intersectDistributesFunc = intersectDistributes @(Func (Happy Nat)) +prop_doubleComplFunc = doubleCompl @(Func (Happy Nat)) +prop_complSubFunc = complSub @(Func (Happy Nat)) +prop_deMorganUnionFunc = deMorganUnion @(Func (Happy Nat)) +prop_deMorganIntersectFunc = deMorganIntersect @(Func (Happy Nat)) + +prop_nestReflTy = nestRefl @Ty +prop_nestTransTy = nestTrans @Ty +prop_nestUnionTy = nestUnion @Ty +prop_nestIntersectTy = nestIntersect @Ty +prop_unionIdTy = unionId @Ty +prop_intersectIdTy = intersectId @Ty +prop_unionAbsorbsTy = unionAbsorbs @Ty +prop_intersectAbsorbsTy = intersectAbsorbs @Ty +prop_unionCommutesTy = unionCommutes @Ty +prop_intersectCommutesTy = intersectCommutes @Ty +prop_unionAssociatesTy = unionAssociates @Ty +prop_intersectAssociatesTy = intersectAssociates @Ty +prop_unionDistributesTy = unionDistributes @Ty +prop_intersectDistributesTy = intersectDistributes @Ty +prop_doubleComplTy = doubleCompl @Ty +prop_complSubTy = complSub @Ty +prop_deMorganUnionTy = deMorganUnion @Ty +prop_deMorganIntersectTy = deMorganIntersect @Ty diff --git a/pkg/hs/hoon/src/IR/Wing.hs b/pkg/hs/hoon/src/IR/Wing.hs new file mode 100644 index 000000000..4737136ca --- /dev/null +++ b/pkg/hs/hoon/src/IR/Wing.hs @@ -0,0 +1,206 @@ +module IR.Wing where + +import ClassyPrelude hiding (union) +import Control.Lens hiding (union) +import IR.Ty + +import Control.Category ((>>>)) +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Data.Foldable (foldrM) + + +-- Search Forks ---------------------------------------------------------------- + +{- + Search all the branches of a fork, and merge the results. + + If the fork is `Top`, return `top`, otherwise `search` all the branches + of the fork and `merge` the results. This succeeds if all of the + searches succeed and all of the merges succeed. +-} +searchFork :: Ord a + => Either String b + -> (b -> b -> Either String b) + -> (a -> Either String b) + -> Fork a + -> Either String b +searchFork top merge search = \case + Top -> top + FFork alts -> do + results <- traverse search (setToList alts) + case results of + [] -> Left "searchFork: no matches" + r:rs -> foldrM merge r rs + + + +-- Traversals ------------------------------------------------------------------ + +atDir :: HoonDir -> Traversal' Ty Ty +atDir dd f t = dd & \case + Dot -> f t + Ctx -> walk _Core topCtx ctx + Arm s c -> walk _Core (topArm s) (arm s) + L -> walk _Cell topLeft left + R -> walk _Cell topRight right + where + sing :: Ord a => a -> Fork a + sing = review _Singleton + + topRight = sing <$> right (Cell top top) + topLeft = sing <$> left (Cell top top) + topCtx = sing <$> ctx (Core mempty top) + topArm s = sing <$> ctx (Core mempty top) + + right (Cell l r) = Cell <$> pure l <*> f r + left (Cell l r) = Cell <$> f l <*> pure r + ctx (Core a c) = Core a <$> f c + + arm s k@(Core a c) = + Map.lookup s a & \case + Nothing -> pure k + Just at -> do at' <- f at + pure (Core (Map.insert s at' a) c) + + walk :: (Ord a, Applicative f) + => Prism' Ty (Fork a) -> f (Fork a) -> (a -> f a) -> f Ty + walk p top get = + (t ^? p) & \case + Nothing -> pure t + Just fk -> review p <$> traverseFork top get fk + +atPath :: HoonPath -> Traversal' Ty Ty +atPath [] f t = f t +atPath (d:ds) f t = (atDir d . atPath ds) f t + +getPath :: HoonPath -> Ty -> Either String Ty +getPath d t = t ^.. atPath d & \case + [] -> Left ("No values found at path " <> show d) + (d:ds) -> pure (foldr union d ds) + + +-- Name Resolution ------------------------------------------------------------- + +mbErr :: String -> Maybe a -> Either String a +mbErr err = \case Nothing -> Left err + Just a -> pure a + +getName :: Sym -> Ty -> Either String (HoonPath, Ty) +getName nm = fmap (over _1 reverse) . go [] + where + go :: HoonPath -> Ty -> Either String (HoonPath, Ty) + go acc t | member nm (tFace t) = pure (acc, t) + go acc t = + mbErr "getName: Can't discriminate type" (t ^? _Discrim) >>= \case + DCore k -> searchFork top merge (goCore acc) k + DCell p -> searchFork top merge (goCell acc) p + DCoreAndCell _ _ -> Left "getName: Might be core or cell" + DAtom _ -> Left "getName: Search ended at atom" + + top :: Either String (HoonPath, Ty) + top = Left "Trying to search through top type" + + merge :: (HoonPath, Ty) -> (HoonPath, Ty) -> Either String (HoonPath, Ty) + merge (i,x) (j,y) = do + mbErr "face matches at differing locations" $ guard (i == j) + pure (i, union x y) + + goCore :: HoonPath -> Core Ty -> Either String (HoonPath, Ty) + goCore acc c@(Core arms ctx) = isArm <|> inCtx + where + isArm = ((Arm nm c:acc),) <$> + mbErr "no such arm" (Map.lookup nm arms) + inCtx = go (Ctx:acc) ctx + + goCell :: HoonPath -> Cell Ty -> Either String (HoonPath, Ty) + goCell acc (Cell l r) = go (L:acc) l <|> go (R:acc) r + +-- Simple Getters and Setters -------------------------------------------------- + +previewErr :: String -> Prism' a b -> a -> Either String b +previewErr err p a = mbErr err (a ^? p) + +getDir' :: HoonDir -> Ty -> Either String Ty +getDir' = \case + Dot -> pure + L -> previewErr notCell _Cell >=> + searchFork ptop merge (\(Cell l _) -> pure l) + R -> previewErr notCell _Cell >=> + searchFork ptop merge (\(Cell _ r) -> pure r) + Ctx -> previewErr notCore _Core >=> + searchFork ptop merge (\(Core _ c) -> pure c) + Arm s c -> \t -> do c' <- mbErr "getDir': can't discern core type" $ + t ^? _Core . _Singleton + mbErr "arm signature doesn't match core type" $ + guard (c == c') + pure (_Core . _Singleton # c) + where + notCell = "Trying to use cell-indexing into non-cell value" + notCore = "Trying to get context of non-core value" + merge = \x y -> pure (union x y) + ptop = pure top + +getPath' :: HoonPath -> Ty -> Either String Ty +getPath' [] t = pure t +getPath' (d:ds) t = getDir' d t >>= getPath' ds + +setDir' :: HoonDir -> Ty -> Ty -> Either String Ty +setDir' dd newTy t = dd & \case + Dot -> pure newTy + Ctx -> Left "Can't edit context type" + Arm s c -> Left "Can't edit arms" + L -> review _Cell . mapFork topLeft setLeft <$> asCell + R -> review _Cell . mapFork topRight setRight <$> asCell + where + asCell = mbErr "Can't get axis of non-cell value" (t ^? _Cell) + topRight = _Singleton # Cell top newTy + setRight (Cell l _) = Cell l newTy + topLeft = _Singleton # Cell newTy top + setLeft (Cell _ r) = Cell newTy r + + +-- Get and Edit Wings ---------------------------------------------------------- + +getAxis :: TreePath -> Ty -> Either String (HoonPath, Ty) +getAxis axis = fmap (path,) . getPath path + where + path = axis <&> \case { False -> L; True -> R } + +getLimb :: Limb -> Ty -> Either String (HoonPath, Ty) +getLimb (WAxis a) = getAxis a +getLimb (WName n) = getName n +getLimb WDot = \t -> pure ([Dot], t) + +{- + In Hoon, only the last arm name actually resolves to an arm, + everything else just refers to the core of that arm. `muck` handles + this transformation. +-} +resolve :: Wing -> Ty -> Either String (HoonPath, Ty) +resolve (reverse -> ww) tt = over _1 muck <$> go ww tt + where + go [] t = pure ([], t) + go (l:ls) t = do (p,t') <- getLimb l t + over _1 (p <>) <$> go ls t' + + muck = reverse . r . reverse + where + r [] = [] + r (d:ds) = d : filter (not . isWeird) ds + isWeird (Arm _ _) = True + isWeird Dot = True + isWeird _ = False + +edit :: Wing -> Ty -> Ty -> Either String (HoonPath, Ty) +edit w newTy ty = do + (path, oldTy) <- resolve w ty + + guard (all (isn't _Arm) path) + + result <- any (has _Ctx) path & \case + True -> ty <$ guard (nest newTy oldTy) + False -> pure (set (atPath path) newTy ty) + + pure (path, result) diff --git a/pkg/hs/hoon/src/LL/Gen.hs b/pkg/hs/hoon/src/LL/Gen.hs new file mode 100644 index 000000000..b539e8e3a --- /dev/null +++ b/pkg/hs/hoon/src/LL/Gen.hs @@ -0,0 +1,80 @@ +module LL.Gen where + +import ClassyPrelude hiding (union) +import Data.Bits (shift, finiteBitSize, countLeadingZeros) + +import IR.Ty (Sym, Nat) +import LL.Types +import Nock.Types + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Vector as Vector + +axis :: LLPath -> Atom +axis = go . reverse + where + go [] = 1 + go (L:ds) = 2 * go ds + go (R:ds) = 2 * go ds + 1 + go (Ctx:ds) = 2 * go ds + 1 + +log2 :: Int -> Int +log2 x = finiteBitSize x - 1 - countLeadingZeros x + +-- | The greatest power of two less than the argument +scale :: Int -> Int +scale x = shift (log2 x) 1 + +layoutPath :: Nat -> Nat -> LLPath +layoutPath 0 1 = [] +layoutPath _ 1 = error "axis-fell" +layoutPath idx sz = + let midpoint = sz `quot` 2 + in if idx <= midpoint + then L : layoutPath idx midpoint + else R : layoutPath (idx - midpoint) (sz - midpoint) + +-- | The axis of an arm, as laid out in a battery +coreAxis :: Sym -> (Map Sym t) -> Maybe Atom +coreAxis a bat = do + i <- Map.lookupIndex a bat + let batPath = layoutPath i (Map.size bat) + pure (axis (L : batPath)) + +layOut :: Vector Noun -> Noun +layOut ns + | null ns = Atom 0 + | length ns == 1 = Vector.head ns + | otherwise = Cell (layOut as) (layOut bs) + where (as, bs) = splitAt (length ns `quot` 2) ns + +battery :: (Map Sym a) -> (a -> Maybe Noun) -> Maybe Noun +battery bat conv = layOut <$> Vector.fromList <$> Map.elems <$> traverse conv bat + +generate :: LLTy -> Maybe Nock +generate = \case + LWith _ x (LFire _ s bat) -> do + ax <- coreAxis s bat + x' <- generate x + -- FIXME icky + pure (NNineInvoke ax x') + LWith _ x y -> NSevenThen <$> generate x <*> generate y + LAxis _ a -> pure (NZeroAxis (axis a)) + LEdit _ a r x -> do + r' <- generate r + x' <- generate x + pure (NTenEdit (axis a, r') x') + LFire _ s bat -> do + ax <- coreAxis s bat + -- FIXME icky + pure (NNineInvoke ax (NZeroAxis 1)) + LAtom _ n -> pure (NOneConst (Atom n)) + LPair _ x y -> NCons <$> generate x <*> generate y + LCore _ arms -> do + b <- battery arms (fmap nockToNoun . generate) + pure (NCons (NOneConst b) (NZeroAxis 1)) + LSucc _ x -> NFourSucc <$> generate x + LTest _ x y z -> NSixIf <$> generate x <*> generate y <*> generate z + LCelQ _ x -> NThreeIsCell <$> generate x + LEqlQ _ x y -> NFiveEq <$> generate x <*> generate y diff --git a/pkg/hs/hoon/src/LL/Run.hs b/pkg/hs/hoon/src/LL/Run.hs new file mode 100644 index 000000000..9a2d9b1a5 --- /dev/null +++ b/pkg/hs/hoon/src/LL/Run.hs @@ -0,0 +1,108 @@ +module LL.Run where + +import ClassyPrelude hiding (succ, union, intersect) +import Control.Lens +import Control.Lens.TH +import Control.Monad.Fix +import Data.Void +import IR.Ty (Ty, Nat, Sym, Hoon, HoonPath) +import LL.Types + +import Control.Category ((>>>)) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified IR.Wing as Wing +import qualified Prelude + + +-- Types ----------------------------------------------------------------------- + +type Battery a = Map Sym (LL a) + +data Val a + = VAtom !Nat + | VCell !(Val a) !(Val a) + | VCore !(Battery a) !(Val a) + deriving (Eq, Ord, Show) + + +-- Lenses ---------------------------------------------------------------------- + +makePrisms ''Val + +_VBool :: Prism' (Val a) Bool +_VBool = prism' mk get + where + mk True = VAtom 0 + mk False = VAtom 1 + + get (VAtom 1) = pure False + get (VAtom 0) = pure True + get _ = Nothing + + +-- Value Manipulation ---------------------------------------------------------- + +succ :: Val a -> Either String (Val a) +succ = fmap (review _VAtom . (+1)) . mbErr notAtom . preview _VAtom + where notAtom = "Can't increment non-atom value." + +isCell :: Val a -> Bool +isCell = \case + VAtom _ -> False + VCell _ _ -> True + VCore _ _ -> True -- bah + +get :: LLPath -> Val a -> Either String (Val a) +get = go + where + go [] val = pure val + go (L:ds) (VCell l _) = go ds l + go (R:ds) (VCell _ r) = go ds r + go (Ctx:ds) (VCore _ c) = go ds c + go _ _ = Left "Failed to lookup LLPath in value" + +edit :: LLPath -> Val a -> Val a -> Either String (Val a) +edit = go + where + go [] x v = pure x + go (L:ds) x (VCell l r) = VCell <$> edit ds l x <*> pure r + go (R:ds) x (VCell l r) = VCell <$> pure l <*> edit ds r x + go (Ctx:ds) x (VCore arms ctx) = VCore <$> pure arms <*> edit ds ctx x + go _ x _ = Left "LL.Run.edit: Bullshit edit" + + +-- Interpreter ----------------------------------------------------------------- + +mbErr :: String -> Maybe a -> Either String a +mbErr err = \case Nothing -> Left err + Just a -> pure a + +fire :: (Eq a, Show a) => Sym -> Val a -> Either String (Val a) +fire nm = \case + k@(VCore batt ctx) -> mbErr noArm (Map.lookup nm batt) >>= runLL k + _ -> Left "Attempting to fire arm in non-core value" + where + noArm = unpack ("LL.Run.fire: Can't find arm " <> nm) + +toBool :: Show a => Val a -> Either String Bool +toBool v = mbErr notBool (v ^? _VBool) + where + notBool = "Expected a bool, but got " <> show v + +runLL :: (Eq a, Show a) => Val a -> LL a -> Either String (Val a) +runLL sut = r + where + r = \case + LAxis _ p -> get p sut + LFire _ a bat -> fire a sut -- TODO do we test whether bat is correct? + LSucc _ h -> r h >>= succ + LPair _ x y -> VCell <$> r x <*> r y + LAtom _ n -> pure (VAtom n) + LEdit _ w x y -> join (edit w <$> r x <*> r y) + LWith _ x y -> r x >>= flip runLL y + LCore _ b -> pure (VCore b sut) + LTest _ v t f -> r v >>= toBool >>= bool (r t) (r f) + LCelQ _ v -> review _VBool . isCell <$> r v + LEqlQ _ x y -> review _VBool <$> ((==) <$> r x <*> r y) diff --git a/pkg/hs/hoon/src/LL/Types.hs b/pkg/hs/hoon/src/LL/Types.hs new file mode 100644 index 000000000..eae3b4a92 --- /dev/null +++ b/pkg/hs/hoon/src/LL/Types.hs @@ -0,0 +1,73 @@ +module LL.Types where + +import ClassyPrelude hiding (union, intersect) +import IR.Ty +import Control.Lens +import Control.Lens.TH +import Control.Monad.Fix +import Data.Void + +import Control.Category ((>>>)) +import Data.Function ((&)) +import Data.Maybe (fromJust) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Prelude + + +-- Low-Level Representation ---------------------------------------------------- + +data LLDir = L | R | Ctx + deriving (Eq, Ord, Show) + +type LLPath = [LLDir] + +data LL t + = LWith t (LL t) (LL t) + | LAxis t LLPath + | LEdit t LLPath (LL t) (LL t) + | LFire t Sym (Map Sym t) + | LAtom t Nat + | LPair t (LL t) (LL t) + | LCore t (Map Sym (LL t)) + | LSucc t (LL t) + | LTest t (LL t) (LL t) (LL t) + | LCelQ t (LL t) + | LEqlQ t (LL t) (LL t) + deriving (Eq, Ord, Show, Functor) + +type LLTy = LL Ty + +llYes, llNo :: LLTy +llYes = LAtom tyBool 0 +llNo = LAtom tyBool 1 + +llTy :: Lens (LL a) (LL a) a a +llTy = lens get set + where + get = \case + LWith t _ _ -> t + LAxis t _ -> t + LEdit t _ _ _ -> t + LFire t _ _ -> t + LAtom t _ -> t + LPair t _ _ -> t + LCore t _ -> t + LSucc t _ -> t + LTest t _ _ _ -> t + LCelQ t _ -> t + LEqlQ t _ _ -> t + + set ty t = ty & \case + LWith _ x y -> LWith t x y + LAxis _ x -> LAxis t x + LEdit _ x y z -> LEdit t x y z + LFire _ x bat -> LFire t x bat + LAtom _ x -> LAtom t x + LPair _ x y -> LPair t x y + LCore _ x -> LCore t x + LSucc _ x -> LSucc t x + LTest _ x y z -> LTest t x y z + LCelQ _ x -> LCelQ t x + LEqlQ _ x y -> LEqlQ t x y diff --git a/pkg/hs/hoon/src/Nock/Types.hs b/pkg/hs/hoon/src/Nock/Types.hs new file mode 100644 index 000000000..e38afec09 --- /dev/null +++ b/pkg/hs/hoon/src/Nock/Types.hs @@ -0,0 +1,58 @@ +module Nock.Types where + +import ClassyPrelude + +type Atom = Int + +data Noun = Atom !Atom + | Cell !Noun !Noun + deriving (Eq, Ord, Read, Show) + +yes, no :: Noun +yes = Atom 0 +no = Atom 1 + +-- | Tree address +type Axis = Atom + +data Nock = NCons Nock Nock -- ^ autocons + | NZeroAxis Axis -- ^ 0: tree addressing + | NOneConst Noun + | NTwoCompose Nock Nock + | NThreeIsCell Nock + | NFourSucc Nock + | NFiveEq Nock Nock + | NSixIf Nock Nock Nock + | NSevenThen Nock Nock + | NEightPush Nock Nock + | NNineInvoke Axis Nock + | NTenEdit (Axis, Nock) Nock + | NElevenHint Hint Nock + | NTwelveScry Nock Nock + deriving (Eq, Ord, Read, Show) + +data Hint = Tag Atom + | Assoc Atom Nock + deriving (Eq, Ord, Read, Show) + +nockToNoun :: Nock -> Noun +nockToNoun = go + where + go (NCons n m) = (Cell (go n) (go m)) + go (NZeroAxis a) = (Cell (Atom 0) (Atom a)) + go (NOneConst c) = (Cell (Atom 1) c) + go (NTwoCompose n m) = (Cell (Atom 2) (Cell (go n) (go m))) + go (NThreeIsCell n) = (Cell (Atom 3) (go n)) + go (NFourSucc n) = (Cell (Atom 4) (go n)) + go (NFiveEq n m) = (Cell (Atom 5) (Cell (go n) (go m))) + go (NSixIf n m o) = (Cell (Atom 6) (Cell (go n) (Cell (go m) (go o)))) + go (NSevenThen n m) = (Cell (Atom 7) (Cell (go n) (go m))) + go (NEightPush n m) = (Cell (Atom 8) (Cell (go n) (go m))) + go (NNineInvoke a n) = (Cell (Atom 9) (Cell (Atom a) (go n))) + go (NTenEdit (a, n) m) = (Cell (Atom 10) (Cell (Cell (Atom a) (go n)) (go m))) + go (NElevenHint h n) = (Cell (Atom 11) (Cell (ho h) (go n))) + go (NTwelveScry n m) = (Cell (Atom 12) (Cell (go n) (go m))) + + ho (Tag x) = (Atom x) + ho (Assoc x n) = (Cell (Atom x) (go n)) + diff --git a/pkg/hs/hoon/src/SpecToBunt.hs b/pkg/hs/hoon/src/SpecToBunt.hs new file mode 100644 index 000000000..4177166a8 --- /dev/null +++ b/pkg/hs/hoon/src/SpecToBunt.hs @@ -0,0 +1,7 @@ +module SpecToBunt (specToBunt) where + +import Prelude +import Types + +specToBunt :: Bool -> Spec -> Hoon +specToBunt = undefined diff --git a/pkg/hs/hoon/src/SpecToMold.hs b/pkg/hs/hoon/src/SpecToMold.hs new file mode 100644 index 000000000..dcb50eb10 --- /dev/null +++ b/pkg/hs/hoon/src/SpecToMold.hs @@ -0,0 +1,9 @@ +module SpecToMold (specToMold) where + +import Prelude +import Types + +-- | factory:ax. Given a spec and a boolean (?) produces a normalizing gate. +specToMold :: Bool -> Spec -> Hoon +specToMold fab spec = error "TODO specToMold" + diff --git a/pkg/hs/hoon/src/Types.hs b/pkg/hs/hoon/src/Types.hs new file mode 100644 index 000000000..4631f0d3b --- /dev/null +++ b/pkg/hs/hoon/src/Types.hs @@ -0,0 +1,282 @@ +module Types where + +import Prelude + +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List.NonEmpty (NonEmpty) + +import Nock.Types + +hoonVersion :: Atom +hoonVersion = 141 + +type Name = String -- "term" +type Aura = Name +type Tape = String +type AtomUD = Atom + +nameToAtom = error "TODO nameToAtom" + +data Type = Void + | Noun + | Atomic Name (Maybe Atom) + | Cell Type Type + | Core Type -- TODO + | Face Name Type -- TODO name or "tune" + | Fork (Set Type) + -- TODO %hint + | Hold Type Hoon + +data Polarity = Wet | Dry + deriving (Eq, Ord, Read, Show) + +data Variance = Invariant -- "gold" + | Contravariant -- "iron" + | Bivariant -- "lead" + | Covariant -- "zinc" + deriving (Eq, Ord, Read, Show) + +type Claims = Map Name Spec + +data Base + = SVoid -- Empty Set + | SNull -- ~ + | SFlag -- Bool + | SNoun -- * + | SCell -- ^ + | SAtom Aura + +data Spec + = SBase Base + | SDebug Spot Spec + | SLeaf Name Atom + | Like (NonEmpty Wing) + | Loop Name + | Made (NonEmpty Name) Spec + | Make Hoon [Spec] + | Name Name Spec + | Over Wing Spec + -- + | BucGar Spec Spec -- ^ $> filter: require + | BucBuc Spec Claims -- ^ $$ recursion + | BucBar Spec Hoon -- ^ $$ recursion + | BucCab Hoon -- $_ + | BucCol (NonEmpty Spec) -- $: + | BucCen (NonEmpty Spec) -- $%, head pick + | BucDot Spec Claims -- $., read-write core + | BucLed Spec Spec -- $<, filter: exclude + | BucHep Spec Spec -- $-, function core + | BucKet Spec Spec -- $^, cons pick + | BucLus Stud Spec -- $+, standard + | BucFas Spec Claims -- $/, write-only core + | BucMic Hoon -- $;, manual + | BucPad Spec Hoon -- $&, repair + | BucSig Hoon Spec -- $~, default + | BucTic Spec Claims -- $`, read-only core + | BucTis Skin Spec -- $=, name + | BucPat Spec Spec -- $@, atom pick + | BucWut (NonEmpty Spec) -- $?, full pick + | BucZap Spec Claims -- $!, opaque core + +type Bindings hoon = Map Name (Map Name (BindingHelp, hoon)) +data BindingHelp -- "what" +data Tome + +data Hoon + = HAutocons [Hoon] + | H_ Axis -- shorthand which should have been a function + | HBase Base -- base type mold + | Bust Base -- base type bunt + | HDebug Spot Hoon + | Error Tape + | Hand Type Nock + | Note Note Hoon + | Fits Hoon Wing + | Knit [Woof] + | HLeaf Name Atom + | Limb Name + | Lost Hoon + | Rock Name Noun + | Sand Name Noun + | Tell (NonEmpty Hoon) + | Tune (Either Name Tune) + | Wing Wing + | Yell (NonEmpty Hoon) + | Xray ManxHoot + -- Cores + | BarCab Spec Alas (Bindings Hoon) + | BarCol Hoon Hoon + | BarCen (Maybe Name) (Bindings Hoon) + | BarDot Hoon + | BarKet Hoon (Bindings Hoon) + | BarHep Hoon + | BarSig Spec Hoon + | BarTar Spec Hoon + | BarTis Spec Hoon + | BarPat (Maybe Name) (Bindings Hoon) + | BarWut Hoon + -- Tuples + | ColCab Hoon Hoon + | ColKet Hoon Hoon Hoon Hoon + | ColHep Hoon Hoon + | ColLus Hoon Hoon Hoon + | ColSig [Hoon] + | ColTar (NonEmpty Hoon) -- was ordinary list + -- Invocations + | CenCab Wing [(Wing, Hoon)] + | CenDot Hoon Hoon + | CenHep Hoon Hoon + | CenCol Hoon [Hoon] + | CenTar Wing Hoon [(Wing, Hoon)] + | CenKet Hoon Hoon Hoon Hoon + | CenLus Hoon Hoon Hoon + | CenSig Wing Hoon [Hoon] + | CenTis Wing [(Wing, Hoon)] + -- Nock + | DotKet Spec Hoon + | DotLus Hoon + | DotTar Hoon Hoon + | DotTis Hoon Hoon + | DotWut Hoon + -- Type conversions + | KetBar Hoon + | KetCen Hoon + | KetDot Hoon Hoon + | KetLus Hoon Hoon + | KetHep Spec Hoon + | KetPam Hoon + | KetSig Hoon + | KetTis Skin Hoon + | KetWut Hoon + | KetTar Spec + | KetCol Spec + -- Hints + | SigBar Hoon Hoon + | SigCab Hoon Hoon + | SigCen Chum Hoon Tyre Hoon + | SigFas Chum Hoon + | SigLed Name (Maybe Hoon) Hoon + | SigGar Name (Maybe Hoon) Hoon + | SigBuc Name Hoon + | SigLus Atom Hoon + | SigPam AtomUD Hoon Hoon + | SigTis Hoon Hoon + | SigWut AtomUD Hoon Hoon Hoon + | SigZap Hoon Hoon + -- Miscellaneous + | MicTis MarlHoot + | MicCol Hoon [Hoon] + | MicNet Hoon + | MicSig Hoon [Hoon] + | MicMic Hoon Hoon + -- Compositions + | TisBar Spec Hoon + | TisCol [(Wing, Hoon)] Hoon + | TisFas Skin Hoon Hoon + | TisMic Skin Hoon Hoon + | TisDot Wing Hoon Hoon + | TisWut Wing Hoon Hoon Hoon + | TisLed Hoon Hoon + | TisHep Hoon Hoon + | TisGar Hoon Hoon + | TisKet Skin Wing Hoon Hoon + | TisLus Hoon Hoon + | TisSig [Hoon] + | TisTar Name (Maybe Spec) Hoon Hoon + | TisCom Hoon Hoon + -- Conditionals + | WutBar [Hoon] + | WutHep Wing [(Spec,Hoon)] + | WutCol Hoon Hoon Hoon + | WutDot Hoon Hoon Hoon + | WutKet Wing Hoon Hoon + | WutLed Hoon Hoon + | WutGar Hoon Hoon + | WutLus Wing Hoon [(Spec, Hoon)] + | WutPam [Hoon] + | WutPat Wing Hoon Hoon + | WutSig Wing Hoon Hoon + | WutHax Skin Wing + | WutTis Spec Wing + | WutZap Hoon + -- Special + | ZapCom Hoon Hoon + | ZapGar Hoon + | ZapMic Hoon Hoon + | ZapTis Hoon + | ZapPat [Wing] Hoon Hoon + | ZapWut (Either Atom (Atom, Atom)) Hoon + | ZapZap + +type Wing = [Limb] +data Limb + = NameLimb Name + | AxisLimb Axis -- ^ %& tag + | ByNameLimb Atom (Maybe Name) -- ^ ??? %| tag + +data Tune + = Tone + { aliases :: (Map Name (Maybe Hoon)) + , bridges :: [Hoon] + } + +-- TODO +data Alas +data Spot +data Woof +data ManxHoot +data MarlHoot +data Note +data Chum +data Tyre +data Stud +data Skin + +-- | Basic hoon: totally desugared +data BHoon + = BAutocons [BHoon] + | BDebug Spot BHoon + | BHand Type Nock + | BNote Note BHoon + | BFits BHoon Wing + | BSand Name Noun + | BRock Name Noun + | BTune (Either Name Tune) + | BLost BHoon + -- + | BBarCen (Maybe Name) (Bindings BHoon) + | BBarPat (Maybe Name) (Bindings BHoon) + -- + | BCenTis Wing [(Wing, BHoon)] + -- + | BDotKet Spec BHoon + | BDotLus BHoon + | BDotTar BHoon BHoon + | BDotTis BHoon BHoon + | BDotWut BHoon + -- + | BKetBar BHoon + | BKetCen BHoon + | BKetLus BHoon BHoon + | BKetPam BHoon + | BKetSig BHoon + | BKetWut BHoon + -- + | BSigGar Name (Maybe BHoon) BHoon + | BSigZap BHoon BHoon + -- + | BTisGar BHoon BHoon + | BTisCom BHoon BHoon + -- + | BWutCol BHoon BHoon BHoon + | BWutHax Skin Wing + -- + | BZapCom BHoon BHoon + | BZapMic BHoon BHoon + | BZapTis BHoon + | BZapPat [Wing] BHoon BHoon + | BZapZap + diff --git a/pkg/hs/stack.yaml b/pkg/hs/stack.yaml new file mode 100644 index 000000000..aba6774ff --- /dev/null +++ b/pkg/hs/stack.yaml @@ -0,0 +1,8 @@ +resolver: lts-13.10 + +packages: + - hoon + - uterm + +extra-deps: + - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 diff --git a/pkg/hs/uterm/.gitignore b/pkg/hs/uterm/.gitignore new file mode 100644 index 000000000..ed7701026 --- /dev/null +++ b/pkg/hs/uterm/.gitignore @@ -0,0 +1 @@ +uterm.cabal diff --git a/pkg/uterm/Main.hs b/pkg/hs/uterm/Main.hs similarity index 100% rename from pkg/uterm/Main.hs rename to pkg/hs/uterm/Main.hs diff --git a/pkg/hs/uterm/package.yaml b/pkg/hs/uterm/package.yaml new file mode 100644 index 000000000..86f09d1da --- /dev/null +++ b/pkg/hs/uterm/package.yaml @@ -0,0 +1,25 @@ +name: "uterm" +version: 0.1.0 +license: AGPL-3.0-only + +default-extensions: + - OverloadedStrings + - TypeApplications + - UnicodeSyntax + - FlexibleContexts + - TemplateHaskell + - QuasiQuotes + - LambdaCase + - NoImplicitPrelude + - ScopedTypeVariables + - DeriveAnyClass + - DeriveGeneric + +dependencies: + - base + - classy-prelude + - lens + +executables: + pomo: + main: "Main.hs" diff --git a/pkg/uterm/package.dhall b/pkg/uterm/package.dhall deleted file mode 100644 index 898a389c5..000000000 --- a/pkg/uterm/package.dhall +++ /dev/null @@ -1,27 +0,0 @@ -{ name = - "uterm" -, version = - "0.1.0" -, license = - "AGPL-3.0-only" -, default-extensions = - [ "OverloadedStrings" - , "TypeApplications" - , "UnicodeSyntax" - , "FlexibleContexts" - , "TemplateHaskell" - , "QuasiQuotes" - , "LambdaCase" - , "NoImplicitPrelude" - , "ScopedTypeVariables" - , "DeriveAnyClass" - , "DeriveGeneric" - ] -, dependencies = - [ "base" - , "classy-prelude" - , "lens" - ] -, executables = - { pomo = { main = "Main.hs" } } -} diff --git a/pkg/uterm/shell.nix b/pkg/uterm/shell.nix deleted file mode 100644 index 71550a487..000000000 --- a/pkg/uterm/shell.nix +++ /dev/null @@ -1 +0,0 @@ -import ../../nix/pkgs/uterm/default.nix From 87dbcef866e69e0e9103e6249b6ca0f8b53c1e3b Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 29 Apr 2019 16:15:25 -0700 Subject: [PATCH 003/431] Minor cleanup. --- pkg/hs/.gitignore | 1 + pkg/hs/hoon/.gitignore | 13 ------------- pkg/hs/hoon/package.yaml | 4 ++-- pkg/hs/uterm/.gitignore | 1 - pkg/hs/uterm/package.yaml | 1 + 5 files changed, 4 insertions(+), 16 deletions(-) delete mode 100644 pkg/hs/hoon/.gitignore delete mode 100644 pkg/hs/uterm/.gitignore diff --git a/pkg/hs/.gitignore b/pkg/hs/.gitignore index 8ee1bf948..c99ca9e13 100644 --- a/pkg/hs/.gitignore +++ b/pkg/hs/.gitignore @@ -1 +1,2 @@ .stack-work +*.cabal diff --git a/pkg/hs/hoon/.gitignore b/pkg/hs/hoon/.gitignore deleted file mode 100644 index f476396fc..000000000 --- a/pkg/hs/hoon/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -.stack-work/ -hoon-hs.cabal -*~ -*. - -# Swap -[._]*.s[a-v][a-z] -[._]*.sw[a-p] -[._]s[a-rt-v][a-z] -[._]ss[a-gi-z] -[._]sw[a-p] - -.DS_Store diff --git a/pkg/hs/hoon/package.yaml b/pkg/hs/hoon/package.yaml index cdf636f1c..3a308cf0a 100644 --- a/pkg/hs/hoon/package.yaml +++ b/pkg/hs/hoon/package.yaml @@ -1,6 +1,6 @@ -name: hoon-hs +name: language-hoon version: 0.1.0.0 -github: "urbit/hoon-hs" +github: "urbit/urbit" license: BSD3 library: diff --git a/pkg/hs/uterm/.gitignore b/pkg/hs/uterm/.gitignore deleted file mode 100644 index ed7701026..000000000 --- a/pkg/hs/uterm/.gitignore +++ /dev/null @@ -1 +0,0 @@ -uterm.cabal diff --git a/pkg/hs/uterm/package.yaml b/pkg/hs/uterm/package.yaml index 86f09d1da..281073988 100644 --- a/pkg/hs/uterm/package.yaml +++ b/pkg/hs/uterm/package.yaml @@ -19,6 +19,7 @@ dependencies: - base - classy-prelude - lens + - language-hoon executables: pomo: From 0cf4b2f3e3f4da384e48a2bcc00b8cea36dc8e6b Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 1 May 2019 18:11:45 -0700 Subject: [PATCH 004/431] Makefile cleanup. --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index ccea8879b..2a68691a2 100644 --- a/Makefile +++ b/Makefile @@ -22,5 +22,5 @@ test: sh/test clean: - rm -rf ./out ./work + rm -rf ./cross ./release rm -f result result-* From 25713052c06ad99bf92baf42ac32952bbbe4a6ca Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 1 May 2019 19:19:19 -0700 Subject: [PATCH 005/431] Messing around. --- pkg/hs/stack.yaml | 1 + pkg/hs/vere/Main.hs | 65 ++++++++++++++++++++++++++++++++++++++++ pkg/hs/vere/package.yaml | 27 +++++++++++++++++ 3 files changed, 93 insertions(+) create mode 100644 pkg/hs/vere/Main.hs create mode 100644 pkg/hs/vere/package.yaml diff --git a/pkg/hs/stack.yaml b/pkg/hs/stack.yaml index aba6774ff..c7595d138 100644 --- a/pkg/hs/stack.yaml +++ b/pkg/hs/stack.yaml @@ -3,6 +3,7 @@ resolver: lts-13.10 packages: - hoon - uterm + - vere extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 diff --git a/pkg/hs/vere/Main.hs b/pkg/hs/vere/Main.hs new file mode 100644 index 000000000..96a6d9ffc --- /dev/null +++ b/pkg/hs/vere/Main.hs @@ -0,0 +1,65 @@ +module Main where + +import ClassyPrelude hiding (atomically, newTVarIO) +import Control.Lens +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TBMQueue + +-------------------------------------------------------------------------------- + +newtype Cpu st ev fx = Cpu { runCpu :: st -> ev -> (st, fx) } + +data CpuApi ev st fx = CpuApi + { caHalt :: IO () + , caInput :: TBMQueue ev + , caOutput :: TBMQueue (st, fx) + } + +-------------------------------------------------------------------------------- + +dummyCpu :: Cpu () () () +dummyCpu = Cpu $ (\() () -> ((), ())) + +runCpuIO :: Cpu st ev fx + -> TVar st + -> TBMQueue ev + -> TBMQueue (st, fx) + -> IO () +runCpuIO cpu vSt inp out = + forever $ atomically $ do + ev <- readTBMQueue inp >>= maybe (error "No more input") pure + st <- readTVar vSt + runCpu cpu st ev & \(st', fx) -> do + writeTVar vSt st' + writeTBMQueue out (st', fx) + +runCpuThread :: Cpu st ev fx + -> st + -> IO (CpuApi ev st fx) +runCpuThread cpu init = do + inp <- newTBMQueueIO 1 + out <- newTBMQueueIO 16 + vSt <- newTVarIO init + tid <- forkIO (runCpuIO cpu vSt inp out) + + let kill = do atomically (closeTBMQueue inp >> closeTBMQueue out) + killThread tid + + pure (CpuApi kill inp out) + +-------------------------------------------------------------------------------- + +{- + - When an event comes in: + - process the event + - persist the event + - run the effects + + - Take a snapshot at any time. +-} + +main :: IO () +main = do + cpuProc <- runCpuThread dummyCpu () + caHalt cpuProc diff --git a/pkg/hs/vere/package.yaml b/pkg/hs/vere/package.yaml new file mode 100644 index 000000000..ea9f86ab7 --- /dev/null +++ b/pkg/hs/vere/package.yaml @@ -0,0 +1,27 @@ +name: vere +version: 0.1.0 +license: AGPL-3.0-only + +default-extensions: + - OverloadedStrings + - TypeApplications + - UnicodeSyntax + - FlexibleContexts + - TemplateHaskell + - QuasiQuotes + - LambdaCase + - NoImplicitPrelude + - ScopedTypeVariables + - DeriveAnyClass + - DeriveGeneric + +dependencies: + - base + - classy-prelude + - stm + - stm-chans + - lens + +executables: + vere: + main: Main.hs From 4b38053509ddeac4c6b75240cd83ce21f504a8a6 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 5 May 2019 14:46:40 -0700 Subject: [PATCH 006/431] Behn --- pkg/hs/vere/Vere/Behn.hs | 109 + pkg/hs/vere/notes/BehnSketch.hs.txt | 184 ++ pkg/hs/vere/{Main.hs => notes/Sketch.hs.txt} | 0 pkg/hs/vere/notes/c/ames.c | 563 ++++ pkg/hs/vere/notes/c/behn.c | 90 + pkg/hs/vere/notes/c/cttp.c | 989 ++++++ pkg/hs/vere/notes/c/daemon.c | 735 +++++ pkg/hs/vere/notes/c/dawn.c | 525 ++++ pkg/hs/vere/notes/c/foil.c | 170 + pkg/hs/vere/notes/c/hash_tests.c | 105 + pkg/hs/vere/notes/c/hashtable_tests.c | 144 + pkg/hs/vere/notes/c/http.c | 2908 ++++++++++++++++++ pkg/hs/vere/notes/c/lmdb.c | 670 ++++ pkg/hs/vere/notes/c/newt.c | 359 +++ pkg/hs/vere/notes/c/pier.c | 2143 +++++++++++++ pkg/hs/vere/notes/c/reck.c | 482 +++ pkg/hs/vere/notes/c/save.c | 66 + pkg/hs/vere/notes/c/term.c | 1342 ++++++++ pkg/hs/vere/notes/c/time.c | 179 ++ pkg/hs/vere/notes/c/unix.c | 1333 ++++++++ pkg/hs/vere/notes/c/walk.c | 334 ++ pkg/hs/vere/notes/c/worker.c | 947 ++++++ pkg/hs/vere/package.yaml | 8 +- 23 files changed, 14382 insertions(+), 3 deletions(-) create mode 100644 pkg/hs/vere/Vere/Behn.hs create mode 100644 pkg/hs/vere/notes/BehnSketch.hs.txt rename pkg/hs/vere/{Main.hs => notes/Sketch.hs.txt} (100%) create mode 100644 pkg/hs/vere/notes/c/ames.c create mode 100644 pkg/hs/vere/notes/c/behn.c create mode 100644 pkg/hs/vere/notes/c/cttp.c create mode 100644 pkg/hs/vere/notes/c/daemon.c create mode 100644 pkg/hs/vere/notes/c/dawn.c create mode 100644 pkg/hs/vere/notes/c/foil.c create mode 100644 pkg/hs/vere/notes/c/hash_tests.c create mode 100644 pkg/hs/vere/notes/c/hashtable_tests.c create mode 100644 pkg/hs/vere/notes/c/http.c create mode 100644 pkg/hs/vere/notes/c/lmdb.c create mode 100644 pkg/hs/vere/notes/c/newt.c create mode 100644 pkg/hs/vere/notes/c/pier.c create mode 100644 pkg/hs/vere/notes/c/reck.c create mode 100644 pkg/hs/vere/notes/c/save.c create mode 100644 pkg/hs/vere/notes/c/term.c create mode 100644 pkg/hs/vere/notes/c/time.c create mode 100644 pkg/hs/vere/notes/c/unix.c create mode 100644 pkg/hs/vere/notes/c/walk.c create mode 100644 pkg/hs/vere/notes/c/worker.c diff --git a/pkg/hs/vere/Vere/Behn.hs b/pkg/hs/vere/Vere/Behn.hs new file mode 100644 index 000000000..f53bd370b --- /dev/null +++ b/pkg/hs/vere/Vere/Behn.hs @@ -0,0 +1,109 @@ +{- + # Behn + + This provides a timer. To use this, + + - Create a new timer with `init`. + - Use `doze` to start the timer. + - Call `wait` to wait until the timer fires. + + Then, `wait` will return when the specified time has come. + + - If the specified time was in the past, `wait` will return immediately. + - If a timer is set again, the old timer will not fire. The new time + replaces the old one. + - If a timer is unset (with `doze _ Nothing`), the timer will not fire + until a new time has been set. + + ## Implementation Notes + + We use `tryPutMVar` when the timer fires, so that things will continue + to work correctly if the user does not call `wait`. If a timer fires + before `wait` is called, `wait` will return immediatly. + + To handle race conditions, the MVar in `bState` is used as a lock. The + code for setting a timer and the thread that runs when the timer fires + (which causes `wait` to return) both take that MVar before acting. + + So, if the timer fires conncurently with a call to `doze`, + then one of those threads will get the lock and the other will wait: + + - If the `doze` call gets the lock first, it will kill the timer thread + before releasing it. + - If the timer gets the the lock first, it will fire (causeing `wait` + to return) first, and then `doze` action will wait until that finishes. +-} + +module Vere.Behn (Behn, init, wait, doze) where + +import Control.Concurrent +import Control.Concurrent.Async hiding (wait) +import Control.Concurrent.MVar +import Data.LargeWord +import Prelude hiding (init) + +import Data.Time.Clock.System (SystemTime(..), getSystemTime) +import Control.Lens ((&)) +import Control.Monad (void) + + +-- Time Stuff ------------------------------------------------------------------ + +type UrbitTime = Word128 + +urNow :: IO UrbitTime +urNow = systemTimeToUrbitTime <$> getSystemTime + +{- + TODO This is wrong. + + - The high word should be `(0x8000000cce9e0d80ULL + secs)` + - The low word should be `(((usecs * 65536ULL) / 1000000ULL) << 48ULL)` +-} +systemTimeToUrbitTime :: SystemTime -> UrbitTime +systemTimeToUrbitTime (MkSystemTime secs ns) = + LargeKey (fromIntegral secs) (fromIntegral ns) + +-- TODO +urbitTimeToMicrosecs :: UrbitTime -> Int +urbitTimeToMicrosecs x = fromIntegral x + +-- TODO Double Check this +diffTime :: UrbitTime -> UrbitTime -> UrbitTime +diffTime fst snd | fst >= snd = 0 + | otherwise = snd - fst + +-- Behn Stuff ------------------------------------------------------------------ + +data Behn = Behn + { bState :: MVar (Maybe (UrbitTime, Async ())) + , bSignal :: MVar UrbitTime + } + +init :: IO Behn +init = do + st <- newMVar Nothing + sig <- newEmptyMVar + pure (Behn st sig) + +wait :: Behn -> IO UrbitTime +wait (Behn _ sig) = takeMVar sig + +startTimerThread :: Behn -> UrbitTime -> IO (Async ()) +startTimerThread (Behn vSt sig) time = + async $ do + now <- urNow + threadDelay (urbitTimeToMicrosecs (now `diffTime` time)) + void (swapMVar vSt Nothing >> tryPutMVar sig time) + +doze :: Behn -> Maybe UrbitTime -> IO () +doze behn@(Behn vSt sig) mNewTime = do + takeMVar vSt >>= \case Nothing -> pure () + Just (_,timer) -> cancel timer + + newSt <- mNewTime & \case + Nothing -> pure (Nothing :: Maybe (UrbitTime, Async ())) + Just time -> do timer <- startTimerThread behn time + pure (Just (time, timer)) + + void (putMVar vSt newSt) diff --git a/pkg/hs/vere/notes/BehnSketch.hs.txt b/pkg/hs/vere/notes/BehnSketch.hs.txt new file mode 100644 index 000000000..1fb89ccfc --- /dev/null +++ b/pkg/hs/vere/notes/BehnSketch.hs.txt @@ -0,0 +1,184 @@ +{- + TODO When is `u3_behn_io_init` called? +-} + +data Pier +data Timer + +data Wen = Wen Noun Noun Noun + +data TimeVal = TimeVal + { tv_sec :: time_t -- seconds + , tv_usec :: suseconds_t -- microseconds + } + +data Event + = Wake + | Born + +data Wire + = Blip -- Empty path + | Behn + | Sen Text -- "an instance string" + +newtype Knot = Knot Text + +newtype Wire = Wire [Knot] + +data Duct = [Wire] + +data Blip = Blip Behn (Maybe Void) + + +{- + alm -- is timer active? + tim -- timer + data -- associated pier +-} +data Behn = Behn + { _alm :: TVar Bool + , _tim :: TVar Timer + , _data :: TVar Pier + } + +makeLenses ''Behn + +-------------------------------------------------------------------------------- + +newTimer :: IO Timer +newTimer = undefined + +init :: Pier -> IO () +init p = + timer <- newTimer + atomically $ do + writeTVar (p ^. teh.alm) False + writeTVar (p ^. teh.tim) timer + writeTVar (p ^. teh.data) p + +exit :: Pier -> IO () +exit _ = pure () + +doze :: Pier -> Maybe Wen -> IO () +doze pir mWen = do + (active, timer) <- do + (,) <$> readTVarIO (pir ^. teh.alm) + <*> readTVarIO (pir ^. teh.tim) + + if active + then stopTimer timer -- TODO Race condition + else pure () + + case mWen of + Nothing -> pure () + Just (Wen x y z) -> do + timeVal <- getTimeOfDay + let now = u3_time_in_tv timeVal + let gap = u3_time_gap_ms(y, z) + writeTVar (p ^. teh.alm) True + startTimer timer gap $ do + u3_pier *pir_u = tim_u->data; + u3_behn* teh_u = pir_u->teh_u; + writeTVar (p ^. teh.alm) False; + pierWork pir [Blip Behn] Wake + +bake :: Pier -> IO () +bake = do + sen <- readTVarIO (u3A ^. sen) + pierWork pir [Blip Behn (Sen sen)] Born + +/* u3_behn_ef_bake(): notify %behn that we're live +*/ +void +u3_behn_ef_bake(u3_pier *pir_u) +{ + u3_noun pax = u3nq(u3_blip, c3__behn, u3k(u3A->sen), u3_nul); + + u3_pier_work(pir_u, pax, u3nc(c3__born, u3_nul)); +} + + +{- + u3_time_in_tv timeVal + u3_time_gap_ms(y, z) + u3nt(u3_blip, c3__behn, u3_nul), + u3nc(c3__wake, u3_nul)); +-} + + +-------------------------------------------------------------------------------- + +/* u3_behn(): initialize time timer. +*/ +void +u3_behn_io_init(u3_pier *pir_u) +{ + u3_behn* teh_u = pir_u->teh_u; + teh_u->alm = c3n; + + uv_timer_init(u3L, &teh_u->tim_u); + teh_u->tim_u.data = pir_u; +} + +/* u3_behn_io_exit(): terminate timer. +*/ +void +u3_behn_io_exit(u3_pier *pir_u) +{ +} + +/* _behn_time_cb(): timer callback. +*/ +static void +_behn_time_cb(uv_timer_t* tim_u) +{ + u3_pier *pir_u = tim_u->data; + u3_behn* teh_u = pir_u->teh_u; + teh_u->alm = c3n; + + { + u3_pier_work + (pir_u, + u3nt(u3_blip, c3__behn, u3_nul), + u3nc(c3__wake, u3_nul)); + } +} + +/* u3_behn_ef_doze(): set or cancel timer +*/ +void +u3_behn_ef_doze(u3_pier *pir_u, u3_noun wen) +{ + u3_behn* teh_u = pir_u->teh_u; + + if ( c3y == teh_u->alm ) { + uv_timer_stop(&teh_u->tim_u); + teh_u->alm = c3n; + } + + if ( (u3_nul != wen) && + (c3y == u3du(wen)) && + (c3y == u3ud(u3t(wen))) ) + { + struct timeval tim_tv; + gettimeofday(&tim_tv, 0); + + u3_noun now = u3_time_in_tv(&tim_tv); + c3_d gap_d = u3_time_gap_ms(now, u3k(u3t(wen))); + + teh_u->alm = c3y; + uv_timer_start(&teh_u->tim_u, _behn_time_cb, gap_d, 0); + } + + u3z(wen); +} + +/* u3_behn_ef_bake(): notify %behn that we're live +*/ +void +u3_behn_ef_bake(u3_pier *pir_u) +{ + u3_noun pax = u3nq(u3_blip, c3__behn, u3k(u3A->sen), u3_nul); + + u3_pier_work(pir_u, pax, u3nc(c3__born, u3_nul)); +} diff --git a/pkg/hs/vere/Main.hs b/pkg/hs/vere/notes/Sketch.hs.txt similarity index 100% rename from pkg/hs/vere/Main.hs rename to pkg/hs/vere/notes/Sketch.hs.txt diff --git a/pkg/hs/vere/notes/c/ames.c b/pkg/hs/vere/notes/c/ames.c new file mode 100644 index 000000000..a7c2540be --- /dev/null +++ b/pkg/hs/vere/notes/c/ames.c @@ -0,0 +1,563 @@ +/* vere/ames.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +/* _ames_alloc(): libuv buffer allocator. +*/ +static void +_ames_alloc(uv_handle_t* had_u, + size_t len_i, + uv_buf_t* buf + ) +{ + // we allocate 2K, which gives us plenty of space + // for a single ames packet (max size 1060 bytes) + // + void* ptr_v = c3_malloc(2048); + *buf = uv_buf_init(ptr_v, 2048); +} + +/* _ames_free(): contrasting free. +*/ +static void +_ames_free(void* ptr_v) +{ +// u3l_log("free %p\n", ptr_v); + free(ptr_v); +} + +/* _ames_pact_free(): free packet struct. +*/ +static void +_ames_pact_free(u3_pact* pac_u) +{ + free(pac_u->hun_y); + free(pac_u->dns_c); + free(pac_u); +} + +/* _ames_send_cb(): send callback. +*/ +static void +_ames_send_cb(uv_udp_send_t* req_u, c3_i sas_i) +{ + u3_pact* pac_u = (u3_pact*)req_u; + +#if 0 + if ( 0 != sas_i ) { + u3l_log("ames: send_cb: %s\n", uv_strerror(sas_i)); + } +#endif + + _ames_pact_free(pac_u); +} + +/* _ames_send(): send buffer to address on port. +*/ +static void +_ames_send(u3_pact* pac_u) +{ + // XX revisit + u3_pier* pir_u = u3_pier_stub(); + u3_ames* sam_u = pir_u->sam_u; + + if ( !pac_u->hun_y ) { + _ames_pact_free(pac_u); + return; + } + + struct sockaddr_in add_u; + + memset(&add_u, 0, sizeof(add_u)); + add_u.sin_family = AF_INET; + add_u.sin_addr.s_addr = htonl(pac_u->pip_w); + add_u.sin_port = htons(pac_u->por_s); + + uv_buf_t buf_u = uv_buf_init((c3_c*)pac_u->hun_y, pac_u->len_w); + + c3_i sas_i; + + if ( 0 != (sas_i = uv_udp_send(&pac_u->snd_u, + &sam_u->wax_u, + &buf_u, 1, + (const struct sockaddr*)&add_u, + _ames_send_cb)) ) { + u3l_log("ames: send: %s\n", uv_strerror(sas_i)); + } +} + +/* _ames_czar_port(): udp port for galaxy. +*/ +static c3_s +_ames_czar_port(c3_y imp_y) +{ + if ( c3n == u3_Host.ops_u.net ) { + return 31337 + imp_y; + } + else { + return 13337 + imp_y; + } +} + +/* _ames_czar_gone(): galaxy address resolution failed. +*/ +static void +_ames_czar_gone(u3_pact* pac_u, time_t now) +{ + // XX revisit + u3_pier* pir_u = u3_pier_stub(); + u3_ames* sam_u = pir_u->sam_u; + + u3l_log("ames: czar at %s: not found (b)\n", pac_u->dns_c); + if ( (0 == sam_u->imp_w[pac_u->imp_y]) || + (0xffffffff == sam_u->imp_w[pac_u->imp_y]) ) { + sam_u->imp_w[pac_u->imp_y] = 0xffffffff; + } /* else keep existing ip for 5 more minutes */ + sam_u->imp_t[pac_u->imp_y] = now; + + _ames_pact_free(pac_u); +} + +/* _ames_czar_cb(): galaxy address resolution callback. +*/ +static void +_ames_czar_cb(uv_getaddrinfo_t* adr_u, + c3_i sas_i, + struct addrinfo* aif_u) +{ + // XX revisit + u3_pier* pir_u = u3_pier_stub(); + u3_ames* sam_u = pir_u->sam_u; + + u3_pact* pac_u = (u3_pact*)adr_u->data; + time_t now = time(0); + + struct addrinfo* rai_u = aif_u; + + while ( 1 ) { + if ( !rai_u ) { + _ames_czar_gone(pac_u, now); + break; + } + + if ( (AF_INET == rai_u->ai_family) ) { + struct sockaddr_in* add_u = (struct sockaddr_in *)rai_u->ai_addr; + c3_w old_w = sam_u->imp_w[pac_u->imp_y]; + + sam_u->imp_w[pac_u->imp_y] = ntohl(add_u->sin_addr.s_addr); + sam_u->imp_t[pac_u->imp_y] = now; + +#if 1 + if ( sam_u->imp_w[pac_u->imp_y] != old_w + && sam_u->imp_w[pac_u->imp_y] != 0xffffffff ) { + u3_noun wad = u3i_words(1, &sam_u->imp_w[pac_u->imp_y]); + u3_noun nam = u3dc("scot", c3__if, wad); + c3_c* nam_c = u3r_string(nam); + + u3l_log("ames: czar %s: ip %s\n", pac_u->dns_c, nam_c); + + free(nam_c); u3z(nam); + } +#endif + + _ames_send(pac_u); + break; + } + + rai_u = rai_u->ai_next; + } + + free(adr_u); + uv_freeaddrinfo(aif_u); +} + + +/* _ames_czar(): galaxy address resolution. +*/ +static void +_ames_czar(u3_pact* pac_u, c3_c* bos_c) +{ + // XX revisit + u3_pier* pir_u = u3_pier_stub(); + u3_ames* sam_u = pir_u->sam_u; + + pac_u->por_s = _ames_czar_port(pac_u->imp_y); + + if ( c3n == u3_Host.ops_u.net ) { + pac_u->pip_w = 0x7f000001; + _ames_send(pac_u); + return; + } + + // if we don't have a galaxy domain, no-op + // + if ( 0 == bos_c ) { + u3_noun nam = u3dc("scot", 'p', pac_u->imp_y); + c3_c* nam_c = u3r_string(nam); + u3l_log("ames: no galaxy domain for %s, no-op\r\n", nam_c); + + free(nam_c); + u3z(nam); + return; + } + + time_t now = time(0); + + // backoff + if ( (0xffffffff == sam_u->imp_w[pac_u->imp_y]) && + (now - sam_u->imp_t[pac_u->imp_y]) < 300 ) { + _ames_pact_free(pac_u); + return; + } + + if ( (0 == sam_u->imp_w[pac_u->imp_y]) || + (now - sam_u->imp_t[pac_u->imp_y]) > 300 ) { /* 5 minute TTL */ + u3_noun nam = u3dc("scot", 'p', pac_u->imp_y); + c3_c* nam_c = u3r_string(nam); + // XX remove extra byte for '~' + pac_u->dns_c = c3_malloc(1 + strlen(bos_c) + 1 + strlen(nam_c)); + + snprintf(pac_u->dns_c, 256, "%s.%s", nam_c + 1, bos_c); + // u3l_log("czar %s, dns %s\n", nam_c, pac_u->dns_c); + + free(nam_c); + u3z(nam); + + { + uv_getaddrinfo_t* adr_u = c3_malloc(sizeof(*adr_u)); + adr_u->data = pac_u; + + c3_i sas_i; + + if ( 0 != (sas_i = uv_getaddrinfo(u3L, adr_u, + _ames_czar_cb, + pac_u->dns_c, 0, 0)) ) { + u3l_log("ames: %s\n", uv_strerror(sas_i)); + _ames_czar_gone(pac_u, now); + return; + } + } + } + else { + pac_u->pip_w = sam_u->imp_w[pac_u->imp_y]; + _ames_send(pac_u); + return; + } +} + +/* _ames_lane_ipv4(): IPv4 address/ from lane. +*/ +u3_noun +_ames_lane_ip(u3_noun lan, c3_s* por_s, c3_w* pip_w) +{ + switch ( u3h(lan) ) { + case c3__if: { + *por_s= (c3_s) u3h(u3t(u3t(lan))); + *pip_w = u3r_word(0, u3t(u3t(u3t(lan)))); + + return c3y; + } break; + case c3__is: { + u3_noun pq_lan = u3h(u3t(u3t(lan))); + + if ( u3_nul == pq_lan ) return c3n; + else return _ames_lane_ip(u3t(pq_lan), por_s, pip_w); + } break; + case c3__ix: { + *por_s = (c3_s) u3h(u3t(u3t(lan))); + *pip_w = u3r_word(0, u3t(u3t(u3t(lan)))); + + return c3y; + } break; + } + return c3n; +} + +/* u3_ames_ef_bake(): notify %ames that we're live. +*/ +void +u3_ames_ef_bake(u3_pier* pir_u) +{ + u3_noun pax = u3nq(u3_blip, c3__newt, u3k(u3A->sen), u3_nul); + + u3_pier_plan(pax, u3nc(c3__barn, u3_nul)); +} + +/* u3_ames_ef_send(): send packet to network (v4). +*/ +void +u3_ames_ef_send(u3_pier* pir_u, u3_noun lan, u3_noun pac) +{ + u3_ames* sam_u = pir_u->sam_u; + + if ( u3_Host.ops_u.fuz_w && ((rand() % 100) < u3_Host.ops_u.fuz_w) ) { + u3z(lan); u3z(pac); + return; + } + + u3_pact* pac_u = c3_calloc(sizeof(*pac_u)); + + if ( c3y == _ames_lane_ip(lan, &pac_u->por_s, &pac_u->pip_w) ) { + pac_u->len_w = u3r_met(3, pac); + pac_u->hun_y = c3_malloc(pac_u->len_w); + + u3r_bytes(0, pac_u->len_w, pac_u->hun_y, pac); + + if ( 0 == pac_u->pip_w ) { + pac_u->pip_w = 0x7f000001; + pac_u->por_s = pir_u->por_s; + } + + if ( (0 == (pac_u->pip_w >> 16)) && (1 == (pac_u->pip_w >> 8)) ) { + pac_u->imp_y = (pac_u->pip_w & 0xff); + + _ames_czar(pac_u, sam_u->dns_c); + } + else if ( (c3y == u3_Host.ops_u.net) || (0x7f000001 == pac_u->pip_w) ) { + _ames_send(pac_u); + } + else { + // networking disabled + _ames_pact_free(pac_u); + } + } + else { + _ames_pact_free(pac_u); + } + + u3z(lan); u3z(pac); +} + +/* _ames_recv_cb(): receive callback. +*/ +static void +_ames_recv_cb(uv_udp_t* wax_u, + ssize_t nrd_i, + const uv_buf_t * buf_u, + const struct sockaddr* adr_u, + unsigned flg_i) +{ + // u3l_log("ames: rx %p\r\n", buf_u.base); + + if ( 0 == nrd_i ) { + _ames_free(buf_u->base); + } + else { + { + u3_noun msg = u3i_bytes((c3_w)nrd_i, (c3_y*)buf_u->base); + + // u3l_log("ames: plan\r\n"); +#if 0 + u3z(msg); +#else + struct sockaddr_in* add_u = (struct sockaddr_in *)adr_u; + c3_s por_s = ntohs(add_u->sin_port); + c3_w pip_w = ntohl(add_u->sin_addr.s_addr); + + u3_pier_plan + (u3nt(u3_blip, c3__ames, u3_nul), + u3nt(c3__hear, + u3nq(c3__if, u3k(u3A->now), por_s, u3i_words(1, &pip_w)), + msg)); +#endif + } + _ames_free(buf_u->base); + } +} + +/* _ames_io_start(): initialize ames I/O. +*/ +static void +_ames_io_start(u3_pier* pir_u) +{ + u3_ames* sam_u = pir_u->sam_u; + c3_s por_s = pir_u->por_s; + u3_noun who = u3i_chubs(2, pir_u->who_d); + u3_noun rac = u3do("clan:title", u3k(who)); + + if ( c3__czar == rac ) { + u3_noun imp = u3dc("scot", 'p', u3k(who)); + c3_c* imp_c = u3r_string(imp); + c3_y num_y = (c3_y)pir_u->who_d[0]; + + por_s = _ames_czar_port(num_y); + + if ( c3y == u3_Host.ops_u.net ) { + u3l_log("ames: czar: %s on %d\n", imp_c, por_s); + } + else { + u3l_log("ames: czar: %s on %d (localhost only)\n", imp_c, por_s); + } + + u3z(imp); + free(imp_c); + } + + int ret; + if ( 0 != (ret = uv_udp_init(u3L, &sam_u->wax_u)) ) { + u3l_log("ames: init: %s\n", uv_strerror(ret)); + c3_assert(0); + } + + // Bind and stuff. + { + struct sockaddr_in add_u; + c3_i add_i = sizeof(add_u); + + memset(&add_u, 0, sizeof(add_u)); + add_u.sin_family = AF_INET; + add_u.sin_addr.s_addr = _(u3_Host.ops_u.net) ? + htonl(INADDR_ANY) : + htonl(INADDR_LOOPBACK); + add_u.sin_port = htons(por_s); + + int ret; + if ( (ret = uv_udp_bind(&sam_u->wax_u, + (const struct sockaddr*) & add_u, 0)) != 0 ) { + u3l_log("ames: bind: %s\n", + uv_strerror(ret)); + if (UV_EADDRINUSE == ret){ + u3l_log(" ...perhaps you've got two copies of vere running?\n"); + } + u3_pier_exit(pir_u); + } + + uv_udp_getsockname(&sam_u->wax_u, (struct sockaddr *)&add_u, &add_i); + c3_assert(add_u.sin_port); + + sam_u->por_s = ntohs(add_u.sin_port); + } + + // u3l_log("ames: on localhost, UDP %d.\n", sam_u->por_s); + uv_udp_recv_start(&sam_u->wax_u, _ames_alloc, _ames_recv_cb); + + sam_u->liv = c3y; + u3z(rac); + u3z(who); +} + +/* _cttp_mcut_char(): measure/cut character. +*/ +static c3_w +_cttp_mcut_char(c3_c* buf_c, c3_w len_w, c3_c chr_c) +{ + if ( buf_c ) { + buf_c[len_w] = chr_c; + } + return len_w + 1; +} + +/* _cttp_mcut_cord(): measure/cut cord. +*/ +static c3_w +_cttp_mcut_cord(c3_c* buf_c, c3_w len_w, u3_noun san) +{ + c3_w ten_w = u3r_met(3, san); + + if ( buf_c ) { + u3r_bytes(0, ten_w, (c3_y *)(buf_c + len_w), san); + } + u3z(san); + return (len_w + ten_w); +} + +/* _cttp_mcut_path(): measure/cut cord list. +*/ +static c3_w +_cttp_mcut_path(c3_c* buf_c, c3_w len_w, c3_c sep_c, u3_noun pax) +{ + u3_noun axp = pax; + + while ( u3_nul != axp ) { + u3_noun h_axp = u3h(axp); + + len_w = _cttp_mcut_cord(buf_c, len_w, u3k(h_axp)); + axp = u3t(axp); + + if ( u3_nul != axp ) { + len_w = _cttp_mcut_char(buf_c, len_w, sep_c); + } + } + u3z(pax); + return len_w; +} + +/* _cttp_mcut_host(): measure/cut host. +*/ +static c3_w +_cttp_mcut_host(c3_c* buf_c, c3_w len_w, u3_noun hot) +{ + len_w = _cttp_mcut_path(buf_c, len_w, '.', u3kb_flop(u3k(hot))); + u3z(hot); + return len_w; +} + +/* u3_ames_ef_turf(): initialize ames I/O on domain(s). +*/ +void +u3_ames_ef_turf(u3_pier* pir_u, u3_noun tuf) +{ + u3_ames* sam_u = pir_u->sam_u; + + if ( u3_nul != tuf ) { + // XX save all for fallback, not just first + u3_noun hot = u3k(u3h(tuf)); + c3_w len_w = _cttp_mcut_host(0, 0, u3k(hot)); + + sam_u->dns_c = c3_malloc(1 + len_w); + _cttp_mcut_host(sam_u->dns_c, 0, hot); + sam_u->dns_c[len_w] = 0; + + u3z(tuf); + } + else if ( (c3n == pir_u->fak_o) && (0 == sam_u->dns_c) ) { + u3l_log("ames: turf: no domains\n"); + } + + if ( c3n == sam_u->liv ) { + _ames_io_start(pir_u); + } +} + +/* u3_ames_io_init(): initialize ames I/O. +*/ +void +u3_ames_io_init(u3_pier* pir_u) +{ + u3_ames* sam_u = pir_u->sam_u; + sam_u->liv = c3n; +} + +/* u3_ames_io_talk(): start receiving ames traffic. +*/ +void +u3_ames_io_talk(u3_pier* pir_u) +{ +} + +/* u3_ames_io_exit(): terminate ames I/O. +*/ +void +u3_ames_io_exit(u3_pier* pir_u) +{ + u3_ames* sam_u = pir_u->sam_u; + + if ( c3y == sam_u->liv ) { + // XX remove had_u/wax_u union, cast and close wax_u + uv_close(&sam_u->had_u, 0); + } +} diff --git a/pkg/hs/vere/notes/c/behn.c b/pkg/hs/vere/notes/c/behn.c new file mode 100644 index 000000000..6da833eab --- /dev/null +++ b/pkg/hs/vere/notes/c/behn.c @@ -0,0 +1,90 @@ +/* vere/behn.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +/* u3_behn(): initialize time timer. +*/ +void +u3_behn_io_init(u3_pier *pir_u) +{ + u3_behn* teh_u = pir_u->teh_u; + teh_u->alm = c3n; + + uv_timer_init(u3L, &teh_u->tim_u); + teh_u->tim_u.data = pir_u; +} + +/* u3_behn_io_exit(): terminate timer. +*/ +void +u3_behn_io_exit(u3_pier *pir_u) +{ +} + +/* _behn_time_cb(): timer callback. +*/ +static void +_behn_time_cb(uv_timer_t* tim_u) +{ + u3_pier *pir_u = tim_u->data; + u3_behn* teh_u = pir_u->teh_u; + teh_u->alm = c3n; + + { + u3_pier_work + (pir_u, + u3nt(u3_blip, c3__behn, u3_nul), + u3nc(c3__wake, u3_nul)); + } +} + +/* u3_behn_ef_doze(): set or cancel timer +*/ +void +u3_behn_ef_doze(u3_pier *pir_u, u3_noun wen) +{ + u3_behn* teh_u = pir_u->teh_u; + + if ( c3y == teh_u->alm ) { + uv_timer_stop(&teh_u->tim_u); + teh_u->alm = c3n; + } + + if ( (u3_nul != wen) && + (c3y == u3du(wen)) && + (c3y == u3ud(u3t(wen))) ) + { + struct timeval tim_tv; + gettimeofday(&tim_tv, 0); + + u3_noun now = u3_time_in_tv(&tim_tv); + c3_d gap_d = u3_time_gap_ms(now, u3k(u3t(wen))); + + teh_u->alm = c3y; + uv_timer_start(&teh_u->tim_u, _behn_time_cb, gap_d, 0); + } + + u3z(wen); +} + +/* u3_behn_ef_bake(): notify %behn that we're live +*/ +void +u3_behn_ef_bake(u3_pier *pir_u) +{ + u3_noun pax = u3nq(u3_blip, c3__behn, u3k(u3A->sen), u3_nul); + + u3_pier_work(pir_u, pax, u3nc(c3__born, u3_nul)); +} diff --git a/pkg/hs/vere/notes/c/cttp.c b/pkg/hs/vere/notes/c/cttp.c new file mode 100644 index 000000000..36ff32440 --- /dev/null +++ b/pkg/hs/vere/notes/c/cttp.c @@ -0,0 +1,989 @@ +/* vere/cttp.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + + +// XX deduplicate with _http_vec_to_atom +/* _cttp_vec_to_atom(): convert h2o_iovec_t to atom (cord) +*/ +static u3_noun +_cttp_vec_to_atom(h2o_iovec_t vec_u) +{ + return u3i_bytes(vec_u.len, (const c3_y*)vec_u.base); +} + +/* _cttp_bods_free(): free body structure. +*/ +static void +_cttp_bods_free(u3_hbod* bod_u) +{ + while ( bod_u ) { + u3_hbod* nex_u = bod_u->nex_u; + + free(bod_u); + bod_u = nex_u; + } +} + +/* _cttp_bod_new(): create a data buffer +*/ +static u3_hbod* +_cttp_bod_new(c3_w len_w, c3_c* hun_c) +{ + u3_hbod* bod_u = c3_malloc(1 + len_w + sizeof(*bod_u)); + bod_u->hun_y[len_w] = 0; + bod_u->len_w = len_w; + memcpy(bod_u->hun_y, (const c3_y*)hun_c, len_w); + + bod_u->nex_u = 0; + return bod_u; +} + +/* _cttp_bod_from_hed(): create a data buffer from a header +*/ +static u3_hbod* +_cttp_bod_from_hed(u3_hhed* hed_u) +{ + c3_w len_w = hed_u->nam_w + 2 + hed_u->val_w + 2; + u3_hbod* bod_u = c3_malloc(1 + len_w + sizeof(*bod_u)); + bod_u->hun_y[len_w] = 0; + + memcpy(bod_u->hun_y, hed_u->nam_c, hed_u->nam_w); + memcpy(bod_u->hun_y + hed_u->nam_w, ": ", 2); + memcpy(bod_u->hun_y + hed_u->nam_w + 2, hed_u->val_c, hed_u->val_w); + memcpy(bod_u->hun_y + hed_u->nam_w + 2 + hed_u->val_w, "\r\n", 2); + + bod_u->len_w = len_w; + bod_u->nex_u = 0; + + return bod_u; +} + +/* _cttp_bods_to_octs: translate body buffer into octet-stream noun. +*/ +static u3_noun +_cttp_bods_to_octs(u3_hbod* bod_u) +{ + c3_w len_w; + c3_y* buf_y; + u3_noun cos; + + { + u3_hbod* bid_u = bod_u; + + len_w = 0; + while ( bid_u ) { + len_w += bid_u->len_w; + bid_u = bid_u->nex_u; + } + } + buf_y = c3_malloc(1 + len_w); + buf_y[len_w] = 0; + + { + c3_y* ptr_y = buf_y; + + while ( bod_u ) { + memcpy(ptr_y, bod_u->hun_y, bod_u->len_w); + ptr_y += bod_u->len_w; + bod_u = bod_u->nex_u; + } + } + cos = u3i_bytes(len_w, buf_y); + free(buf_y); + return u3nc(len_w, cos); +} + +/* _cttp_bod_from_octs(): translate octet-stream noun into body. +*/ +static u3_hbod* +_cttp_bod_from_octs(u3_noun oct) +{ + c3_w len_w; + + if ( !_(u3a_is_cat(u3h(oct))) ) { // 2GB max + u3m_bail(c3__fail); return 0; + } + len_w = u3h(oct); + + { + u3_hbod* bod_u = c3_malloc(1 + len_w + sizeof(*bod_u)); + bod_u->hun_y[len_w] = 0; + bod_u->len_w = len_w; + u3r_bytes(0, len_w, bod_u->hun_y, u3t(oct)); + + bod_u->nex_u = 0; + + u3z(oct); + return bod_u; + } +} + +/* _cttp_bods_to_vec(): translate body buffers to array of h2o_iovec_t +*/ +static h2o_iovec_t* +_cttp_bods_to_vec(u3_hbod* bod_u, c3_w* tot_w) +{ + h2o_iovec_t* vec_u; + c3_w len_w; + + { + u3_hbod* bid_u = bod_u; + len_w = 0; + + while( bid_u ) { + len_w++; + bid_u = bid_u->nex_u; + } + } + + if ( 0 == len_w ) { + *tot_w = len_w; + return 0; + } + + vec_u = c3_malloc(sizeof(h2o_iovec_t) * len_w); + len_w = 0; + + while( bod_u ) { + vec_u[len_w] = h2o_iovec_init(bod_u->hun_y, bod_u->len_w); + len_w++; + bod_u = bod_u->nex_u; + } + + *tot_w = len_w; + + return vec_u; +} + +// XX deduplicate with _http_heds_free +/* _cttp_heds_free(): free header linked list +*/ +static void +_cttp_heds_free(u3_hhed* hed_u) +{ + while ( hed_u ) { + u3_hhed* nex_u = hed_u->nex_u; + + free(hed_u->nam_c); + free(hed_u->val_c); + free(hed_u); + hed_u = nex_u; + } +} + +// XX deduplicate with _http_hed_new +/* _cttp_hed_new(): create u3_hhed from nam/val cords +*/ +static u3_hhed* +_cttp_hed_new(u3_atom nam, u3_atom val) +{ + c3_w nam_w = u3r_met(3, nam); + c3_w val_w = u3r_met(3, val); + u3_hhed* hed_u = c3_malloc(sizeof(*hed_u)); + + hed_u->nam_c = c3_malloc(1 + nam_w); + hed_u->val_c = c3_malloc(1 + val_w); + hed_u->nam_c[nam_w] = 0; + hed_u->val_c[val_w] = 0; + hed_u->nex_u = 0; + hed_u->nam_w = nam_w; + hed_u->val_w = val_w; + + u3r_bytes(0, nam_w, (c3_y*)hed_u->nam_c, nam); + u3r_bytes(0, val_w, (c3_y*)hed_u->val_c, val); + + return hed_u; +} + +// XX vv similar to _http_heds_from_noun +/* _cttp_heds_math(): create headers from +math +*/ +static u3_hhed* +_cttp_heds_math(u3_noun mah) +{ + u3_noun hed = u3kdi_tap(mah); + u3_noun deh = hed; + + u3_hhed* hed_u = 0; + + while ( u3_nul != hed ) { + u3_noun nam = u3h(u3h(hed)); + u3_noun lit = u3t(u3h(hed)); + + while ( u3_nul != lit ) { + u3_hhed* nex_u = _cttp_hed_new(nam, u3h(lit)); + nex_u->nex_u = hed_u; + + hed_u = nex_u; + lit = u3t(lit); + } + + hed = u3t(hed); + } + + u3z(deh); + return hed_u; +} + +// XX deduplicate with _http_heds_to_noun +/* _cttp_heds_to_noun(): convert h2o_header_t to (list (pair @t @t)) +*/ +static u3_noun +_cttp_heds_to_noun(h2o_header_t* hed_u, c3_d hed_d) +{ + u3_noun hed = u3_nul; + c3_d dex_d = hed_d; + + h2o_header_t deh_u; + + while ( 0 < dex_d ) { + deh_u = hed_u[--dex_d]; + hed = u3nc(u3nc(_cttp_vec_to_atom(*deh_u.name), + _cttp_vec_to_atom(deh_u.value)), hed); + } + + return hed; +} + +/* _cttp_cres_free(): free a u3_cres. +*/ +static void +_cttp_cres_free(u3_cres* res_u) +{ + _cttp_bods_free(res_u->bod_u); + free(res_u); +} + +/* _cttp_cres_new(): create a response +*/ +static void +_cttp_cres_new(u3_creq* ceq_u, c3_w sas_w) +{ + ceq_u->res_u = c3_calloc(sizeof(*ceq_u->res_u)); + ceq_u->res_u->sas_w = sas_w; +} + +/* _cttp_cres_fire_body(): attach response body buffer +*/ +static void +_cttp_cres_fire_body(u3_cres* res_u, u3_hbod* bod_u) +{ + c3_assert(!bod_u->nex_u); + + if ( !(res_u->bod_u) ) { + res_u->bod_u = res_u->dob_u = bod_u; + } + else { + res_u->dob_u->nex_u = bod_u; + res_u->dob_u = bod_u; + } +} + +/* _cttp_mcut_char(): measure/cut character. +*/ +static c3_w +_cttp_mcut_char(c3_c* buf_c, c3_w len_w, c3_c chr_c) +{ + if ( buf_c ) { + buf_c[len_w] = chr_c; + } + return len_w + 1; +} + +/* _cttp_mcut_cord(): measure/cut cord. +*/ +static c3_w +_cttp_mcut_cord(c3_c* buf_c, c3_w len_w, u3_noun san) +{ + c3_w ten_w = u3r_met(3, san); + + if ( buf_c ) { + u3r_bytes(0, ten_w, (c3_y *)(buf_c + len_w), san); + } + u3z(san); + return (len_w + ten_w); +} + +/* _cttp_mcut_path(): measure/cut cord list. +*/ +static c3_w +_cttp_mcut_path(c3_c* buf_c, c3_w len_w, c3_c sep_c, u3_noun pax) +{ + u3_noun axp = pax; + + while ( u3_nul != axp ) { + u3_noun h_axp = u3h(axp); + + len_w = _cttp_mcut_cord(buf_c, len_w, u3k(h_axp)); + axp = u3t(axp); + + if ( u3_nul != axp ) { + len_w = _cttp_mcut_char(buf_c, len_w, sep_c); + } + } + u3z(pax); + return len_w; +} + +/* _cttp_mcut_host(): measure/cut host. +*/ +static c3_w +_cttp_mcut_host(c3_c* buf_c, c3_w len_w, u3_noun hot) +{ + len_w = _cttp_mcut_path(buf_c, len_w, '.', u3kb_flop(u3k(hot))); + u3z(hot); + return len_w; +} + +/* _cttp_mcut_pork(): measure/cut path/extension. +*/ +static c3_w +_cttp_mcut_pork(c3_c* buf_c, c3_w len_w, u3_noun pok) +{ + u3_noun h_pok = u3h(pok); + u3_noun t_pok = u3t(pok); + + len_w = _cttp_mcut_path(buf_c, len_w, '/', u3k(t_pok)); + if ( u3_nul != h_pok ) { + len_w = _cttp_mcut_char(buf_c, len_w, '.'); + len_w = _cttp_mcut_cord(buf_c, len_w, u3k(u3t(h_pok))); + } + u3z(pok); + return len_w; +} + +/* _cttp_mcut_quay(): measure/cut query. +*/ +static c3_w +_cttp_mcut_quay(c3_c* buf_c, c3_w len_w, u3_noun quy) +{ + if ( u3_nul == quy ) { + return len_w; + } + else { + u3_noun i_quy = u3h(quy); + u3_noun pi_quy = u3h(i_quy); + u3_noun qi_quy = u3t(i_quy); + u3_noun t_quy = u3t(quy); + + len_w = _cttp_mcut_char(buf_c, len_w, '&'); + len_w = _cttp_mcut_cord(buf_c, len_w, u3k(pi_quy)); + len_w = _cttp_mcut_char(buf_c, len_w, '='); + len_w = _cttp_mcut_cord(buf_c, len_w, u3k(qi_quy)); + + len_w = _cttp_mcut_quay(buf_c, len_w, u3k(t_quy)); + } + u3z(quy); + return len_w; +} + +/* _cttp_mcut_url(): measure/cut purl, producing relative URL. +*/ +static c3_w +_cttp_mcut_url(c3_c* buf_c, c3_w len_w, u3_noun pul) +{ + u3_noun q_pul = u3h(u3t(pul)); + u3_noun r_pul = u3t(u3t(pul)); + + len_w = _cttp_mcut_char(buf_c, len_w, '/'); + len_w = _cttp_mcut_pork(buf_c, len_w, u3k(q_pul)); + + if ( u3_nul != r_pul ) { + len_w = _cttp_mcut_char(buf_c, len_w, '?'); + len_w = _cttp_mcut_quay(buf_c, len_w, u3k(r_pul)); + } + u3z(pul); + return len_w; +} + +/* _cttp_creq_port(): stringify port +*/ +static c3_c* +_cttp_creq_port(c3_s por_s) +{ + c3_c* por_c = c3_malloc(8); + snprintf(por_c, 7, "%d", 0xffff & por_s); + return por_c; +} + +/* _cttp_creq_url(): construct url from noun. +*/ +static c3_c* +_cttp_creq_url(u3_noun pul) +{ + c3_w len_w = _cttp_mcut_url(0, 0, u3k(pul)); + c3_c* url_c = c3_malloc(1 + len_w); + + _cttp_mcut_url(url_c, 0, pul); + url_c[len_w] = 0; + + return url_c; +} + +/* _cttp_creq_host(): construct host from noun. +*/ +static c3_c* +_cttp_creq_host(u3_noun hot) +{ + c3_w len_w = _cttp_mcut_host(0, 0, u3k(hot)); + c3_c* hot_c = c3_malloc(1 + len_w); + + _cttp_mcut_host(hot_c, 0, hot); + hot_c[len_w] = 0; + + return hot_c; +} + +/* _cttp_creq_ip(): stringify ip +*/ +static c3_c* +_cttp_creq_ip(c3_w ipf_w) +{ + c3_c* ipf_c = c3_malloc(17); + snprintf(ipf_c, 16, "%d.%d.%d.%d", (ipf_w >> 24), + ((ipf_w >> 16) & 255), + ((ipf_w >> 8) & 255), + (ipf_w & 255)); + return ipf_c; +} + +/* _cttp_creq_find(): find a request by number in the client +*/ +static u3_creq* +_cttp_creq_find(c3_l num_l) +{ + u3_creq* ceq_u = u3_Host.ctp_u.ceq_u; + + // XX glories of linear search + // + while ( ceq_u ) { + if ( num_l == ceq_u->num_l ) { + return ceq_u; + } + ceq_u = ceq_u->nex_u; + } + return 0; +} + +/* _cttp_creq_link(): link request to client +*/ +static void +_cttp_creq_link(u3_creq* ceq_u) +{ + ceq_u->nex_u = u3_Host.ctp_u.ceq_u; + + if ( 0 != ceq_u->nex_u ) { + ceq_u->nex_u->pre_u = ceq_u; + } + u3_Host.ctp_u.ceq_u = ceq_u; +} + +/* _cttp_creq_unlink(): unlink request from client +*/ +static void +_cttp_creq_unlink(u3_creq* ceq_u) +{ + if ( ceq_u->pre_u ) { + ceq_u->pre_u->nex_u = ceq_u->nex_u; + + if ( 0 != ceq_u->nex_u ) { + ceq_u->nex_u->pre_u = ceq_u->pre_u; + } + } + else { + u3_Host.ctp_u.ceq_u = ceq_u->nex_u; + + if ( 0 != ceq_u->nex_u ) { + ceq_u->nex_u->pre_u = 0; + } + } +} + +/* _cttp_creq_free(): free a u3_creq. +*/ +static void +_cttp_creq_free(u3_creq* ceq_u) +{ + _cttp_creq_unlink(ceq_u); + + _cttp_heds_free(ceq_u->hed_u); + // Note: ceq_u->bod_u is covered here + _cttp_bods_free(ceq_u->rub_u); + + if ( ceq_u->res_u ) { + _cttp_cres_free(ceq_u->res_u); + } + + free(ceq_u->hot_c); + free(ceq_u->por_c); + free(ceq_u->url_c); + free(ceq_u->vec_u); + free(ceq_u); +} + +/* _cttp_creq_new(): create a request from a +hiss noun +*/ +static u3_creq* +_cttp_creq_new(c3_l num_l, u3_noun hes) +{ + u3_creq* ceq_u = c3_calloc(sizeof(*ceq_u)); + + u3_noun pul = u3h(hes); // +purl + u3_noun hat = u3h(pul); // +hart + u3_noun sec = u3h(hat); + u3_noun por = u3h(u3t(hat)); + u3_noun hot = u3t(u3t(hat)); // +host + u3_noun moh = u3t(hes); // +moth + u3_noun met = u3h(moh); // +meth + u3_noun mah = u3h(u3t(moh)); // +math + u3_noun bod = u3t(u3t(moh)); + + ceq_u->sat_e = u3_csat_init; + ceq_u->num_l = num_l; + ceq_u->sec = sec; + + if ( c3y == u3h(hot) ) { + ceq_u->hot_c = _cttp_creq_host(u3k(u3t(hot))); + } else { + ceq_u->ipf_w = u3r_word(0, u3t(hot)); + ceq_u->ipf_c = _cttp_creq_ip(ceq_u->ipf_w); + } + + if ( u3_nul != por ) { + ceq_u->por_s = u3t(por); + ceq_u->por_c = _cttp_creq_port(ceq_u->por_s); + } + + ceq_u->met_m = met; + ceq_u->url_c = _cttp_creq_url(u3k(pul)); + ceq_u->hed_u = _cttp_heds_math(u3k(mah)); + + if ( u3_nul != bod ) { + ceq_u->bod_u = _cttp_bod_from_octs(u3k(u3t(bod))); + } + + _cttp_creq_link(ceq_u); + + u3z(hes); + return ceq_u; +} + +/* _cttp_creq_fire_body(): attach body to request buffers. +*/ +static void +_cttp_creq_fire_body(u3_creq* ceq_u, u3_hbod *rub_u) +{ + c3_assert(!rub_u->nex_u); + + if ( !(ceq_u->rub_u) ) { + ceq_u->rub_u = ceq_u->bur_u = rub_u; + } + else { + ceq_u->bur_u->nex_u = rub_u; + ceq_u->bur_u = rub_u; + } +} + +/* _cttp_creq_fire_str(): attach string to request buffers. +*/ +static void +_cttp_creq_fire_str(u3_creq* ceq_u, c3_c* str_c) +{ + _cttp_creq_fire_body(ceq_u, _cttp_bod_new(strlen(str_c), str_c)); +} + +/* _cttp_creq_fire_heds(): attach output headers. +*/ +static void +_cttp_creq_fire_heds(u3_creq* ceq_u, u3_hhed* hed_u) +{ + while ( hed_u ) { + _cttp_creq_fire_body(ceq_u, _cttp_bod_from_hed(hed_u)); + hed_u = hed_u->nex_u; + } +} + +/* _cttp_creq_fire(): load request data for into buffers. +*/ +static void +_cttp_creq_fire(u3_creq* ceq_u) +{ + switch ( ceq_u->met_m ) { + default: c3_assert(0); + case c3__get: _cttp_creq_fire_str(ceq_u, "GET "); break; + case c3__put: _cttp_creq_fire_str(ceq_u, "PUT "); break; + case c3__post: _cttp_creq_fire_str(ceq_u, "POST "); break; + case c3__head: _cttp_creq_fire_str(ceq_u, "HEAD "); break; + case c3__conn: _cttp_creq_fire_str(ceq_u, "CONNECT "); break; + case c3__delt: _cttp_creq_fire_str(ceq_u, "DELETE "); break; + case c3__opts: _cttp_creq_fire_str(ceq_u, "OPTIONS "); break; + case c3__trac: _cttp_creq_fire_str(ceq_u, "TRACE "); break; + } + _cttp_creq_fire_str(ceq_u, ceq_u->url_c); + _cttp_creq_fire_str(ceq_u, " HTTP/1.1\r\n"); + + { + c3_c* hot_c = ceq_u->hot_c ? ceq_u->hot_c : ceq_u->ipf_c; + c3_c* hos_c; + c3_w len_w; + + if ( ceq_u->por_c ) { + len_w = 6 + strlen(hot_c) + 1 + strlen(ceq_u->por_c) + 3; + hos_c = c3_malloc(len_w); + len_w = snprintf(hos_c, len_w, "Host: %s:%s\r\n", hot_c, ceq_u->por_c); + } + else { + len_w = 6 + strlen(hot_c) + 3; + hos_c = c3_malloc(len_w); + len_w = snprintf(hos_c, len_w, "Host: %s\r\n", hot_c); + } + + _cttp_creq_fire_body(ceq_u, _cttp_bod_new(len_w, hos_c)); + free(hos_c); + } + + _cttp_creq_fire_heds(ceq_u, ceq_u->hed_u); + + if ( !ceq_u->bod_u ) { + _cttp_creq_fire_body(ceq_u, _cttp_bod_new(2, "\r\n")); + } + else { + c3_c len_c[41]; + c3_w len_w = snprintf(len_c, 40, "Content-Length: %u\r\n\r\n", + ceq_u->bod_u->len_w); + + _cttp_creq_fire_body(ceq_u, _cttp_bod_new(len_w, len_c)); + _cttp_creq_fire_body(ceq_u, ceq_u->bod_u); + } +} + +/* _cttp_creq_quit(): cancel a u3_creq +*/ +static void +_cttp_creq_quit(u3_creq* ceq_u) +{ + if ( u3_csat_addr == ceq_u->sat_e ) { + ceq_u->sat_e = u3_csat_quit; + return; // wait to be called again on address resolution + } + + if ( ceq_u->cli_u ) { + h2o_http1client_cancel(ceq_u->cli_u); + } + + _cttp_creq_free(ceq_u); +} + +/* _cttp_httr(): dispatch http response to %eyre +*/ +static void +_cttp_httr(c3_l num_l, c3_w sas_w, u3_noun mes, u3_noun uct) +{ + u3_noun htr = u3nt(sas_w, mes, uct); + u3_noun pox = u3nt(u3_blip, c3__http, u3_nul); + + u3_pier_plan(pox, u3nt(c3__they, num_l, htr)); +} + +/* _cttp_creq_quit(): dispatch error response +*/ +static void +_cttp_creq_fail(u3_creq* ceq_u, const c3_c* err_c) +{ + // XX anything other than a 504? + c3_w cod_w = 504; + + u3l_log("http: fail (%d, %d): %s\r\n", ceq_u->num_l, cod_w, err_c); + + // XX include err_c as response body? + _cttp_httr(ceq_u->num_l, cod_w, u3_nul, u3_nul); + _cttp_creq_free(ceq_u); +} + +/* _cttp_creq_quit(): dispatch response +*/ +static void +_cttp_creq_respond(u3_creq* ceq_u) +{ + u3_cres* res_u = ceq_u->res_u; + + _cttp_httr(ceq_u->num_l, res_u->sas_w, res_u->hed, + ( !res_u->bod_u ) ? u3_nul : + u3nc(u3_nul, _cttp_bods_to_octs(res_u->bod_u))); + + _cttp_creq_free(ceq_u); +} + +// XX research: may be called with closed client? +/* _cttp_creq_on_body(): cb invoked by h2o upon receiving a response body +*/ +static c3_i +_cttp_creq_on_body(h2o_http1client_t* cli_u, const c3_c* err_c) +{ + u3_creq* ceq_u = (u3_creq *)cli_u->data; + + if ( 0 != err_c && h2o_http1client_error_is_eos != err_c ) { + _cttp_creq_fail(ceq_u, err_c); + return -1; + } + + h2o_buffer_t* buf_u = cli_u->sock->input; + + if ( buf_u->size ) { + _cttp_cres_fire_body(ceq_u->res_u, + _cttp_bod_new(buf_u->size, buf_u->bytes)); + h2o_buffer_consume(&cli_u->sock->input, buf_u->size); + } + + if ( h2o_http1client_error_is_eos == err_c ) { + _cttp_creq_respond(ceq_u); + } + + return 0; +} + +/* _cttp_creq_on_head(): cb invoked by h2o upon receiving response headers +*/ +static h2o_http1client_body_cb +_cttp_creq_on_head(h2o_http1client_t* cli_u, const c3_c* err_c, c3_i ver_i, + c3_i sas_i, h2o_iovec_t sas_u, h2o_header_t* hed_u, + size_t hed_t, c3_i len_i) +{ + u3_creq* ceq_u = (u3_creq *)cli_u->data; + + if ( 0 != err_c && h2o_http1client_error_is_eos != err_c ) { + _cttp_creq_fail(ceq_u, err_c); + return 0; + } + + _cttp_cres_new(ceq_u, (c3_w)sas_i); + ceq_u->res_u->hed = _cttp_heds_to_noun(hed_u, hed_t); + + if ( h2o_http1client_error_is_eos == err_c ) { + _cttp_creq_respond(ceq_u); + return 0; + } + + return _cttp_creq_on_body; +} + +/* _cttp_creq_on_connect(): cb invoked by h2o upon successful connection +*/ +static h2o_http1client_head_cb +_cttp_creq_on_connect(h2o_http1client_t* cli_u, const c3_c* err_c, + h2o_iovec_t** vec_p, size_t* vec_t, c3_i* hed_i) +{ + u3_creq* ceq_u = (u3_creq *)cli_u->data; + + if ( 0 != err_c ) { + _cttp_creq_fail(ceq_u, err_c); + return 0; + } + + { + c3_w len_w; + ceq_u->vec_u = _cttp_bods_to_vec(ceq_u->rub_u, &len_w); + *vec_t = len_w; + *vec_p = ceq_u->vec_u; + *hed_i = c3__head == ceq_u->met_m; + } + + return _cttp_creq_on_head; +} + +/* _cttp_creq_connect(): establish connection +*/ +static void +_cttp_creq_connect(u3_creq* ceq_u) +{ + c3_assert(u3_csat_ripe == ceq_u->sat_e); + c3_assert(ceq_u->ipf_c); + + h2o_iovec_t ipf_u = h2o_iovec_init(ceq_u->ipf_c, strlen(ceq_u->ipf_c)); + c3_s por_s = ceq_u->por_s ? ceq_u->por_s : + ( c3y == ceq_u->sec ) ? 443 : 80; + + // connect by IP + h2o_http1client_connect(&ceq_u->cli_u, ceq_u, u3_Host.ctp_u.ctx_u, ipf_u, + por_s, c3y == ceq_u->sec, _cttp_creq_on_connect); + + // set hostname for TLS handshake + if ( ceq_u->hot_c && c3y == ceq_u->sec ) { + c3_w len_w = 1 + strlen(ceq_u->hot_c); + c3_c* hot_c = c3_malloc(len_w); + strncpy(hot_c, ceq_u->hot_c, len_w); + + free(ceq_u->cli_u->ssl.server_name); + ceq_u->cli_u->ssl.server_name = hot_c; + } + + _cttp_creq_fire(ceq_u); +} + +/* _cttp_creq_resolve_cb(): cb upon IP address resolution +*/ +static void +_cttp_creq_resolve_cb(uv_getaddrinfo_t* adr_u, + c3_i sas_i, + struct addrinfo* aif_u) +{ + u3_creq* ceq_u = adr_u->data; + + if ( u3_csat_quit == ceq_u->sat_e ) { + _cttp_creq_quit(ceq_u);; + } + else if ( 0 != sas_i ) { + _cttp_creq_fail(ceq_u, uv_strerror(sas_i)); + } + else { + // XX traverse struct a la _ames_czar_cb + ceq_u->ipf_w = ntohl(((struct sockaddr_in *)aif_u->ai_addr)->sin_addr.s_addr); + ceq_u->ipf_c = _cttp_creq_ip(ceq_u->ipf_w); + + ceq_u->sat_e = u3_csat_ripe; + _cttp_creq_connect(ceq_u); + } + + free(adr_u); + uv_freeaddrinfo(aif_u); +} + +/* _cttp_creq_resolve(): resolve hostname to IP address +*/ +static void +_cttp_creq_resolve(u3_creq* ceq_u) +{ + c3_assert(u3_csat_addr == ceq_u->sat_e); + c3_assert(ceq_u->hot_c); + + uv_getaddrinfo_t* adr_u = c3_malloc(sizeof(*adr_u)); + adr_u->data = ceq_u; + + struct addrinfo hin_u; + memset(&hin_u, 0, sizeof(struct addrinfo)); + + hin_u.ai_family = PF_INET; + hin_u.ai_socktype = SOCK_STREAM; + hin_u.ai_protocol = IPPROTO_TCP; + + // XX is this necessary? + c3_c* por_c = ceq_u->por_c ? ceq_u->por_c : + ( c3y == ceq_u->sec ) ? "443" : "80"; + + c3_i sas_i; + + if ( 0 != (sas_i = uv_getaddrinfo(u3L, adr_u, _cttp_creq_resolve_cb, + ceq_u->hot_c, por_c, &hin_u)) ) { + _cttp_creq_fail(ceq_u, uv_strerror(sas_i)); + } +} + +/* _cttp_creq_start(): start a request +*/ +static void +_cttp_creq_start(u3_creq* ceq_u) +{ + if ( ceq_u->ipf_c ) { + ceq_u->sat_e = u3_csat_ripe; + _cttp_creq_connect(ceq_u); + } else { + ceq_u->sat_e = u3_csat_addr; + _cttp_creq_resolve(ceq_u); + } +} + +/* _cttp_init_tls: initialize OpenSSL context +*/ +static SSL_CTX* +_cttp_init_tls() +{ + // XX require 1.1.0 and use TLS_client_method() + SSL_CTX* tls_u = SSL_CTX_new(SSLv23_client_method()); + // XX use SSL_CTX_set_max_proto_version() and SSL_CTX_set_min_proto_version() + SSL_CTX_set_options(tls_u, SSL_OP_NO_SSLv2 | + SSL_OP_NO_SSLv3 | + // SSL_OP_NO_TLSv1 | // XX test + SSL_OP_NO_COMPRESSION); + + SSL_CTX_set_verify(tls_u, SSL_VERIFY_PEER, 0); + SSL_CTX_set_default_verify_paths(tls_u); + SSL_CTX_set_session_cache_mode(tls_u, SSL_SESS_CACHE_OFF); + SSL_CTX_set_cipher_list(tls_u, + "ECDH+AESGCM:DH+AESGCM:ECDH+AES256:DH+AES256:" + "ECDH+AES128:DH+AES:ECDH+3DES:DH+3DES:RSA+AESGCM:" + "RSA+AES:RSA+3DES:!aNULL:!MD5:!DSS"); + + return tls_u; +} + +/* _cttp_init_h2o: initialize h2o client ctx and timeout +*/ +static h2o_http1client_ctx_t* +_cttp_init_h2o() +{ + h2o_timeout_t* tim_u = c3_malloc(sizeof(*tim_u)); + + h2o_timeout_init(u3L, tim_u, 300 * 1000); + + h2o_http1client_ctx_t* ctx_u = c3_calloc(sizeof(*ctx_u)); + ctx_u->loop = u3L; + ctx_u->io_timeout = tim_u; + + return ctx_u; +}; + +/* u3_cttp_ef_thus(): send %thus effect (outgoing request) to cttp. +*/ +void +u3_cttp_ef_thus(c3_l num_l, + u3_noun cuq) +{ + u3_creq* ceq_u; + + if ( u3_nul == cuq ) { + ceq_u =_cttp_creq_find(num_l); + + if ( ceq_u ) { + _cttp_creq_quit(ceq_u); + } + } + else { + ceq_u = _cttp_creq_new(num_l, u3k(u3t(cuq))); + _cttp_creq_start(ceq_u); + } + u3z(cuq); +} + +/* u3_cttp_io_init(): initialize http client I/O. +*/ +void +u3_cttp_io_init() +{ + u3_Host.ctp_u.tls_u = _cttp_init_tls(); + u3_Host.ctp_u.ctx_u = _cttp_init_h2o(); + u3_Host.ctp_u.ctx_u->ssl_ctx = u3_Host.ctp_u.tls_u; + u3_Host.ctp_u.ceq_u = 0; +} + +/* u3_cttp_io_exit(): shut down cttp. +*/ +void +u3_cttp_io_exit(void) +{ + SSL_CTX_free(u3_Host.ctp_u.tls_u); + free(u3_Host.ctp_u.ctx_u->io_timeout); + free(u3_Host.ctp_u.ctx_u); +} diff --git a/pkg/hs/vere/notes/c/daemon.c b/pkg/hs/vere/notes/c/daemon.c new file mode 100644 index 000000000..293f9c6c9 --- /dev/null +++ b/pkg/hs/vere/notes/c/daemon.c @@ -0,0 +1,735 @@ +/* vere/main.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#define U3_GLOBAL +#define C3_GLOBAL +#include "all.h" +#include "vere/vere.h" + +/* Require unsigned char + */ +STATIC_ASSERT(( 0 == CHAR_MIN && UCHAR_MAX == CHAR_MAX ), + "unsigned char required"); + +/* _main_readw(): parse a word from a string. +*/ +static u3_noun +_main_readw(const c3_c* str_c, c3_w max_w, c3_w* out_w) +{ + c3_c* end_c; + c3_w par_w = strtoul(str_c, &end_c, 0); + + if ( *str_c != '\0' && *end_c == '\0' && par_w < max_w ) { + *out_w = par_w; + return c3y; + } + else return c3n; +} + +/* _main_presig(): prefix optional sig. +*/ +c3_c* +_main_presig(c3_c* txt_c) +{ + c3_c* new_c = malloc(2 + strlen(txt_c)); + + if ( '~' == *txt_c ) { + strcpy(new_c, txt_c); + } else { + new_c[0] = '~'; + strcpy(new_c + 1, txt_c); + } + return new_c; +} + +/* _main_getopt(): extract option map from command line. +*/ +static u3_noun +_main_getopt(c3_i argc, c3_c** argv) +{ + c3_i ch_i; + c3_w arg_w; + + u3_Host.ops_u.abo = c3n; + u3_Host.ops_u.bat = c3n; + u3_Host.ops_u.can = c3n; + u3_Host.ops_u.dem = c3n; + u3_Host.ops_u.dry = c3n; + u3_Host.ops_u.etn = c3n; + u3_Host.ops_u.gab = c3n; + u3_Host.ops_u.git = c3n; + + // always disable hashboard + // XX temporary, remove once hashes are added + // + u3_Host.ops_u.has = c3y; + + u3_Host.ops_u.net = c3y; + u3_Host.ops_u.nuu = c3n; + u3_Host.ops_u.pro = c3n; + u3_Host.ops_u.qui = c3n; + u3_Host.ops_u.rep = c3n; + u3_Host.ops_u.tex = c3n; + u3_Host.ops_u.tra = c3n; + u3_Host.ops_u.veb = c3n; + u3_Host.ops_u.kno_w = DefaultKernel; + + while ( -1 != (ch_i=getopt(argc, argv, + "G:J:B:K:A:H:w:u:e:E:f:F:k:m:p:LjabcCdgqstvxPDRS")) ) + { + switch ( ch_i ) { + case 'J': { + u3_Host.ops_u.lit_c = strdup(optarg); + break; + } + case 'B': { + u3_Host.ops_u.pil_c = strdup(optarg); + break; + } + case 'G': { + u3_Host.ops_u.gen_c = strdup(optarg); + break; + } + case 'A': { + u3_Host.ops_u.arv_c = strdup(optarg); + break; + } + case 'H': { + u3_Host.ops_u.dns_c = strdup(optarg); + break; + } + case 'e': { + u3_Host.ops_u.eth_c = strdup(optarg); + break; + } + case 'E': { + u3_Host.ops_u.ets_c = strdup(optarg); + break; + } + case 'F': { + u3_Host.ops_u.fak_c = _main_presig(optarg); + u3_Host.ops_u.net = c3n; + break; + } + case 'w': { + u3_Host.ops_u.who_c = _main_presig(optarg); + u3_Host.ops_u.nuu = c3y; + break; + } + case 'u': { + u3_Host.ops_u.url_c = strdup(optarg); + break; + } + case 'x': { + u3_Host.ops_u.tex = c3y; + break; + } + case 'f': { + if ( c3n == _main_readw(optarg, 100, &u3_Host.ops_u.fuz_w) ) { + return c3n; + } + break; + } + case 'K': { + if ( c3n == _main_readw(optarg, 256, &u3_Host.ops_u.kno_w) ) { + return c3n; + } + break; + } + case 'k': { + u3_Host.ops_u.key_c = strdup(optarg); + break; + } + case 'm': { + u3_Host.ops_u.sap_c = strdup(optarg); + break; + } + case 'p': { + if ( c3n == _main_readw(optarg, 65536, &arg_w) ) { + return c3n; + } else u3_Host.ops_u.por_s = arg_w; + break; + } + case 'R': { + u3_Host.ops_u.rep = c3y; + return c3y; + } + case 'L': { u3_Host.ops_u.net = c3n; break; } + case 'j': { u3_Host.ops_u.tra = c3y; break; } + case 'a': { u3_Host.ops_u.abo = c3y; break; } + case 'b': { u3_Host.ops_u.bat = c3y; break; } + case 'c': { u3_Host.ops_u.nuu = c3y; break; } + case 'C': { u3_Host.ops_u.can = c3y; break; } + case 'd': { u3_Host.ops_u.dem = c3y; break; } + case 'g': { u3_Host.ops_u.gab = c3y; break; } + case 'P': { u3_Host.ops_u.pro = c3y; break; } + case 'D': { u3_Host.ops_u.dry = c3y; break; } + case 'q': { u3_Host.ops_u.qui = c3y; break; } + case 'v': { u3_Host.ops_u.veb = c3y; break; } + case 's': { u3_Host.ops_u.git = c3y; break; } + case 'S': { u3_Host.ops_u.has = c3y; break; } + case 't': { u3_Host.ops_u.etn = c3y; break; } + case '?': default: { + return c3n; + } + } + } + +#if defined(U3_OS_bsd) + if (u3_Host.ops_u.pro == c3y) { + fprintf(stderr, "profiling isn't yet supported on BSD\r\n"); + return c3n; + } +#endif + + if ( 0 != u3_Host.ops_u.fak_c ) { + if ( 28 < strlen(u3_Host.ops_u.fak_c) ) { + fprintf(stderr, "fake comets are disallowed\r\n"); + return c3n; + } + + u3_Host.ops_u.who_c = strdup(u3_Host.ops_u.fak_c); + u3_Host.ops_u.has = c3y; /* no battery hashing on fake ships. */ + u3_Host.ops_u.net = c3n; /* no networking on fake ships. */ + u3_Host.ops_u.nuu = c3y; + } + + if ( argc != (optind + 1) && u3_Host.ops_u.who_c != 0 ) { + u3_Host.dir_c = strdup(1 + u3_Host.ops_u.who_c); + } + + if ( argc != (optind + 1) ) { + return u3_Host.dir_c ? c3y : c3n; + } else { + { + c3_c* ash_c; + + if ( (ash_c = strrchr(argv[optind], '/')) && (ash_c[1] == 0) ) { + *ash_c = 0; + } + } + + u3_Host.dir_c = strdup(argv[optind]); + } + + if ( c3y == u3_Host.ops_u.bat ) { + u3_Host.ops_u.dem = c3y; + u3_Host.ops_u.nuu = c3y; + } + + // make -c optional, catch invalid boot of existing pier + // + { + struct stat s; + if ( 0 != stat(u3_Host.dir_c, &s) ) { + if ( c3n == u3_Host.ops_u.nuu ) { + u3_Host.ops_u.nuu = c3y; + } + } + else if ( c3y == u3_Host.ops_u.nuu ) { + fprintf(stderr, "tried to create, but %s already exists\n", u3_Host.dir_c); + fprintf(stderr, "normal usage: %s %s\n", argv[0], u3_Host.dir_c); + exit(1); + } + } + + c3_t imp_t = ((0 != u3_Host.ops_u.who_c) && + (4 == strlen(u3_Host.ops_u.who_c))); + + if ( u3_Host.ops_u.gen_c != 0 && u3_Host.ops_u.nuu == c3n ) { + fprintf(stderr, "-G only makes sense when bootstrapping a new instance\n"); + return c3n; + } + + if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.who_c != 0) { + fprintf(stderr, "-w only makes sense when creating a new ship\n"); + return c3n; + } + + if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.pil_c != 0) { + fprintf(stderr, "-B only makes sense when creating a new ship\n"); + return c3n; + } + + if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.dns_c != 0) { + fprintf(stderr, "-H only makes sense when bootstrapping a new instance\n"); + return c3n; + } + + if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.pil_c != 0) { + fprintf(stderr, "-B only makes sense when bootstrapping a new instance\n"); + return c3n; + } + + if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.key_c != 0) { + fprintf(stderr, "-k only makes sense when bootstrapping a new instance\n"); + return c3n; + } + + if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.url_c != 0 ) { + fprintf(stderr, "-u only makes sense when bootstrapping a new instance\n"); + return c3n; + } + + if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.sap_c != 0 ) { + fprintf(stderr, "-m only makes sense when bootstrapping a new instance\n"); + return c3n; + } + + if ( u3_Host.ops_u.fak_c != 0 && u3_Host.ops_u.sap_c != 0 ) { + fprintf(stderr, "-m and -F cannot be used together\n"); + return c3n; + } + + if ( u3_Host.ops_u.ets_c != 0 && u3_Host.ops_u.sap_c != 0 ) { + fprintf(stderr, "-m and -E cannot be used together\n"); + return c3n; + } + if ( u3_Host.ops_u.can == c3y && u3_Host.ops_u.sap_c != 0 ) { + fprintf(stderr, "-m and -C cannot be used together\n"); + return c3n; + } + if ( u3_Host.ops_u.can == c3y && u3_Host.ops_u.ets_c != 0 ) { + fprintf(stderr, "-C and -E cannot be used together\n"); + return c3n; + } + + if ( u3_Host.ops_u.eth_c == 0 && imp_t ) { + u3_Host.ops_u.eth_c = "http://eth-mainnet.urbit.org:8545"; + } + + if ( u3_Host.ops_u.sap_c == 0 && u3_Host.ops_u.can == c3n ) { + + u3_Host.ops_u.sap_c = + "https://bootstrap.urbit.org/urbit-" URBIT_VERSION ".snap"; + } + + if ( u3_Host.ops_u.url_c != 0 && u3_Host.ops_u.pil_c != 0 ) { + fprintf(stderr, "-B and -u cannot be used together\n"); + return c3n; + } + else if ( u3_Host.ops_u.nuu == c3y + && u3_Host.ops_u.url_c == 0 + && u3_Host.ops_u.git == c3n ) { + u3_Host.ops_u.url_c = + "https://bootstrap.urbit.org/urbit-" URBIT_VERSION ".pill"; + } + else if ( u3_Host.ops_u.nuu == c3y + && u3_Host.ops_u.url_c == 0 + && u3_Host.ops_u.arv_c == 0 ) { + + fprintf(stderr, "-s only makes sense with -A\n"); + return c3n; + } + + if ( u3_Host.ops_u.pil_c != 0 ) { + struct stat s; + if ( stat(u3_Host.ops_u.pil_c, &s) != 0 ) { + fprintf(stderr, "pill %s not found\n", u3_Host.ops_u.pil_c); + return c3n; + } + } + + if ( u3_Host.ops_u.key_c != 0 ) { + struct stat s; + if ( stat(u3_Host.ops_u.key_c, &s) != 0 ) { + fprintf(stderr, "keyfile %s not found\n", u3_Host.ops_u.key_c); + return c3n; + } + } + + return c3y; +} + +/* u3_ve_usage(): print usage and exit. +*/ +static void +u3_ve_usage(c3_i argc, c3_c** argv) +{ + c3_c *use_c[] = { + "Urbit: a personal server operating function\n", + "https://urbit.org\n", + "Version " URBIT_VERSION "\n", + "\n", + "Usage: %s [options...] ship_name\n", + "where ship_name is a @p phonetic representation of an urbit address\n", + "without the leading '~', and options is some subset of the following:\n", + "\n", + // XX find a way to re-enable + // "-A dir Use dir for initial galaxy sync\n", + "-B pill Bootstrap from this pill\n", + "-b Batch create\n", + "-c pier Create a new urbit in pier/\n", + "-D Recompute from events\n", + "-d Daemon mode\n", + "-e url Ethereum gateway\n", + "-F ship Fake keys; also disables networking\n", + "-f Fuzz testing\n", + "-g Set GC flag\n", + "-j file Create json trace file\n", + "-K stage Start at Hoon kernel version stage\n", + "-k keys Private key file\n", + "-L local networking only\n", + "-P Profiling\n", + "-p ames_port Set the ames port to bind to\n", + "-q Quiet\n", + "-R Report urbit build info\n", + "-S Disable battery hashing\n", + // XX find a way to re-enable + // "-s Pill URL from arvo git hash\n", + "-u url URL from which to download pill\n", + "-v Verbose\n", + "-w name Boot as ~name\n", + "-x Exit immediately\n", + "\n", + "Development Usage:\n", + " To create a development ship, use a fakezod:\n", + " %s -F zod -A /path/to/arvo/folder -B /path/to/pill -c zod\n", + "\n", + " For more information about developing on urbit, see:\n", + " https://github.com/urbit/urbit/blob/master/CONTRIBUTING.md\n", + "\n", + "Simple Usage: \n", + " %s -c to create a comet (anonymous urbit)\n", + " %s -w -k if you own a planet\n", + " %s to restart an existing urbit\n", + 0 + }; + + c3_i i; + for ( i=0; use_c[i]; i++ ) { + fprintf(stderr, use_c[i], argv[0]); + } + exit(1); +} + +#if 0 +/* u3_ve_panic(): panic and exit. +*/ +static void +u3_ve_panic(c3_i argc, c3_c** argv) +{ + fprintf(stderr, "%s: gross system failure\n", argv[0]); + exit(1); +} +#endif + +/* u3_ve_sysopt(): apply option map to system state. +*/ +static void +u3_ve_sysopt() +{ + u3_Local = strdup(u3_Host.dir_c); +} + +static void +report(void) +{ + printf("urbit %s\n", URBIT_VERSION); + printf("---------\nLibraries\n---------\n"); + printf("gmp: %s\n", gmp_version); + printf("sigsegv: %d.%d\n", + (libsigsegv_version >> 8) & 0xff, + libsigsegv_version & 0xff); + printf("openssl: %s\n", SSLeay_version(SSLEAY_VERSION)); + printf("curses: %s\n", curses_version()); + printf("libuv: %s\n", uv_version_string()); + printf("libh2o: %d.%d.%d\n", + H2O_LIBRARY_VERSION_MAJOR, + H2O_LIBRARY_VERSION_MINOR, + H2O_LIBRARY_VERSION_PATCH); + printf("lmdb: %d.%d.%d\n", + MDB_VERSION_MAJOR, + MDB_VERSION_MINOR, + MDB_VERSION_PATCH); + printf("curl: %d.%d.%d\n", + LIBCURL_VERSION_MAJOR, + LIBCURL_VERSION_MINOR, + LIBCURL_VERSION_PATCH); + printf("argon2: 0x%x\n", ARGON2_VERSION_NUMBER); +} + +static void +_stop_exit(c3_i int_i) +{ + // explicit fprintf to avoid allocation in u3l_log + // + fprintf(stderr, "\r\n[received keyboard stop signal, exiting]\r\n"); + u3_daemon_bail(); +} + +/* + This is set to the the write-end of a pipe when Urbit is started in + daemon mode. It's meant to be used as a signal to the parent process + that the child process has finished booting. +*/ +static c3_i _child_process_booted_signal_fd = -1; + +/* + This should be called whenever the ship has been booted enough to + handle commands from automation code. Specifically, once the Eyre's + `chis` interface is up and running. + + In daemon mode, this signals to the parent process that it can + exit. Otherwise, it does nothing. + + Once we've sent a signal with `write`, we close the file descriptor + and overwrite the global to make it impossible to accidentally do + this twice. +*/ +static void _on_boot_completed_cb() { + c3_c buf[2] = {0,0}; + + if ( -1 == _child_process_booted_signal_fd ) { + return; + } + + if ( 0 == write(_child_process_booted_signal_fd, buf, 1) ) { + c3_assert(!"_on_boot_completed_cb: Can't write to parent FD"); + } + + close(_child_process_booted_signal_fd); + _child_process_booted_signal_fd = -1; +} + +/* + In daemon mode, run the urbit as a background process, but don't + exit from the parent process until the ship is finished booting. + + We use a pipe to communicate between the child and the parent. The + parent waits for the child to write something to the pipe and + then exits. If the pipe is closed with nothing written to it, get + the exit status from the child process and also exit with that status. + + We want the child to write to the pipe once it's booted, so we put + `_on_boot_completed_cb` into `u3_Host.bot_f`, which is NULL in + non-daemon mode. That gets called once the `chis` service is + available. + + In both processes, we are good fork() citizens, and close all unused + file descriptors. Closing `pipefd[1]` in the parent process is + especially important, since the pipe needs to be closed if the child + process dies. When the pipe is closed, the read fails, and that's + how we know that something went wrong. + + There are some edge cases around `WEXITSTATUS` that are not handled + here, but I don't think it matters. +*/ +static void +_fork_into_background_process() +{ + c3_i pipefd[2]; + + if ( 0 != pipe(pipefd) ) { + c3_assert(!"Failed to create pipe"); + } + + pid_t childpid = fork(); + + if ( 0 == childpid ) { + close(pipefd[0]); + _child_process_booted_signal_fd = pipefd[1]; + u3_Host.bot_f = _on_boot_completed_cb; + return; + } + + close(pipefd[1]); + close(0); + close(1); + close(2); + + c3_c buf[2] = {0,0}; + if ( 1 == read(pipefd[0], buf, 1) ) { + exit(0); + } + + c3_i status; + wait(&status); + exit(WEXITSTATUS(status)); +} + +c3_i +main(c3_i argc, + c3_c** argv) +{ + // Parse options. + // + if ( c3n == _main_getopt(argc, argv) ) { + u3_ve_usage(argc, argv); + return 1; + } + + // Set `u3_Host.wrk_c` to the worker executable path. + c3_i worker_exe_len = 1 + strlen(argv[0]) + strlen("-worker"); + u3_Host.wrk_c = c3_malloc(worker_exe_len); + snprintf(u3_Host.wrk_c, worker_exe_len, "%s-worker", argv[0]); + + // Set TERMINFO_DIRS environment variable + c3_i terminfo_len = 1 + strlen(argv[0]) + strlen("-terminfo"); + c3_c terminfo_dir[terminfo_len]; + snprintf(terminfo_dir, terminfo_len, "%s-terminfo", argv[0]); + setenv("TERMINFO_DIRS", terminfo_dir, 1); + + if ( c3y == u3_Host.ops_u.dem ) { + _fork_into_background_process(); + } + + if ( c3y == u3_Host.ops_u.rep ) { + report(); + return 0; + } + +#if 0 + if ( 0 == getuid() ) { + chroot(u3_Host.dir_c); + u3_Host.dir_c = "/"; + } +#endif + u3_ve_sysopt(); + + // Block profiling signal, which should be delivered to exactly one thread. + // + // XX review, may be unnecessary due to similar in u3m_init() + // + if ( _(u3_Host.ops_u.pro) ) { + sigset_t set; + + sigemptyset(&set); + sigaddset(&set, SIGPROF); + if ( 0 != pthread_sigmask(SIG_BLOCK, &set, NULL) ) { + u3l_log("boot: thread mask SIGPROF: %s\r\n", strerror(errno)); + exit(1); + } + } + + // Handle SIGTSTP as if it was SIGTERM. + // + // Configured here using signal() so as to be immediately available. + // + signal(SIGTSTP, _stop_exit); + + printf("~\n"); + // printf("welcome.\n"); + printf("urbit %s\n", URBIT_VERSION); + + // prints the absolute path of the pier + // + c3_c* abs_c = realpath(u3_Host.dir_c, 0); + + // if the ship is being booted, we use realpath(). Otherwise, we use getcwd() + // with a memory-allocation loop + // + if (abs_c == NULL) { + c3_i mprint_i = 1000; + abs_c = c3_malloc(mprint_i); + + // allocates more memory as needed if the path is too large + // + while ( abs_c != getcwd(abs_c, mprint_i) ) { + free(abs_c); + mprint_i *= 2; + abs_c = c3_malloc(mprint_i); + } + printf("boot: home is %s/%s\n", abs_c, u3_Host.dir_c); + free(abs_c); + } else { + printf("boot: home is %s\n", abs_c); + free(abs_c); + } + // printf("vere: hostname is %s\n", u3_Host.ops_u.nam_c); + + if ( c3y == u3_Host.ops_u.dem && c3n == u3_Host.ops_u.bat ) { + printf("boot: running as daemon\n"); + } + + // Seed prng. Don't panic -- just for fuzz testing. + // + srand(getpid()); + + // Instantiate process globals. + { + /* Boot the image and checkpoint. Set flags. + */ + { + /* Set pier directory. + */ + u3C.dir_c = u3_Host.dir_c; + + /* Logging that doesn't interfere with console output. + */ + u3C.stderr_log_f = u3_term_io_log; + + /* Set GC flag. + */ + if ( _(u3_Host.ops_u.gab) ) { + u3C.wag_w |= u3o_debug_ram; + } + + /* Set profile flag. + */ + if ( _(u3_Host.ops_u.pro) ) { + u3C.wag_w |= u3o_debug_cpu; + } + + /* Set verbose flag. + */ + if ( _(u3_Host.ops_u.veb) ) { + u3C.wag_w |= u3o_verbose; + } + + /* Set quiet flag. + */ + if ( _(u3_Host.ops_u.qui) ) { + u3C.wag_w |= u3o_quiet; + } + + /* Set dry-run flag. + */ + if ( _(u3_Host.ops_u.dry) ) { + u3C.wag_w |= u3o_dryrun; + } + + /* Set hashboard flag + */ + if ( _(u3_Host.ops_u.has) ) { + u3C.wag_w |= u3o_hashless; + } + + /* Set tracing flag + */ + if ( _(u3_Host.ops_u.tra) ) { + u3C.wag_w |= u3o_trace; + u3_Host.tra_u.nid_w = 0; + u3_Host.tra_u.fil_u = NULL; + u3_Host.tra_u.con_w = 0; + u3_Host.tra_u.fun_w = 0; + } + } + + /* Initialize OpenSSL for client and server + */ + SSL_library_init(); + SSL_load_error_strings(); + + u3_daemon_commence(); + } + return 0; +} diff --git a/pkg/hs/vere/notes/c/dawn.c b/pkg/hs/vere/notes/c/dawn.c new file mode 100644 index 000000000..80a3856aa --- /dev/null +++ b/pkg/hs/vere/notes/c/dawn.c @@ -0,0 +1,525 @@ +/* vere/dawn.c +** +** ethereum-integrated pre-boot validation +*/ +#include +#include + +#include "all.h" +#include "vere/vere.h" + +/* _dawn_oct_to_buf(): +octs to uv_buf_t +*/ +static uv_buf_t +_dawn_oct_to_buf(u3_noun oct) +{ + if ( c3n == u3a_is_cat(u3h(oct)) ) { + exit(1); + } + + c3_w len_w = u3h(oct); + c3_y* buf_y = c3_malloc(1 + len_w); + buf_y[len_w] = 0; + + u3r_bytes(0, len_w, buf_y, u3t(oct)); + + u3z(oct); + return uv_buf_init((void*)buf_y, len_w); +} + +/* _dawn_buf_to_oct(): uv_buf_t to +octs +*/ +static u3_noun +_dawn_buf_to_oct(uv_buf_t buf_u) +{ + u3_noun len = u3i_words(1, (c3_w*)&buf_u.len); + + if ( c3n == u3a_is_cat(len) ) { + exit(1); + } + + return u3nc(len, u3i_bytes(buf_u.len, (const c3_y*)buf_u.base)); +} + + +/* _dawn_curl_alloc(): allocate a response buffer for curl +*/ +static size_t +_dawn_curl_alloc(void* dat_v, size_t uni_t, size_t mem_t, uv_buf_t* buf_u) +{ + size_t siz_t = uni_t * mem_t; + buf_u->base = c3_realloc(buf_u->base, 1 + siz_t + buf_u->len); + + memcpy(buf_u->base + buf_u->len, dat_v, siz_t); + buf_u->len += siz_t; + buf_u->base[buf_u->len] = 0; + + return siz_t; +} + +/* _dawn_post_json(): POST JSON to url_c +*/ +static uv_buf_t +_dawn_post_json(c3_c* url_c, uv_buf_t lod_u) +{ + CURL *curl; + CURLcode result; + long cod_l; + struct curl_slist* hed_u = 0; + + uv_buf_t buf_u = uv_buf_init(c3_malloc(1), 0); + + if ( !(curl = curl_easy_init()) ) { + u3l_log("failed to initialize libcurl\n"); + exit(1); + } + + hed_u = curl_slist_append(hed_u, "Accept: application/json"); + hed_u = curl_slist_append(hed_u, "Content-Type: application/json"); + hed_u = curl_slist_append(hed_u, "charsets: utf-8"); + + // XX require TLS, pin default cert? + + curl_easy_setopt(curl, CURLOPT_URL, url_c); + curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, _dawn_curl_alloc); + curl_easy_setopt(curl, CURLOPT_WRITEDATA, (void*)&buf_u); + curl_easy_setopt(curl, CURLOPT_HTTPHEADER, hed_u); + + // note: must be terminated! + curl_easy_setopt(curl, CURLOPT_POSTFIELDS, lod_u.base); + + result = curl_easy_perform(curl); + curl_easy_getinfo(curl, CURLINFO_RESPONSE_CODE, &cod_l); + + // XX retry? + if ( CURLE_OK != result ) { + u3l_log("failed to fetch %s: %s\n", + url_c, curl_easy_strerror(result)); + exit(1); + } + if ( 300 <= cod_l ) { + u3l_log("error fetching %s: HTTP %ld\n", url_c, cod_l); + exit(1); + } + + curl_easy_cleanup(curl); + curl_slist_free_all(hed_u); + + return buf_u; +} + +/* _dawn_get_jam(): GET a jammed noun from url_c +*/ +static u3_noun +_dawn_get_jam(c3_c* url_c) +{ + CURL *curl; + CURLcode result; + long cod_l; + + uv_buf_t buf_u = uv_buf_init(c3_malloc(1), 0); + + if ( !(curl = curl_easy_init()) ) { + u3l_log("failed to initialize libcurl\n"); + exit(1); + } + + // XX require TLS, pin default cert? + + curl_easy_setopt(curl, CURLOPT_URL, url_c); + curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, _dawn_curl_alloc); + curl_easy_setopt(curl, CURLOPT_WRITEDATA, (void*)&buf_u); + + result = curl_easy_perform(curl); + curl_easy_getinfo(curl, CURLINFO_RESPONSE_CODE, &cod_l); + + // XX retry? + if ( CURLE_OK != result ) { + u3l_log("failed to fetch %s: %s\n", + url_c, curl_easy_strerror(result)); + exit(1); + } + if ( 300 <= cod_l ) { + u3l_log("error fetching %s: HTTP %ld\n", url_c, cod_l); + exit(1); + } + + curl_easy_cleanup(curl); + + // throw away the length from the octs + // + u3_noun octs = _dawn_buf_to_oct(buf_u); + u3_noun jammed = u3k(u3t(octs)); + u3z(octs); + + return u3ke_cue(jammed); +} + +/* _dawn_eth_rpc(): ethereum JSON RPC with request/response as +octs +*/ +static u3_noun +_dawn_eth_rpc(c3_c* url_c, u3_noun oct) +{ + return _dawn_buf_to_oct(_dawn_post_json(url_c, _dawn_oct_to_buf(oct))); +} + +/* _dawn_fail(): pre-boot validation failed +*/ +static void +_dawn_fail(u3_noun who, u3_noun rac, u3_noun sas) +{ + u3_noun how = u3dc("scot", 'p', u3k(who)); + c3_c* how_c = u3r_string(u3k(how)); + + c3_c* rac_c; + + switch (rac) { + default: c3_assert(0); + case c3__czar: { + rac_c = "galaxy"; + break; + } + case c3__king: { + rac_c = "star"; + break; + } + case c3__duke: { + rac_c = "planet"; + break; + } + case c3__earl: { + rac_c = "moon"; + break; + } + case c3__pawn: { + rac_c = "comet"; + break; + } + } + + u3l_log("boot: invalid keys for %s '%s'\r\n", rac_c, how_c); + + // XX deconstruct sas, print helpful error messages + u3m_p("pre-boot error", u3t(sas)); + + u3z(how); + free(how_c); + exit(1); +} + +/* _dawn_need_unit(): produce a value or print error and exit +*/ +static u3_noun +_dawn_need_unit(u3_noun nit, c3_c* msg_c) +{ + if ( u3_nul == nit ) { + u3l_log("%s\r\n", msg_c); + exit(1); + } + else { + u3_noun pro = u3k(u3t(nit)); + u3z(nit); + return pro; + } +} + +/* _dawn_purl(): ethereum gateway url as (unit purl) +*/ +static u3_noun +_dawn_purl(u3_noun rac) +{ + u3_noun url; + + if ( 0 == u3_Host.ops_u.eth_c ) { + if ( c3__czar == rac ) { + u3l_log("boot: galaxy requires ethereum gateway via -e\r\n"); + exit(1); + } + + url = u3_nul; + } + else { + // XX call de-purl directly + // + u3_noun par = u3v_wish("auru:de-purl:html"); + u3_noun lur = u3i_string(u3_Host.ops_u.eth_c); + u3_noun rul = u3dc("rush", u3k(lur), u3k(par)); + + if ( u3_nul == rul ) { + if ( c3__czar == rac ) { + u3l_log("boot: galaxy requires ethereum gateway via -e\r\n"); + exit(1); + } + + url = u3_nul; + } + else { + // XX revise for de-purl + // auru:de-purl:html parses to (pair user purl) + // we need (unit purl) + // + url = u3nc(u3_nul, u3k(u3t(u3t(rul)))); + } + + u3z(par); u3z(lur); u3z(rul); + } + + return url; +} + +/* _dawn_turf(): override contract domains with -H +*/ +static u3_noun +_dawn_turf(c3_c* dns_c) +{ + u3_noun tuf; + + u3_noun par = u3v_wish("thos:de-purl:html"); + u3_noun dns = u3i_string(dns_c); + u3_noun rul = u3dc("rush", u3k(dns), u3k(par)); + + if ( (u3_nul == rul) || (c3n == u3h(u3t(rul))) ) { + u3l_log("boot: invalid domain specified with -H %s\r\n", dns_c); + exit(1); + } + else { + u3l_log("boot: overriding network domains with %s\r\n", dns_c); + u3_noun dom = u3t(u3t(rul)); + tuf = u3nc(u3k(dom), u3_nul); + } + + u3z(par); u3z(dns); u3z(rul); + + return tuf; +} + +/* u3_dawn_vent(): validated boot event +*/ +u3_noun +u3_dawn_vent(u3_noun seed) +{ + u3_noun url, bok, pon, zar, tuf, sap; + + u3_noun ship = u3h(seed); + u3_noun rank = u3do("clan:title", u3k(ship)); + + // load snapshot from file + // + if ( 0 != u3_Host.ops_u.ets_c ) { + u3l_log("boot: loading azimuth snapshot\r\n"); + u3_noun raw_snap = u3ke_cue(u3m_file(u3_Host.ops_u.ets_c)); + sap = u3nc(u3_nul, raw_snap); + } + // load snapshot from HTTP URL + // + else if ( 0 != u3_Host.ops_u.sap_c ) { + u3l_log("boot: downloading azimuth snapshot from %s\r\n", + u3_Host.ops_u.sap_c); + u3_noun raw_snap = _dawn_get_jam(u3_Host.ops_u.sap_c); + sap = u3nc(u3_nul, raw_snap); + } + // no snapshot + // + else { + u3l_log("boot: no azimuth snapshot specified\n"); + sap = u3_nul; + } + + url = _dawn_purl(rank); + + // XX require https? + // + c3_c* url_c = ( 0 != u3_Host.ops_u.eth_c ) ? + u3_Host.ops_u.eth_c : + "https://mainnet.infura.io/v3/196a7f37c7d54211b4a07904ec73ad87"; + + // pin block number + // + if ( c3y == u3_Host.ops_u.etn ) { + u3l_log("boot: extracting block from snapshot\r\n"); + + bok = _dawn_need_unit(u3do("bloq:snap:dawn", u3k(u3t(sap))), + "boot: failed to extract " + "block from snapshot"); + } + else { + u3l_log("boot: retrieving latest block\r\n"); + + u3_noun oct = u3v_wish("bloq:give:dawn"); + u3_noun kob = _dawn_eth_rpc(url_c, u3k(oct)); + + bok = _dawn_need_unit(u3do("bloq:take:dawn", u3k(kob)), + "boot: block retrieval failed"); + u3z(oct); u3z(kob); + } + + { + // +point:azimuth: on-chain state + // + u3_noun pot; + + if ( c3y == u3_Host.ops_u.etn ) { + u3l_log("boot: extracting public keys from snapshot\r\n"); + + pot = _dawn_need_unit(u3dc("point:snap:dawn", u3k(ship), u3k(u3t(sap))), + "boot: failed to extract " + "public keys from snapshot"); + } + else if ( c3__pawn == rank ) { + // irrelevant, just bunt +point + // + pot = u3v_wish("*point:azimuth"); + } + else { + u3_noun who; + + if ( c3__earl == rank ) { + who = u3do("^sein:title", u3k(ship)); + + { + u3_noun seg = u3dc("scot", 'p', u3k(who)); + c3_c* seg_c = u3r_string(seg); + + u3l_log("boot: retrieving %s's public keys (for %s)\r\n", + seg_c, u3_Host.ops_u.who_c); + free(seg_c); + u3z(seg); + } + } + else { + who = u3k(ship); + u3l_log("boot: retrieving %s's public keys\r\n", + u3_Host.ops_u.who_c); + } + + { + u3_noun oct = u3dc("point:give:dawn", u3k(bok), u3k(who)); + u3_noun luh = _dawn_eth_rpc(url_c, u3k(oct)); + + pot = _dawn_need_unit(u3dc("point:take:dawn", u3k(ship), u3k(luh)), + "boot: failed to retrieve public keys"); + u3z(oct); u3z(luh); + } + + u3z(who); + } + + // +live:dawn: network state + // XX actually make request + // + u3_noun liv = u3_nul; + // u3_noun liv = _dawn_get_json(parent, /some/url) + + u3l_log("boot: verifying keys\r\n"); + + // (each sponsor=ship error=@tas) + // + u3_noun sas = u3dt("veri:dawn", u3k(seed), u3k(pot), u3k(liv)); + + if ( c3n == u3h(sas) ) { + // bails, won't return + _dawn_fail(ship, rank, sas); + return u3_none; + } + + // ship: sponsor + // produced by +veri:dawn to avoid coupling to +point structure + // XX reconsider + // + pon = u3k(u3t(sas)); + + u3z(pot); u3z(liv); u3z(sas); + } + + // (map ship [=life =pass]): galaxy table + // + if ( c3y == u3_Host.ops_u.etn ) { + u3l_log("boot: extracting galaxy table from snapshot\r\n"); + + zar = _dawn_need_unit(u3do("czar:snap:dawn", u3k(u3t(sap))), + "boot: failed to extract " + "galaxy table from snapshot"); + } + else { + u3l_log("boot: retrieving galaxy table\r\n"); + + u3_noun oct = u3do("czar:give:dawn", u3k(bok)); + u3_noun raz = _dawn_eth_rpc(url_c, u3k(oct)); + + zar = _dawn_need_unit(u3do("czar:take:dawn", u3k(raz)), + "boot: failed to retrieve galaxy table"); + u3z(oct); u3z(raz); + } + + // (list turf): ames domains + // + if ( 0 != u3_Host.ops_u.dns_c ) { + tuf = _dawn_turf(u3_Host.ops_u.dns_c); + } + else if ( c3y == u3_Host.ops_u.etn ) { + u3l_log("boot: extracting network domains from snapshot\r\n"); + + tuf = _dawn_need_unit(u3do("turf:snap:dawn", u3k(u3t(sap))), + "boot: failed to extract " + "network domains from snapshot"); + } + else { + u3l_log("boot: retrieving network domains\r\n"); + + u3_noun oct = u3do("turf:give:dawn", u3k(bok)); + u3_noun fut = _dawn_eth_rpc(url_c, u3k(oct)); + + tuf = _dawn_need_unit(u3do("turf:take:dawn", u3k(fut)), + "boot: failed to retrieve network domains"); + u3z(oct); u3z(fut); + } + + u3z(rank); + + // [%dawn seed sponsor galaxies domains block eth-url snap] + // + return u3nc(c3__dawn, u3nq(seed, pon, zar, u3nq(tuf, bok, url, sap))); +} + +/* _dawn_come(): mine a comet under a list of stars +*/ +static u3_noun +_dawn_come(u3_noun stars) +{ + u3_noun seed; + { + c3_w eny_w[16]; + u3_noun eny; + + c3_rand(eny_w); + eny = u3i_words(16, eny_w); + + u3l_log("boot: mining a comet. May take up to an hour.\r\n"); + u3l_log("If you want to boot faster, get an Azimuth point.\r\n"); + + seed = u3dc("come:dawn", u3k(stars), u3k(eny)); + u3z(eny); + } + + { + u3_noun who = u3dc("scot", 'p', u3k(u3h(seed))); + c3_c* who_c = u3r_string(who); + + u3l_log("boot: found comet %s\r\n", who_c); + free(who_c); + u3z(who); + } + + u3z(stars); + + return seed; +} + +/* u3_dawn_come(): mine a comet under a list of stars we download +*/ +u3_noun +u3_dawn_come() +{ + return _dawn_come( + _dawn_get_jam("https://bootstrap.urbit.org/comet-stars.jam")); +} diff --git a/pkg/hs/vere/notes/c/foil.c b/pkg/hs/vere/notes/c/foil.c new file mode 100644 index 000000000..4bd4a401a --- /dev/null +++ b/pkg/hs/vere/notes/c/foil.c @@ -0,0 +1,170 @@ +/* vere/foil.c +** +** This file is in the public domain. +*/ + +#include "all.h" + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "vere/vere.h" + + /* assumptions: + ** all measurements are in chubs (double-words, c3_d, uint64_t). + ** little-endian addressing is ASSUMED. + ** + ** framing: + ** the last two chubs of a frame: + ** + ** { + ** 64-bit frame length + ** { + ** (high 32 bits) mug of frame + ** (low 32 bits) mug of current address + ** } + ** } + ** + ** we can scan for one of these frames with very low probability + ** of a false positive. we always write to and read from the end + ** of a file. a frame position points to its end. + ** + ** protocol: + ** once the callback is called, all results are fully fsynced. + ** all callbacks are optional and can be passed 0. + */ + +/* _foil_fail(): fail with error. +*/ +static void +_foil_fail(const c3_c* why_c, c3_i err_i) +{ + if ( err_i ) { + u3l_log("%s: error: %s\r\n", why_c, uv_strerror(err_i)); + c3_assert(0); + } else { + u3l_log("%s: file error\r\n", why_c); + } + exit(1); +} + +/* _foil_close(): close file, blockingly. +*/ +static void +_foil_close(uv_file fil_f) +{ + c3_i err_i; + uv_fs_t ruq_u; + + if ( 0 != (err_i = uv_fs_close(u3L, &ruq_u, fil_f, 0)) ) { + _foil_fail("uv_fs_close", err_i); + } +} + +/* _foil_path(): allocate path. +*/ +static c3_c* +_foil_path(u3_dire* dir_u, + const c3_c* nam_c) +{ + c3_w len_w = strlen(dir_u->pax_c); + c3_c* pax_c; + + pax_c = c3_malloc(1 + len_w + 1 + strlen(nam_c)); + strcpy(pax_c, dir_u->pax_c); + pax_c[len_w] = '/'; + strcpy(pax_c + len_w + 1, nam_c); + + return pax_c; +} + +/* u3_foil_folder(): load directory, blockingly. null if nonexistent. +*/ +u3_dire* +u3_foil_folder(const c3_c* pax_c) +{ + u3_dire* dir_u; + uv_fs_t ruq_u; + uv_dirent_t den_u; + c3_i err_i; + + /* open directory, synchronously + */ + { + err_i = uv_fs_scandir(u3L, &ruq_u, pax_c, 0, 0); + + if ( err_i < 0 ) { + if ( UV_ENOENT != err_i ) { + _foil_fail(pax_c, err_i); + return 0; + } + else { + if ( 0 != (err_i = uv_fs_mkdir(u3L, &ruq_u, pax_c, 0700, 0)) ) { + _foil_fail(pax_c, err_i); + return 0; + } + else { + uv_fs_req_cleanup(&ruq_u); + return u3_foil_folder(pax_c); + } + } + } + dir_u = c3_malloc(sizeof *dir_u); + dir_u->all_u = 0; + dir_u->pax_c = c3_malloc(1 + strlen(pax_c)); + strcpy(dir_u->pax_c, pax_c); + } + + /* create entries for all files + */ + while ( UV_EOF != uv_fs_scandir_next(&ruq_u, &den_u) ) { + if ( UV_DIRENT_FILE == den_u.type ) { + u3_dent* det_u = c3_malloc(sizeof(*det_u)); + + det_u->nam_c = c3_malloc(1 + strlen(den_u.name)); + strcpy(det_u->nam_c, den_u.name); + + det_u->nex_u = dir_u->all_u; + dir_u->all_u = det_u; + } + } + + /* clean up request + */ + { + uv_fs_req_cleanup(&ruq_u); + } + + /* open directory file for reading, to fsync + */ + { + if ( 0 > (err_i = uv_fs_open(u3L, + &ruq_u, + pax_c, + O_RDONLY, + 0600, + 0)) ) + { + _foil_fail("open directory", err_i); + return 0; + } + dir_u->fil_u = ruq_u.result; + + uv_fs_req_cleanup(&ruq_u); + } + return dir_u; +} diff --git a/pkg/hs/vere/notes/c/hash_tests.c b/pkg/hs/vere/notes/c/hash_tests.c new file mode 100644 index 000000000..a362fec10 --- /dev/null +++ b/pkg/hs/vere/notes/c/hash_tests.c @@ -0,0 +1,105 @@ +#include "all.h" + +/* _setup(): prepare for tests. +*/ +static void +_setup(void) +{ + u3m_init(); + u3m_pave(c3y, c3n); +} + +/* _test_mug(): spot check u3r_mug hashes. +*/ +static void +_test_mug(void) +{ + if ( 0x4d441035 != u3r_mug_string("Hello, world!") ) { + fprintf(stderr, "fail (a)\r\n"); + exit(1); + } + + if ( 0x4d441035 != u3r_mug(u3i_string("Hello, world!")) ) { + fprintf(stderr, "fail (b)\r\n"); + exit(1); + } + + if ( 0x79ff04e8 != u3r_mug_bytes(0, 0) ) { + fprintf(stderr, "fail (c)\r\n"); + exit(1); + } + + if ( 0x64dfda5c != u3r_mug(u3i_string("xxxxxxxxxxxxxxxxxxxxxxxxxxxx")) ) { + fprintf(stderr, "fail (d)\r\n"); + exit(1); + } + + if ( 0x389ca03a != u3r_mug_cell(0, 0) ) { + fprintf(stderr, "fail (e)\r\n"); + exit(1); + } + + if ( 0x389ca03a != u3r_mug_cell(1, 1) ) { + fprintf(stderr, "fail (f)\r\n"); + exit(1); + } + + if ( 0x5258a6c0 != u3r_mug_cell(0, u3qc_bex(32)) ) { + fprintf(stderr, "fail (g)\r\n"); + exit(1); + } + + if ( 0x2ad39968 != u3r_mug_cell(u3qa_dec(u3qc_bex(128)), 1) ) { + fprintf(stderr, "fail (h)\r\n"); + exit(1); + } + + { + // stick some zero bytes in a string + // + u3_noun str = u3kc_lsh(3, 1, + u3kc_mix(u3qc_bex(212), + u3i_string("abcdefjhijklmnopqrstuvwxyz"))); + + c3_w byt_w = u3r_met(3, str); + c3_w wor_w = u3r_met(5, str); + c3_y* str_y = c3_malloc(byt_w); + c3_w* str_w = c3_malloc(4 * wor_w); + c3_d str_d = 0; + + u3r_bytes(0, byt_w, str_y, str); + u3r_words(0, wor_w, str_w, str); + + str_d |= str_w[0]; + str_d |= ((c3_d)str_w[1] << 32ULL); + + if ( 0x34d08717 != u3r_mug(str) ) { + fprintf(stderr, "fail (i) (1) \r\n"); + exit(1); + } + if ( 0x34d08717 != u3r_mug_bytes(str_y, byt_w) ) { + fprintf(stderr, "fail (i) (2)\r\n"); + exit(1); + } + if ( 0x34d08717 != u3r_mug_words(str_w, wor_w) ) { + fprintf(stderr, "fail (i) (3)\r\n"); + exit(1); + } + if ( u3r_mug_words(str_w, 2) != u3r_mug_chub(str_d) ) { + fprintf(stderr, "fail (i) (4)\r\n"); + exit(1); + } + } +} + +/* main(): run all test cases. +*/ +int +main(int argc, char* argv[]) +{ + _setup(); + + _test_mug(); + + return 0; +} diff --git a/pkg/hs/vere/notes/c/hashtable_tests.c b/pkg/hs/vere/notes/c/hashtable_tests.c new file mode 100644 index 000000000..8955a000d --- /dev/null +++ b/pkg/hs/vere/notes/c/hashtable_tests.c @@ -0,0 +1,144 @@ +#include "all.h" + +static void _setup(void); +static void _test_cache_replace_value(void); +static void _test_cache_trimming(void); +static void _test_no_cache(void); +static void _test_skip_slot(void); + +// defined in noun/hashtable.c +c3_w _ch_skip_slot(c3_w mug_w, c3_w lef_w); + + +/* main(): run all test cases. +*/ +int +main(int argc, char* argv[]) +{ + _setup(); + + _test_no_cache(); + _test_skip_slot(); + _test_cache_trimming(); + _test_cache_replace_value(); + + return 0; +} + +/* _setup(): prepare for tests. +*/ +static void +_setup(void) +{ + u3m_init(); + u3m_pave(c3y, c3n); +} + +/* _test_no_cache(): test a hashtable without caching. +*/ +static void +_test_no_cache(void) +{ + c3_w i_w; + c3_w max_w = 1000; + + u3p(u3h_root) har_p = u3h_new(); + + for ( i_w = 0; i_w < max_w; i_w++ ) { + u3h_put(har_p, i_w, i_w + max_w); + } + + for ( i_w = 0; i_w < max_w; i_w++ ) { + c3_assert(i_w + max_w == u3h_get(har_p, i_w)); + } + printf("test_no_cache: ok\n"); +} + +/* _test_skip_slot(): +*/ +static void +_test_skip_slot(void) +{ + // root table + { + c3_w mug_w = 0x17 << 25; + c3_w res_w = _ch_skip_slot(mug_w, 25); + c3_assert((0x18 << 25) == res_w); + } + + { + c3_w mug_w = 63 << 25; // 6 bits, all ones + c3_w res_w = _ch_skip_slot(mug_w, 25); + c3_assert(0 == res_w); + } + + // child nodes + { + c3_w mug_w = 17 << 20; + c3_w res_w = _ch_skip_slot(mug_w, 20); + c3_assert((18 << 20) == res_w); + } + + { + c3_w mug_w = 31 << 20; // 5 bits, all ones + c3_w res_w = _ch_skip_slot(mug_w, 20); + c3_assert((1 << 25) == res_w); + } + + fprintf(stderr, "test_skip_slot: ok\n"); +} + +/* _test_cache_trimming(): ensure a caching hashtable removes stale items. +*/ +static void +_test_cache_trimming(void) +{ + c3_w max_w = 620; + c3_w i_w; + + //u3p(u3h_root) har_p = u3h_new_cache(max_w / 2); + u3p(u3h_root) har_p = u3h_new_cache(max_w / 10 ); + u3h_root* har_u = u3to(u3h_root, har_p); + + for ( i_w = 0; i_w < max_w; i_w++ ) { + u3h_put(har_p, i_w, i_w + max_w); + } + + if ( ( max_w + max_w - 1) != u3h_get(har_p, max_w - 1) ) { + fprintf(stderr, "fail\r\n"); + exit(1); + } + if ( ( max_w / 10 ) != har_u->use_w ) { + fprintf(stderr, "fail\r\n"); + exit(1); + } + fprintf(stderr, "test_cache_trimming: ok\n"); +} + +static void +_test_cache_replace_value(void) +{ + c3_w max_w = 100; + c3_w i_w; + + u3p(u3h_root) har_p = u3h_new_cache(max_w); + u3h_root* har_u = u3to(u3h_root, har_p); + + for ( i_w = 0; i_w < max_w; i_w++ ) { + u3h_put(har_p, i_w, i_w + max_w); + } + + for ( i_w = 0; i_w < max_w; i_w++ ) { + u3h_put(har_p, i_w, i_w + max_w + 1); + } + + if ( (2 * max_w) != u3h_get(har_p, max_w - 1) ) { + fprintf(stderr, "fail\r\n"); + exit(1); + } + if ( max_w != har_u->use_w ) { + fprintf(stderr, "fail\r\n"); + exit(1); + } + fprintf(stderr, "test_cache_replace_value: ok\r\n"); +} diff --git a/pkg/hs/vere/notes/c/http.c b/pkg/hs/vere/notes/c/http.c new file mode 100644 index 000000000..11dbe0bdd --- /dev/null +++ b/pkg/hs/vere/notes/c/http.c @@ -0,0 +1,2908 @@ +/* vere/http.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +typedef struct _u3_h2o_serv { + h2o_globalconf_t fig_u; // h2o global config + h2o_context_t ctx_u; // h2o ctx + h2o_accept_ctx_t cep_u; // h2o accept ctx + h2o_hostconf_t* hos_u; // h2o host config + h2o_handler_t* han_u; // h2o request handler +} u3_h2o_serv; + +static void _proxy_serv_free(u3_prox* lis_u); +static void _proxy_serv_close(u3_prox* lis_u); +static u3_prox* _proxy_serv_new(u3_http* htp_u, c3_s por_s, c3_o sec); +static u3_prox* _proxy_serv_start(u3_prox* lis_u); + +static void _http_serv_free(u3_http* htp_u); +static void _http_serv_start_all(void); +static void _http_form_free(void); + +static const c3_i TCP_BACKLOG = 16; + +// XX temporary, add to u3_http_ef_form +// +#define PROXY_DOMAIN "arvo.network" + +/* _http_vec_to_meth(): convert h2o_iovec_t to meth +*/ +static u3_weak +_http_vec_to_meth(h2o_iovec_t vec_u) +{ + return ( 0 == strncmp(vec_u.base, "GET", vec_u.len) ) ? c3__get : + ( 0 == strncmp(vec_u.base, "PUT", vec_u.len) ) ? c3__put : + ( 0 == strncmp(vec_u.base, "POST", vec_u.len) ) ? c3__post : + ( 0 == strncmp(vec_u.base, "HEAD", vec_u.len) ) ? c3__head : + ( 0 == strncmp(vec_u.base, "CONNECT", vec_u.len) ) ? c3__conn : + ( 0 == strncmp(vec_u.base, "DELETE", vec_u.len) ) ? c3__delt : + ( 0 == strncmp(vec_u.base, "OPTIONS", vec_u.len) ) ? c3__opts : + ( 0 == strncmp(vec_u.base, "TRACE", vec_u.len) ) ? c3__trac : + // TODO ?? + // ( 0 == strncmp(vec_u.base, "PATCH", vec_u.len) ) ? c3__patc : + u3_none; +} + +/* _http_vec_to_atom(): convert h2o_iovec_t to atom (cord) +*/ +static u3_noun +_http_vec_to_atom(h2o_iovec_t vec_u) +{ + return u3i_bytes(vec_u.len, (const c3_y*)vec_u.base); +} + +/* _http_vec_to_octs(): convert h2o_iovec_t to (unit octs) +*/ +static u3_noun +_http_vec_to_octs(h2o_iovec_t vec_u) +{ + if ( 0 == vec_u.len ) { + return u3_nul; + } + + // XX correct size_t -> atom? + return u3nt(u3_nul, u3i_chubs(1, (const c3_d*)&vec_u.len), + _http_vec_to_atom(vec_u)); +} + +/* _http_vec_from_octs(): convert (unit octs) to h2o_iovec_t +*/ +static h2o_iovec_t +_http_vec_from_octs(u3_noun oct) +{ + if ( u3_nul == oct ) { + return h2o_iovec_init(0, 0); + } + + // 2GB max + if ( c3n == u3a_is_cat(u3h(u3t(oct))) ) { + u3m_bail(c3__fail); + } + + c3_w len_w = u3h(u3t(oct)); + c3_y* buf_y = c3_malloc(1 + len_w); + buf_y[len_w] = 0; + + u3r_bytes(0, len_w, buf_y, u3t(u3t(oct))); + + u3z(oct); + return h2o_iovec_init(buf_y, len_w); +} + +/* _http_heds_to_noun(): convert h2o_header_t to (list (pair @t @t)) +*/ +static u3_noun +_http_heds_to_noun(h2o_header_t* hed_u, c3_d hed_d) +{ + u3_noun hed = u3_nul; + c3_d dex_d = hed_d; + + h2o_header_t deh_u; + + while ( 0 < dex_d ) { + deh_u = hed_u[--dex_d]; + hed = u3nc(u3nc(_http_vec_to_atom(*deh_u.name), + _http_vec_to_atom(deh_u.value)), hed); + } + + return hed; +} + +/* _http_heds_free(): free header linked list +*/ +static void +_http_heds_free(u3_hhed* hed_u) +{ + while ( hed_u ) { + u3_hhed* nex_u = hed_u->nex_u; + + free(hed_u->nam_c); + free(hed_u->val_c); + free(hed_u); + hed_u = nex_u; + } +} + +/* _http_hed_new(): create u3_hhed from nam/val cords +*/ +static u3_hhed* +_http_hed_new(u3_atom nam, u3_atom val) +{ + c3_w nam_w = u3r_met(3, nam); + c3_w val_w = u3r_met(3, val); + u3_hhed* hed_u = c3_malloc(sizeof(*hed_u)); + + hed_u->nam_c = c3_malloc(1 + nam_w); + hed_u->val_c = c3_malloc(1 + val_w); + hed_u->nam_c[nam_w] = 0; + hed_u->val_c[val_w] = 0; + hed_u->nex_u = 0; + hed_u->nam_w = nam_w; + hed_u->val_w = val_w; + + u3r_bytes(0, nam_w, (c3_y*)hed_u->nam_c, nam); + u3r_bytes(0, val_w, (c3_y*)hed_u->val_c, val); + + return hed_u; +} + +/* _http_heds_from_noun(): convert (list (pair @t @t)) to u3_hhed +*/ +static u3_hhed* +_http_heds_from_noun(u3_noun hed) +{ + u3_noun deh = hed; + u3_noun i_hed; + + u3_hhed* hed_u = 0; + + while ( u3_nul != hed ) { + i_hed = u3h(hed); + u3_hhed* nex_u = _http_hed_new(u3h(i_hed), u3t(i_hed)); + nex_u->nex_u = hed_u; + + hed_u = nex_u; + hed = u3t(hed); + } + + u3z(deh); + return hed_u; +} + +/* _http_req_find(): find http request in connection by sequence. +*/ +static u3_hreq* +_http_req_find(u3_hcon* hon_u, c3_w seq_l) +{ + u3_hreq* req_u = hon_u->req_u; + + // XX glories of linear search + // + while ( req_u ) { + if ( seq_l == req_u->seq_l ) { + return req_u; + } + req_u = req_u->nex_u; + } + return 0; +} + +/* _http_req_link(): link http request to connection +*/ +static void +_http_req_link(u3_hcon* hon_u, u3_hreq* req_u) +{ + req_u->hon_u = hon_u; + req_u->seq_l = hon_u->seq_l++; + req_u->nex_u = hon_u->req_u; + + if ( 0 != req_u->nex_u ) { + req_u->nex_u->pre_u = req_u; + } + hon_u->req_u = req_u; +} + +/* _http_req_unlink(): remove http request from connection +*/ +static void +_http_req_unlink(u3_hreq* req_u) +{ + if ( 0 != req_u->pre_u ) { + req_u->pre_u->nex_u = req_u->nex_u; + + if ( 0 != req_u->nex_u ) { + req_u->nex_u->pre_u = req_u->pre_u; + } + } + else { + req_u->hon_u->req_u = req_u->nex_u; + + if ( 0 != req_u->nex_u ) { + req_u->nex_u->pre_u = 0; + } + } +} + +/* _http_req_to_duct(): translate srv/con/req to duct +*/ +static u3_noun +_http_req_to_duct(u3_hreq* req_u) +{ + return u3nt(u3_blip, c3__http, + u3nq(u3dc("scot", c3_s2('u','v'), req_u->hon_u->htp_u->sev_l), + u3dc("scot", c3_s2('u','d'), req_u->hon_u->coq_l), + u3dc("scot", c3_s2('u','d'), req_u->seq_l), + u3_nul)); +} + +/* _http_req_kill(): kill http request in %eyre. +*/ +static void +_http_req_kill(u3_hreq* req_u) +{ + u3_noun pox = _http_req_to_duct(req_u); + u3_pier_plan(pox, u3nc(c3__thud, u3_nul)); +} + +/* _http_req_done(): request finished, deallocation callback +*/ +static void +_http_req_done(void* ptr_v) +{ + u3_hreq* req_u = (u3_hreq*)ptr_v; + + // client canceled request + if ( u3_rsat_plan == req_u->sat_e ) { + _http_req_kill(req_u); + } + + if ( 0 != req_u->tim_u ) { + uv_close((uv_handle_t*)req_u->tim_u, (uv_close_cb)free); + req_u->tim_u = 0; + } + + _http_req_unlink(req_u); +} + +/* _http_req_timer_cb(): request timeout callback +*/ +static void +_http_req_timer_cb(uv_timer_t* tim_u) +{ + u3_hreq* req_u = tim_u->data; + + if ( u3_rsat_plan == req_u->sat_e ) { + _http_req_kill(req_u); + req_u->sat_e = u3_rsat_ripe; + + c3_c* msg_c = "gateway timeout"; + h2o_send_error_generic(req_u->rec_u, 504, msg_c, msg_c, 0); + } +} + +/* _http_req_new(): receive http request. +*/ +static u3_hreq* +_http_req_new(u3_hcon* hon_u, h2o_req_t* rec_u) +{ + u3_hreq* req_u = h2o_mem_alloc_shared(&rec_u->pool, sizeof(*req_u), + _http_req_done); + req_u->rec_u = rec_u; + req_u->sat_e = u3_rsat_init; + req_u->tim_u = 0; + req_u->pre_u = 0; + + _http_req_link(hon_u, req_u); + + return req_u; +} + +/* _http_req_dispatch(): dispatch http request to %eyre +*/ +static void +_http_req_dispatch(u3_hreq* req_u, u3_noun req) +{ + c3_assert(u3_rsat_init == req_u->sat_e); + req_u->sat_e = u3_rsat_plan; + + u3_noun pox = _http_req_to_duct(req_u); + u3_noun typ = _(req_u->hon_u->htp_u->lop) ? c3__chis : c3__this; + + u3_pier_plan(pox, u3nq(typ, + req_u->hon_u->htp_u->sec, + u3nc(c3y, u3i_words(1, &req_u->hon_u->ipf_w)), + req)); +} + +typedef struct _u3_hgen { + h2o_generator_t neg_u; + h2o_iovec_t bod_u; + u3_hhed* hed_u; +} u3_hgen; + +/* _http_hgen_dispose(): dispose response generator and buffers +*/ +static void +_http_hgen_dispose(void* ptr_v) +{ + u3_hgen* gen_u = (u3_hgen*)ptr_v; + _http_heds_free(gen_u->hed_u); + free(gen_u->bod_u.base); +} + +/* _http_req_respond(): write httr to h2o_req_t->res and send +*/ +static void +_http_req_respond(u3_hreq* req_u, u3_noun sas, u3_noun hed, u3_noun bod) +{ + // XX ideally + //c3_assert(u3_rsat_plan == req_u->sat_e); + + if ( u3_rsat_plan != req_u->sat_e ) { + //u3l_log("duplicate response\n"); + return; + } + + req_u->sat_e = u3_rsat_ripe; + + uv_timer_stop(req_u->tim_u); + + h2o_req_t* rec_u = req_u->rec_u; + + rec_u->res.status = sas; + rec_u->res.reason = (sas < 200) ? "weird" : + (sas < 300) ? "ok" : + (sas < 400) ? "moved" : + (sas < 500) ? "missing" : + "hosed"; + + u3_hhed* hed_u = _http_heds_from_noun(u3k(hed)); + + u3_hgen* gen_u = h2o_mem_alloc_shared(&rec_u->pool, sizeof(*gen_u), + _http_hgen_dispose); + gen_u->neg_u = (h2o_generator_t){0, 0}; + gen_u->hed_u = hed_u; + + while ( 0 != hed_u ) { + h2o_add_header_by_str(&rec_u->pool, &rec_u->res.headers, + hed_u->nam_c, hed_u->nam_w, 0, 0, + hed_u->val_c, hed_u->val_w); + hed_u = hed_u->nex_u; + } + + gen_u->bod_u = _http_vec_from_octs(u3k(bod)); + rec_u->res.content_length = gen_u->bod_u.len; + + h2o_start_response(rec_u, &gen_u->neg_u); + h2o_send(rec_u, &gen_u->bod_u, 1, H2O_SEND_STATE_FINAL); + + { + u3_h2o_serv* h2o_u = req_u->hon_u->htp_u->h2o_u; + + if ( 0 != h2o_u->ctx_u.shutdown_requested ) { + rec_u->http1_is_persistent = 0; + } + } + + u3z(sas); u3z(hed); u3z(bod); +} + +/* _http_rec_to_httq(): convert h2o_req_t to httq +*/ +static u3_weak +_http_rec_to_httq(h2o_req_t* rec_u) +{ + u3_noun med = _http_vec_to_meth(rec_u->method); + + if ( u3_none == med ) { + return u3_none; + } + + u3_noun url = _http_vec_to_atom(rec_u->path); + u3_noun hed = _http_heds_to_noun(rec_u->headers.entries, + rec_u->headers.size); + + // restore host header + hed = u3nc(u3nc(u3i_string("host"), + _http_vec_to_atom(rec_u->authority)), + hed); + + u3_noun bod = _http_vec_to_octs(rec_u->entity); + + return u3nq(med, url, hed, bod); +} + +typedef struct _h2o_uv_sock { // see private st_h2o_uv_socket_t + h2o_socket_t sok_u; // socket + uv_stream_t* han_u; // client stream handler (u3_hcon) +} h2o_uv_sock; + +/* _http_rec_accept(); handle incoming http request from h2o. +*/ +static c3_i +_http_rec_accept(h2o_handler_t* han_u, h2o_req_t* rec_u) +{ + u3_weak req = _http_rec_to_httq(rec_u); + + if ( u3_none == req ) { + if ( (u3C.wag_w & u3o_verbose) ) { + u3l_log("strange %.*s request\n", (int)rec_u->method.len, + rec_u->method.base); + } + c3_c* msg_c = "bad request"; + h2o_send_error_generic(rec_u, 400, msg_c, msg_c, 0); + } + else { + h2o_uv_sock* suv_u = (h2o_uv_sock*)rec_u->conn-> + callbacks->get_socket(rec_u->conn); + u3_hcon* hon_u = (u3_hcon*)suv_u->han_u; + + // sanity check + c3_assert( hon_u->sok_u == &suv_u->sok_u ); + + u3_hreq* req_u = _http_req_new(hon_u, rec_u); + + req_u->tim_u = c3_malloc(sizeof(*req_u->tim_u)); + req_u->tim_u->data = req_u; + uv_timer_init(u3L, req_u->tim_u); + uv_timer_start(req_u->tim_u, _http_req_timer_cb, 900 * 1000, 0); + + _http_req_dispatch(req_u, req); + } + + return 0; +} + +/* _http_conn_find(): find http connection in server by sequence. +*/ +static u3_hcon* +_http_conn_find(u3_http *htp_u, c3_w coq_l) +{ + u3_hcon* hon_u = htp_u->hon_u; + + // XX glories of linear search + // + while ( hon_u ) { + if ( coq_l == hon_u->coq_l ) { + return hon_u; + } + hon_u = hon_u->nex_u; + } + return 0; +} + +/* _http_conn_link(): link http request to connection +*/ +static void +_http_conn_link(u3_http* htp_u, u3_hcon* hon_u) +{ + hon_u->htp_u = htp_u; + hon_u->coq_l = htp_u->coq_l++; + hon_u->nex_u = htp_u->hon_u; + + if ( 0 != hon_u->nex_u ) { + hon_u->nex_u->pre_u = hon_u; + } + htp_u->hon_u = hon_u; +} + +/* _http_conn_unlink(): remove http request from connection +*/ +static void +_http_conn_unlink(u3_hcon* hon_u) +{ + if ( 0 != hon_u->pre_u ) { + hon_u->pre_u->nex_u = hon_u->nex_u; + + if ( 0 != hon_u->nex_u ) { + hon_u->nex_u->pre_u = hon_u->pre_u; + } + } + else { + hon_u->htp_u->hon_u = hon_u->nex_u; + + if ( 0 != hon_u->nex_u ) { + hon_u->nex_u->pre_u = 0; + } + } +} + +/* _http_conn_free(): free http connection on close. +*/ +static void +_http_conn_free(uv_handle_t* han_t) +{ + u3_hcon* hon_u = (u3_hcon*)han_t; + u3_http* htp_u = hon_u->htp_u; + u3_h2o_serv* h2o_u = htp_u->h2o_u; + + c3_assert( 0 == hon_u->req_u ); + +#if 0 + { + c3_w len_w = 0; + + u3_hcon* noh_u = htp_u->hon_u; + + while ( 0 != noh_u ) { + len_w++; + noh_u = noh_u->nex_u; + } + + u3l_log("http conn free %d of %u server %d\n", hon_u->coq_l, len_w, htp_u->sev_l); + } +#endif + + _http_conn_unlink(hon_u); + +#if 0 + { + c3_w len_w = 0; + + u3_hcon* noh_u = htp_u->hon_u; + + while ( 0 != noh_u ) { + len_w++; + noh_u = noh_u->nex_u; + } + + u3l_log("http conn free %u remaining\n", len_w); + } +#endif + + if ( (0 == htp_u->hon_u) && (0 != h2o_u->ctx_u.shutdown_requested) ) { +#if 0 + u3l_log("http conn free %d free server %d\n", hon_u->coq_l, htp_u->sev_l); +#endif + _http_serv_free(htp_u); + } + + free(hon_u); +} + +/* _http_conn_new(): create and accept http connection. +*/ +static u3_hcon* +_http_conn_new(u3_http* htp_u) +{ + u3_hcon* hon_u = c3_malloc(sizeof(*hon_u)); + hon_u->seq_l = 1; + hon_u->ipf_w = 0; + hon_u->req_u = 0; + hon_u->sok_u = 0; + hon_u->con_u = 0; + hon_u->pre_u = 0; + + _http_conn_link(htp_u, hon_u); + +#if 0 + u3l_log("http conn neww %d server %d\n", hon_u->coq_l, htp_u->sev_l); +#endif + + return hon_u; +} + +/* _http_serv_find(): find http server by sequence. +*/ +static u3_http* +_http_serv_find(c3_l sev_l) +{ + u3_http* htp_u = u3_Host.htp_u; + + // XX glories of linear search + // + while ( htp_u ) { + if ( sev_l == htp_u->sev_l ) { + return htp_u; + } + htp_u = htp_u->nex_u; + } + return 0; +} + +/* _http_serv_link(): link http server to global state. +*/ +static void +_http_serv_link(u3_http* htp_u) +{ + // XX link elsewhere initially, relink on start? + + if ( 0 != u3_Host.htp_u ) { + htp_u->sev_l = 1 + u3_Host.htp_u->sev_l; + } + else { + htp_u->sev_l = u3A->sev_l; + } + + htp_u->nex_u = u3_Host.htp_u; + u3_Host.htp_u = htp_u; +} + +/* _http_serv_unlink(): remove http server from global state. +*/ +static void +_http_serv_unlink(u3_http* htp_u) +{ + // XX link elsewhere initially, relink on start? + + if ( u3_Host.htp_u == htp_u ) { + u3_Host.htp_u = htp_u->nex_u; + } + else { + u3_http* pre_u = u3_Host.htp_u; + + // XX glories of linear search + // + while ( pre_u ) { + if ( pre_u->nex_u == htp_u ) { + pre_u->nex_u = htp_u->nex_u; + } + else pre_u = pre_u->nex_u; + } + } +} + +/* _http_h2o_context_dispose(): h2o_context_dispose, inlined and cleaned up. +*/ +static void +_http_h2o_context_dispose(h2o_context_t* ctx) +{ + h2o_globalconf_t *config = ctx->globalconf; + size_t i, j; + + for (i = 0; config->hosts[i] != NULL; ++i) { + h2o_hostconf_t *hostconf = config->hosts[i]; + for (j = 0; j != hostconf->paths.size; ++j) { + h2o_pathconf_t *pathconf = hostconf->paths.entries + j; + h2o_context_dispose_pathconf_context(ctx, pathconf); + } + h2o_context_dispose_pathconf_context(ctx, &hostconf->fallback_path); + } + + free(ctx->_pathconfs_inited.entries); + free(ctx->_module_configs); + + h2o_timeout_dispose(ctx->loop, &ctx->zero_timeout); + h2o_timeout_dispose(ctx->loop, &ctx->hundred_ms_timeout); + h2o_timeout_dispose(ctx->loop, &ctx->handshake_timeout); + h2o_timeout_dispose(ctx->loop, &ctx->http1.req_timeout); + h2o_timeout_dispose(ctx->loop, &ctx->http2.idle_timeout); + + // NOTE: linked in http2/connection, never unlinked + h2o_timeout_unlink(&ctx->http2._graceful_shutdown_timeout); + + h2o_timeout_dispose(ctx->loop, &ctx->http2.graceful_shutdown_timeout); + h2o_timeout_dispose(ctx->loop, &ctx->proxy.io_timeout); + h2o_timeout_dispose(ctx->loop, &ctx->one_sec_timeout); + + h2o_filecache_destroy(ctx->filecache); + ctx->filecache = NULL; + + /* clear storage */ + for (i = 0; i != ctx->storage.size; ++i) { + h2o_context_storage_item_t *item = ctx->storage.entries + i; + if (item->dispose != NULL) { + item->dispose(item->data); + } + } + + free(ctx->storage.entries); + + h2o_multithread_unregister_receiver(ctx->queue, &ctx->receivers.hostinfo_getaddr); + h2o_multithread_destroy_queue(ctx->queue); + + if (ctx->_timestamp_cache.value != NULL) { + h2o_mem_release_shared(ctx->_timestamp_cache.value); + } + + // NOTE: explicit uv_run removed +} + +/* _http_serv_really_free(): free http server. +*/ +static void +_http_serv_really_free(u3_http* htp_u) +{ + c3_assert( 0 == htp_u->hon_u ); + + if ( 0 != htp_u->h2o_u ) { + u3_h2o_serv* h2o_u = htp_u->h2o_u; + + if ( 0 != h2o_u->cep_u.ssl_ctx ) { + SSL_CTX_free(h2o_u->cep_u.ssl_ctx); + } + + h2o_config_dispose(&h2o_u->fig_u); + + // XX h2o_cleanup_thread if not restarting? + + free(htp_u->h2o_u); + htp_u->h2o_u = 0; + } + + _http_serv_unlink(htp_u); + free(htp_u); +} + +/* http_serv_free_cb(): timer callback for freeing http server. +*/ +static void +http_serv_free_cb(uv_timer_t* tim_u) +{ + u3_http* htp_u = tim_u->data; + + _http_serv_really_free(htp_u); + + uv_close((uv_handle_t*)tim_u, (uv_close_cb)free); +} + +/* _http_serv_free(): begin to free http server. +*/ +static void +_http_serv_free(u3_http* htp_u) +{ +#if 0 + u3l_log("http serv free %d\n", htp_u->sev_l); +#endif + + c3_assert( 0 == htp_u->hon_u ); + + if ( 0 == htp_u->h2o_u ) { + _http_serv_really_free(htp_u); + } + else { + u3_h2o_serv* h2o_u = htp_u->h2o_u; + + _http_h2o_context_dispose(&h2o_u->ctx_u); + + // NOTE: free deferred to allow timers to be closed + // this is a heavy-handed workaround for the lack of + // close callbacks in h2o_timer_t + // it's unpredictable how many event-loop turns will + // be required to finish closing the underlying uv_timer_t + // and we can't free until that's done (or we have UB) + // testing reveals 5s to be a long enough deferral + uv_timer_t* tim_u = c3_malloc(sizeof(*tim_u)); + + tim_u->data = htp_u; + + uv_timer_init(u3L, tim_u); + uv_timer_start(tim_u, http_serv_free_cb, 5000, 0); + } +} + +/* _http_serv_close_cb(): http server uv_close callback. +*/ +static void +_http_serv_close_cb(uv_handle_t* han_u) +{ + u3_http* htp_u = (u3_http*)han_u; + htp_u->liv = c3n; + + // otherwise freed by the last linked connection + if ( 0 == htp_u->hon_u ) { + _http_serv_free(htp_u); + } + + // restart if all linked servers have been shutdown + { + htp_u = u3_Host.htp_u; + c3_o res = c3y; + + while ( 0 != htp_u ) { + if ( c3y == htp_u->liv ) { + res = c3n; + } + htp_u = htp_u->nex_u; + } + + if ( (c3y == res) && (0 != u3_Host.fig_u.for_u) ) { + _http_serv_start_all(); + } + } +} + +/* _http_serv_close(): close http server gracefully. +*/ +static void +_http_serv_close(u3_http* htp_u) +{ + u3_h2o_serv* h2o_u = htp_u->h2o_u; + h2o_context_request_shutdown(&h2o_u->ctx_u); + +#if 0 + u3l_log("http serv close %d %p\n", htp_u->sev_l, &htp_u->wax_u); +#endif + + uv_close((uv_handle_t*)&htp_u->wax_u, _http_serv_close_cb); + + if ( 0 != htp_u->rox_u ) { + // XX close soft + _proxy_serv_close(htp_u->rox_u); + htp_u->rox_u = 0; + } +} + +/* _http_serv_new(): create new http server. +*/ +static u3_http* +_http_serv_new(c3_s por_s, c3_o sec, c3_o lop) +{ + u3_http* htp_u = c3_malloc(sizeof(*htp_u)); + + htp_u->coq_l = 1; + htp_u->por_s = por_s; + htp_u->sec = sec; + htp_u->lop = lop; + htp_u->liv = c3y; + htp_u->h2o_u = 0; + htp_u->rox_u = 0; + htp_u->hon_u = 0; + htp_u->nex_u = 0; + + _http_serv_link(htp_u); + + return htp_u; +} + +/* _http_serv_accept(): accept new http connection. +*/ +static void +_http_serv_accept(u3_http* htp_u) +{ + u3_hcon* hon_u = _http_conn_new(htp_u); + + uv_tcp_init(u3L, &hon_u->wax_u); + + c3_i sas_i; + + if ( 0 != (sas_i = uv_accept((uv_stream_t*)&htp_u->wax_u, + (uv_stream_t*)&hon_u->wax_u)) ) { + if ( (u3C.wag_w & u3o_verbose) ) { + u3l_log("http: accept: %s\n", uv_strerror(sas_i)); + } + + uv_close((uv_handle_t*)&hon_u->wax_u, _http_conn_free); + return; + } + + hon_u->sok_u = h2o_uv_socket_create((uv_stream_t*)&hon_u->wax_u, + _http_conn_free); + + h2o_accept(&((u3_h2o_serv*)htp_u->h2o_u)->cep_u, hon_u->sok_u); + + // capture h2o connection (XX fragile) + hon_u->con_u = (h2o_conn_t*)hon_u->sok_u->data; + + struct sockaddr_in adr_u; + h2o_socket_getpeername(hon_u->sok_u, (struct sockaddr*)&adr_u); + hon_u->ipf_w = ( adr_u.sin_family != AF_INET ) ? + 0 : ntohl(adr_u.sin_addr.s_addr); +} + +/* _http_serv_listen_cb(): uv_connection_cb for uv_listen +*/ +static void +_http_serv_listen_cb(uv_stream_t* str_u, c3_i sas_i) +{ + u3_http* htp_u = (u3_http*)str_u; + + if ( 0 != sas_i ) { + u3l_log("http: listen_cb: %s\n", uv_strerror(sas_i)); + } + else { + _http_serv_accept(htp_u); + } +} + +/* _http_serv_init_h2o(): initialize h2o ctx and handlers for server. +*/ +static u3_h2o_serv* +_http_serv_init_h2o(SSL_CTX* tls_u, c3_o log, c3_o red) +{ + u3_h2o_serv* h2o_u = c3_calloc(sizeof(*h2o_u)); + + h2o_config_init(&h2o_u->fig_u); + h2o_u->fig_u.server_name = h2o_iovec_init( + H2O_STRLIT("urbit/vere-" URBIT_VERSION)); + + // XX default pending vhost/custom-domain design + // XX revisit the effect of specifying the port + h2o_u->hos_u = h2o_config_register_host(&h2o_u->fig_u, + h2o_iovec_init(H2O_STRLIT("default")), + 65535); + + h2o_u->cep_u.ctx = (h2o_context_t*)&h2o_u->ctx_u; + h2o_u->cep_u.hosts = h2o_u->fig_u.hosts; + h2o_u->cep_u.ssl_ctx = tls_u; + + h2o_u->han_u = h2o_create_handler(&h2o_u->hos_u->fallback_path, + sizeof(*h2o_u->han_u)); + if ( c3y == red ) { + // XX h2o_redirect_register + h2o_u->han_u->on_req = _http_rec_accept; + } + else { + h2o_u->han_u->on_req = _http_rec_accept; + } + + if ( c3y == log ) { + // XX move this to post serv_start and put the port in the name +#if 0 + c3_c* pax_c = u3_Host.dir_c; + u3_noun now = u3dc("scot", c3__da, u3k(u3A->now)); + c3_c* now_c = u3r_string(now); + c3_c* nam_c = ".access.log"; + c3_w len_w = 1 + strlen(pax_c) + 1 + strlen(now_c) + strlen(nam_c); + + c3_c* paf_c = c3_malloc(len_w); + snprintf(paf_c, len_w, "%s/%s%s", pax_c, now_c, nam_c); + + h2o_access_log_filehandle_t* fil_u = + h2o_access_log_open_handle(paf_c, 0, H2O_LOGCONF_ESCAPE_APACHE); + + h2o_access_log_register(&h2o_u->hos_u->fallback_path, fil_u); + + free(paf_c); + free(now_c); + u3z(now); +#endif + } + + // XX h2o_compress_register + + h2o_context_init(&h2o_u->ctx_u, u3L, &h2o_u->fig_u); + + return h2o_u; +} + +/* _http_serv_start(): start http server. +*/ +static void +_http_serv_start(u3_http* htp_u) +{ + struct sockaddr_in adr_u; + memset(&adr_u, 0, sizeof(adr_u)); + + adr_u.sin_family = AF_INET; + adr_u.sin_addr.s_addr = ( c3y == htp_u->lop ) ? + htonl(INADDR_LOOPBACK) : + INADDR_ANY; + + uv_tcp_init(u3L, &htp_u->wax_u); + + /* Try ascending ports. + */ + while ( 1 ) { + c3_i sas_i; + + adr_u.sin_port = htons(htp_u->por_s); + + if ( 0 != (sas_i = uv_tcp_bind(&htp_u->wax_u, + (const struct sockaddr*)&adr_u, 0)) || + 0 != (sas_i = uv_listen((uv_stream_t*)&htp_u->wax_u, + TCP_BACKLOG, _http_serv_listen_cb)) ) { + if ( (UV_EADDRINUSE == sas_i) || (UV_EACCES == sas_i) ) { + if ( (c3y == htp_u->sec) && (443 == htp_u->por_s) ) { + htp_u->por_s = 8443; + } + else if ( (c3n == htp_u->sec) && (80 == htp_u->por_s) ) { + htp_u->por_s = 8080; + } + else { + htp_u->por_s++; + } + + continue; + } + + u3l_log("http: listen: %s\n", uv_strerror(sas_i)); + + if ( 0 != htp_u->rox_u ) { + _proxy_serv_free(htp_u->rox_u); + } + _http_serv_free(htp_u); + return; + } + + // XX this is weird + if ( 0 != htp_u->rox_u ) { + htp_u->rox_u = _proxy_serv_start(htp_u->rox_u); + } + + if ( 0 != htp_u->rox_u ) { + u3l_log("http: live (%s, %s) on %d (proxied on %d)\n", + (c3y == htp_u->sec) ? "secure" : "insecure", + (c3y == htp_u->lop) ? "loopback" : "public", + htp_u->por_s, + htp_u->rox_u->por_s); + } + else { + u3l_log("http: live (%s, %s) on %d\n", + (c3y == htp_u->sec) ? "secure" : "insecure", + (c3y == htp_u->lop) ? "loopback" : "public", + htp_u->por_s); + } + + break; + } +} + +//XX deduplicate these with cttp + +/* _cttp_mcut_char(): measure/cut character. +*/ +static c3_w +_cttp_mcut_char(c3_c* buf_c, c3_w len_w, c3_c chr_c) +{ + if ( buf_c ) { + buf_c[len_w] = chr_c; + } + return len_w + 1; +} + +/* _cttp_mcut_cord(): measure/cut cord. +*/ +static c3_w +_cttp_mcut_cord(c3_c* buf_c, c3_w len_w, u3_noun san) +{ + c3_w ten_w = u3r_met(3, san); + + if ( buf_c ) { + u3r_bytes(0, ten_w, (c3_y *)(buf_c + len_w), san); + } + u3z(san); + return (len_w + ten_w); +} + +/* _cttp_mcut_path(): measure/cut cord list. +*/ +static c3_w +_cttp_mcut_path(c3_c* buf_c, c3_w len_w, c3_c sep_c, u3_noun pax) +{ + u3_noun axp = pax; + + while ( u3_nul != axp ) { + u3_noun h_axp = u3h(axp); + + len_w = _cttp_mcut_cord(buf_c, len_w, u3k(h_axp)); + axp = u3t(axp); + + if ( u3_nul != axp ) { + len_w = _cttp_mcut_char(buf_c, len_w, sep_c); + } + } + u3z(pax); + return len_w; +} + +static uv_buf_t +_http_wain_to_buf(u3_noun wan) +{ + c3_w len_w = _cttp_mcut_path(0, 0, (c3_c)10, u3k(wan)); + c3_c* buf_c = c3_malloc(1 + len_w); + + _cttp_mcut_path(buf_c, 0, (c3_c)10, wan); + buf_c[len_w] = 0; + + return uv_buf_init(buf_c, len_w); +} + +/* _http_init_tls: initialize OpenSSL context +*/ +static SSL_CTX* +_http_init_tls(uv_buf_t key_u, uv_buf_t cer_u) +{ + // XX require 1.1.0 and use TLS_server_method() + SSL_CTX* tls_u = SSL_CTX_new(SSLv23_server_method()); + // XX use SSL_CTX_set_max_proto_version() and SSL_CTX_set_min_proto_version() + SSL_CTX_set_options(tls_u, SSL_OP_NO_SSLv2 | + SSL_OP_NO_SSLv3 | + // SSL_OP_NO_TLSv1 | // XX test + SSL_OP_NO_COMPRESSION); + + SSL_CTX_set_default_verify_paths(tls_u); + SSL_CTX_set_session_cache_mode(tls_u, SSL_SESS_CACHE_OFF); + SSL_CTX_set_cipher_list(tls_u, + "ECDH+AESGCM:DH+AESGCM:ECDH+AES256:DH+AES256:" + "ECDH+AES128:DH+AES:ECDH+3DES:DH+3DES:RSA+AESGCM:" + "RSA+AES:RSA+3DES:!aNULL:!MD5:!DSS"); + + // enable ALPN for HTTP 2 support +#if H2O_USE_ALPN + { + SSL_CTX_set_ecdh_auto(tls_u, 1); + h2o_ssl_register_alpn_protocols(tls_u, h2o_http2_alpn_protocols); + } +#endif + + { + BIO* bio_u = BIO_new_mem_buf(key_u.base, key_u.len); + EVP_PKEY* pky_u = PEM_read_bio_PrivateKey(bio_u, 0, 0, 0); + c3_i sas_i = SSL_CTX_use_PrivateKey(tls_u, pky_u); + + EVP_PKEY_free(pky_u); + BIO_free(bio_u); + + if( 0 == sas_i ) { + u3l_log("http: load private key failed:\n"); + ERR_print_errors_fp(u3_term_io_hija()); + u3_term_io_loja(1); + + SSL_CTX_free(tls_u); + + return 0; + } + } + + { + BIO* bio_u = BIO_new_mem_buf(cer_u.base, cer_u.len); + X509* xer_u = PEM_read_bio_X509_AUX(bio_u, 0, 0, 0); + c3_i sas_i = SSL_CTX_use_certificate(tls_u, xer_u); + + X509_free(xer_u); + + if( 0 == sas_i ) { + u3l_log("http: load certificate failed:\n"); + ERR_print_errors_fp(u3_term_io_hija()); + u3_term_io_loja(1); + + BIO_free(bio_u); + SSL_CTX_free(tls_u); + + return 0; + } + + // get any additional CA certs, ignoring errors + while ( 0 != (xer_u = PEM_read_bio_X509(bio_u, 0, 0, 0)) ) { + // XX require 1.0.2 or newer and use SSL_CTX_add0_chain_cert + SSL_CTX_add_extra_chain_cert(tls_u, xer_u); + } + + BIO_free(bio_u); + } + + return tls_u; +} + +/* _http_write_ports_file(): update .http.ports +*/ +static void +_http_write_ports_file(c3_c *pax_c) +{ + c3_c* nam_c = ".http.ports"; + c3_w len_w = 1 + strlen(pax_c) + 1 + strlen(nam_c); + + c3_c* paf_c = c3_malloc(len_w); + snprintf(paf_c, len_w, "%s/%s", pax_c, nam_c); + + c3_i por_i = open(paf_c, O_WRONLY | O_CREAT | O_TRUNC, 0666); + free(paf_c); + + u3_http* htp_u = u3_Host.htp_u; + + while ( 0 != htp_u ) { + // XX write proxy ports instead? + if ( 0 < htp_u->por_s ) { + dprintf(por_i, "%u %s %s\n", htp_u->por_s, + (c3y == htp_u->sec) ? "secure" : "insecure", + (c3y == htp_u->lop) ? "loopback" : "public"); + } + + htp_u = htp_u->nex_u; + } + + c3_sync(por_i); + close(por_i); +} + +/* _http_release_ports_file(): remove .http.ports +*/ +static void +_http_release_ports_file(c3_c *pax_c) +{ + c3_c* nam_c = ".http.ports"; + c3_w len_w = 1 + strlen(pax_c) + 1 + strlen(nam_c); + + c3_c* paf_c = c3_malloc(len_w); + snprintf(paf_c, len_w, "%s/%s", pax_c, nam_c); + + unlink(paf_c); + free(paf_c); +} + + +/* _http_czar_host(): galaxy hostname as (unit host:eyre) +*/ +static u3_noun +_http_czar_host(void) +{ + u3_noun dom = u3_nul; + return dom; + + // XX revisit +#if 0 + if ( (0 == u3_Host.ops_u.imp_c) || (c3n == u3_Host.ops_u.net) ) { + return dom; + } + + { + c3_c* dns_c = u3_Host.ops_u.dns_c; + c3_w len_w = strlen(dns_c); + c3_w dif_w; + c3_c* dom_c; + c3_c* dot_c; + + while ( 0 != len_w ) { + if ( 0 == (dot_c = strchr(dns_c, '.'))) { + len_w = 0; + dom = u3nc(u3i_string(dns_c), dom); + break; + } + else { + dif_w = dot_c - dns_c; + dom_c = c3_malloc(1 + dif_w); + strncpy(dom_c, dns_c, dif_w); + dom_c[dif_w] = 0; + + dom = u3nc(u3i_string(dom_c), dom); + + // increment to skip leading '.' + dns_c = dot_c + 1; + free(dom_c); + + // XX confirm that underflow is impossible here + len_w -= c3_min(dif_w, len_w); + } + } + } + + if ( u3_nul == dom ) { + return dom; + } + + // increment to skip '~' + dom = u3nc(u3i_string(u3_Host.ops_u.imp_c + 1), u3kb_flop(u3k(dom))); + + return u3nt(u3_nul, c3y, u3kb_flop(u3k(dom))); +#endif +} + +/* u3_http_ef_bake(): notify %eyre that we're live +*/ +void +u3_http_ef_bake(void) +{ + u3_noun ipf = u3_nul; + + { + struct ifaddrs* iad_u; + getifaddrs(&iad_u); + + struct ifaddrs* dia_u = iad_u; + + while ( iad_u ) { + struct sockaddr_in* adr_u = (struct sockaddr_in *)iad_u->ifa_addr; + + if ( (0 != adr_u) && (AF_INET == adr_u->sin_family) ) { + c3_w ipf_w = ntohl(adr_u->sin_addr.s_addr); + + if ( INADDR_LOOPBACK != ipf_w ) { + ipf = u3nc(u3nc(c3n, u3i_words(1, &ipf_w)), ipf); + } + } + + iad_u = iad_u->ifa_next; + } + + freeifaddrs(dia_u); + } + + u3_noun hot = _http_czar_host(); + + if ( u3_nul != hot ) { + ipf = u3nc(u3k(u3t(hot)), ipf); + u3z(hot); + } + + u3_noun pax = u3nq(u3_blip, c3__http, u3k(u3A->sen), u3_nul); + + u3_pier_plan(pax, u3nc(c3__born, ipf)); +} + +/* u3_http_ef_thou(): send %thou from %eyre as http response. +*/ +void +u3_http_ef_thou(c3_l sev_l, + c3_l coq_l, + c3_l seq_l, + u3_noun rep) +{ + u3_http* htp_u; + u3_hcon* hon_u; + u3_hreq* req_u; + c3_w bug_w = u3C.wag_w & u3o_verbose; + + if ( !(htp_u = _http_serv_find(sev_l)) ) { + if ( bug_w ) { + u3l_log("http: server not found: %x\r\n", sev_l); + } + } + else if ( !(hon_u = _http_conn_find(htp_u, coq_l)) ) { + if ( bug_w ) { + u3l_log("http: connection not found: %x/%d\r\n", sev_l, coq_l); + } + } + else if ( !(req_u = _http_req_find(hon_u, seq_l)) ) { + if ( bug_w ) { + u3l_log("http: request not found: %x/%d/%d\r\n", + sev_l, coq_l, seq_l); + } + } + else { + u3_noun p_rep, q_rep, r_rep; + + if ( c3n == u3r_trel(rep, &p_rep, &q_rep, &r_rep) ) { + u3l_log("http: strange response\n"); + } + else { + _http_req_respond(req_u, u3k(p_rep), u3k(q_rep), u3k(r_rep)); + } + } + + u3z(rep); +} + +/* _http_serv_start_all(): initialize and start servers based on saved config. +*/ +static void +_http_serv_start_all(void) +{ + u3_http* htp_u; + c3_s por_s; + + u3_noun sec = u3_nul; + u3_noun non = u3_none; + + u3_form* for_u = u3_Host.fig_u.for_u; + + c3_assert( 0 != for_u ); + + // if the SSL_CTX existed, it'll be freed with the servers + u3_Host.tls_u = 0; + + // HTTPS server. + if ( (0 != for_u->key_u.base) && (0 != for_u->cer_u.base) ) { + u3_Host.tls_u = _http_init_tls(for_u->key_u, for_u->cer_u); + + // Note: if tls_u is used for additional servers, + // its reference count must be incremented with SSL_CTX_up_ref + + if ( 0 != u3_Host.tls_u ) { + por_s = ( c3y == for_u->pro ) ? 8443 : 443; + htp_u = _http_serv_new(por_s, c3y, c3n); + htp_u->h2o_u = _http_serv_init_h2o(u3_Host.tls_u, for_u->log, for_u->red); + + if ( c3y == for_u->pro ) { + htp_u->rox_u = _proxy_serv_new(htp_u, 443, c3y); + } + + _http_serv_start(htp_u); + sec = u3nc(u3_nul, htp_u->por_s); + } + } + + // HTTP server. + { + por_s = ( c3y == for_u->pro ) ? 8080 : 80; + htp_u = _http_serv_new(por_s, c3n, c3n); + htp_u->h2o_u = _http_serv_init_h2o(0, for_u->log, for_u->red); + + if ( c3y == for_u->pro ) { + htp_u->rox_u = _proxy_serv_new(htp_u, 80, c3n); + } + + _http_serv_start(htp_u); + non = htp_u->por_s; + } + + // Loopback server. + { + por_s = 12321; + htp_u = _http_serv_new(por_s, c3n, c3y); + htp_u->h2o_u = _http_serv_init_h2o(0, for_u->log, for_u->red); + // never proxied + + _http_serv_start(htp_u); + } + + // send listening ports to %eyre + { + c3_assert( u3_none != non ); + + u3_noun pax = u3nq(u3_blip, c3__http, u3k(u3A->sen), u3_nul); + u3_pier_plan(pax, u3nt(c3__live, non, sec)); + } + + _http_write_ports_file(u3_Host.dir_c); + _http_form_free(); +} + +/* _http_serv_restart(): gracefully shutdown, then start servers. +*/ +static void +_http_serv_restart(void) +{ + u3_http* htp_u = u3_Host.htp_u; + + if ( 0 == htp_u ) { + _http_serv_start_all(); + } + else { + u3l_log("http: restarting servers to apply configuration\n"); + + while ( 0 != htp_u ) { + if ( c3y == htp_u->liv ) { + _http_serv_close(htp_u); + } + htp_u = htp_u->nex_u; + } + + _http_release_ports_file(u3_Host.dir_c); + } +} + +/* _http_form_free(): free and unlink saved config. +*/ +static void +_http_form_free(void) +{ + u3_form* for_u = u3_Host.fig_u.for_u; + + if ( 0 == for_u ) { + return; + } + + if ( 0 != for_u->key_u.base ) { + free(for_u->key_u.base); + } + + if ( 0 != for_u->cer_u.base ) { + free(for_u->cer_u.base); + } + + free(for_u); + u3_Host.fig_u.for_u = 0; +} + +/* u3_http_ef_form(): apply configuration, restart servers. +*/ +void +u3_http_ef_form(u3_noun fig) +{ + u3_noun sec, pro, log, red; + + if ( (c3n == u3r_qual(fig, &sec, &pro, &log, &red) ) || + // confirm sec is a valid (unit ^) + !( u3_nul == sec || ( c3y == u3du(sec) && + c3y == u3du(u3t(sec)) && + u3_nul == u3h(sec) ) ) || + // confirm valid flags ("loobeans") + !( c3y == pro || c3n == pro ) || + !( c3y == log || c3n == log ) || + !( c3y == red || c3n == red ) ) { + u3l_log("http: form: invalid card\n"); + u3z(fig); + return; + } + + u3_form* for_u = c3_malloc(sizeof(*for_u)); + for_u->pro = (c3_o)pro; + for_u->log = (c3_o)log; + for_u->red = (c3_o)red; + + if ( u3_nul != sec ) { + u3_noun key = u3h(u3t(sec)); + u3_noun cer = u3t(u3t(sec)); + + for_u->key_u = _http_wain_to_buf(u3k(key)); + for_u->cer_u = _http_wain_to_buf(u3k(cer)); + } + else { + for_u->key_u = uv_buf_init(0, 0); + for_u->cer_u = uv_buf_init(0, 0); + } + + u3z(fig); + _http_form_free(); + + u3_Host.fig_u.for_u = for_u; + + _http_serv_restart(); +} + +/* u3_http_io_init(): initialize http I/O. +*/ +void +u3_http_io_init(void) +{ +} + +/* u3_http_io_talk(): start http I/O. +*/ +void +u3_http_io_talk(void) +{ +} + +/* u3_http_io_exit(): shut down http. +*/ +void +u3_http_io_exit(void) +{ + // Note: nothing in this codepath can print to uH! + // it will seriously mess up your terminal + + // u3_http* htp_u; + + // for ( htp_u = u3_Host.htp_u; htp_u; htp_u = htp_u->nex_u ) { + // _http_serv_close_hard(htp_u); + // } + + // XX close u3_Host.fig_u.cli_u and con_u + + _http_release_ports_file(u3_Host.dir_c); +} + +/////////////////////////////////////////////////////////////////////////////// +/////////////////////////////////////////////////////////////////////////////// +/////////////////////////////////////////////////////////////////////////////// + +typedef enum { + u3_pars_good = 0, // success + u3_pars_fail = 1, // failure + u3_pars_moar = 2 // incomplete +} u3_proxy_pars; + +/* _proxy_alloc(): libuv buffer allocator +*/ +static void +_proxy_alloc(uv_handle_t* had_u, + size_t len_i, + uv_buf_t* buf) +{ + // len_i is always 64k, so we're ignoring it + // using fixed size 4K buffer for + // XX consider h2o_buffer_t, a pool, or something XX + void* ptr_v = c3_malloc(4096); + *buf = uv_buf_init(ptr_v, 4096); +} + +/* _proxy_warc_link(): link warc to global state. +*/ +static void +_proxy_warc_link(u3_warc* cli_u) +{ + cli_u->nex_u = u3_Host.fig_u.cli_u; + + if ( 0 != cli_u->nex_u ) { + cli_u->nex_u->pre_u = cli_u; + } + u3_Host.fig_u.cli_u = cli_u; +} + +/* _proxy_warc_unlink(): unlink warc from global state. +*/ +static void +_proxy_warc_unlink(u3_warc* cli_u) +{ + if ( 0 != cli_u->pre_u ) { + cli_u->pre_u->nex_u = cli_u->nex_u; + + if ( 0 != cli_u->nex_u ) { + cli_u->nex_u->pre_u = cli_u->pre_u; + } + } + else { + u3_Host.fig_u.cli_u = cli_u->nex_u; + + if ( 0 != cli_u->nex_u ) { + cli_u->nex_u->pre_u = 0; + } + } +} + +/* _proxy_warc_free(): free ward client +*/ +static void +_proxy_warc_free(u3_warc* cli_u) +{ + _proxy_warc_unlink(cli_u); + free(cli_u->non_u.base); + free(cli_u->hot_c); + free(cli_u); +} + +/* _proxy_warc_new(): allocate ship-specific proxy client +*/ +static u3_warc* +_proxy_warc_new(u3_http* htp_u, u3_atom sip, u3_atom non, c3_s por_s, c3_o sec) +{ + u3_warc* cli_u = c3_calloc(sizeof(*cli_u)); + cli_u->htp_u = htp_u; + cli_u->por_s = por_s; + cli_u->sec = sec; + + u3r_chubs(0, 2, cli_u->who_d, sip); + _proxy_warc_link(cli_u); + + { + c3_w len_w = u3r_met(3, non); + + c3_assert( 256 > len_w ); + + c3_y* non_y = c3_malloc(1 + len_w); + non_y[0] = (c3_y)len_w; + + u3r_bytes(0, len_w, non_y + 1, non); + + cli_u->non_u = uv_buf_init((c3_c*)non_y, 1 + len_w); + } + + u3z(non); + u3z(sip); + + return cli_u; +} + +/* _proxy_conn_link(): link con to listener or global state. +*/ +static void +_proxy_conn_link(u3_pcon* con_u) +{ + switch ( con_u->typ_e ) { + default: c3_assert(0); + + case u3_ptyp_ward: { + con_u->nex_u = u3_Host.fig_u.con_u; + + if ( 0 != con_u->nex_u ) { + con_u->nex_u->pre_u = con_u; + } + u3_Host.fig_u.con_u = con_u; + break; + } + + case u3_ptyp_prox: { + u3_prox* lis_u = con_u->src_u.lis_u; + con_u->nex_u = lis_u->con_u; + + if ( 0 != con_u->nex_u ) { + con_u->nex_u->pre_u = con_u; + } + lis_u->con_u = con_u; + break; + } + } +} + +/* _proxy_conn_unlink(): unlink con from listener or global state. +*/ +static void +_proxy_conn_unlink(u3_pcon* con_u) +{ + if ( 0 != con_u->pre_u ) { + con_u->pre_u->nex_u = con_u->nex_u; + + if ( 0 != con_u->nex_u ) { + con_u->nex_u->pre_u = con_u->pre_u; + } + } + else { + switch ( con_u->typ_e ) { + default: c3_assert(0); + + case u3_ptyp_ward: { + u3_Host.fig_u.con_u = con_u->nex_u; + + if ( 0 != con_u->nex_u ) { + con_u->nex_u->pre_u = 0; + } + break; + } + + case u3_ptyp_prox: { + u3_prox* lis_u = con_u->src_u.lis_u; + lis_u->con_u = con_u->nex_u; + + if ( 0 != con_u->nex_u ) { + con_u->nex_u->pre_u = 0; + } + break; + } + } + } +} + +/* _proxy_conn_free(): free proxy connection +*/ +static void +_proxy_conn_free(uv_handle_t* han_u) +{ + u3_pcon* con_u = han_u->data; + + if ( 0 != con_u->buf_u.base ) { + free(con_u->buf_u.base); + } + + if ( u3_ptyp_ward == con_u->typ_e ) { + _proxy_warc_free(con_u->src_u.cli_u); + } + + _proxy_conn_unlink(con_u); + + free(con_u); +} + +/* _proxy_conn_close(): close both sides of proxy connection +*/ +static void +_proxy_conn_close(u3_pcon* con_u) +{ + // XX revisit, this is called twice when con_u + // is a loopback connection and we're restarting + if ( uv_is_closing((uv_handle_t*)&con_u->don_u) ){ + return; + } + + if ( 0 != con_u->upt_u ) { + uv_close((uv_handle_t*)con_u->upt_u, (uv_close_cb)free); + } + + uv_close((uv_handle_t*)&con_u->don_u, _proxy_conn_free); +} + +/* _proxy_conn_new(): allocate proxy connection +*/ +static u3_pcon* +_proxy_conn_new(u3_proxy_type typ_e, void* src_u) +{ + u3_pcon* con_u = c3_malloc(sizeof(*con_u)); + con_u->upt_u = 0; + con_u->buf_u = uv_buf_init(0, 0); + con_u->nex_u = 0; + con_u->pre_u = 0; + + switch ( typ_e ) { + default: c3_assert(0); + + case u3_ptyp_prox: { + u3_prox* lis_u = (u3_prox*)src_u; + con_u->typ_e = typ_e; + con_u->src_u.lis_u = lis_u; + con_u->sec = lis_u->sec; + break; + } + + case u3_ptyp_ward: { + u3_warc* cli_u = (u3_warc*)src_u; + con_u->typ_e = typ_e; + con_u->src_u.cli_u = cli_u; + con_u->sec = cli_u->sec; + break; + } + } + + con_u->don_u.data = con_u; + + _proxy_conn_link(con_u); + + return con_u; +} + +typedef struct _proxy_write_ctx { + u3_pcon* con_u; + uv_stream_t* str_u; + c3_c* buf_c; +} proxy_write_ctx; + +/* _proxy_write_cb(): free uv_write_t and linked buffer. +*/ +static void +_proxy_write_cb(uv_write_t* wri_u, c3_i sas_i) +{ + if ( 0 != sas_i ) { + if ( 0 != wri_u->data ) { + proxy_write_ctx* ctx_u = wri_u->data; + + if ( ctx_u->str_u == (uv_stream_t*)ctx_u->con_u->upt_u ) { + u3l_log("proxy: write upstream: %s\n", uv_strerror(sas_i)); + } + else if ( ctx_u->str_u == (uv_stream_t*)&(ctx_u->con_u->don_u) ) { + u3l_log("proxy: write downstream: %s\n", uv_strerror(sas_i)); + } + else { + u3l_log("proxy: write: %s\n", uv_strerror(sas_i)); + } + } + else { + u3l_log("proxy: write: %s\n", uv_strerror(sas_i)); + } + } + + if ( 0 != wri_u->data ) { + proxy_write_ctx* ctx_u = wri_u->data; + free(ctx_u->buf_c); + free(ctx_u); + } + + free(wri_u); +} + +/* _proxy_write(): write buffer to proxy stream +*/ +static c3_i +_proxy_write(u3_pcon* con_u, uv_stream_t* str_u, uv_buf_t buf_u) +{ + uv_write_t* wri_u = c3_malloc(sizeof(*wri_u)); + + proxy_write_ctx* ctx_u = c3_malloc(sizeof(*ctx_u)); + ctx_u->con_u = con_u; + ctx_u->str_u = str_u; + ctx_u->buf_c = buf_u.base; + wri_u->data = ctx_u; + + c3_i sas_i; + if ( 0 != (sas_i = uv_write(wri_u, str_u, &buf_u, 1, _proxy_write_cb)) ) { + _proxy_conn_close(con_u); + _proxy_write_cb(wri_u, sas_i); + } + + return sas_i; +} + +/* _proxy_read_downstream_cb(): read from downstream, write upstream. +*/ +static void +_proxy_read_downstream_cb(uv_stream_t* don_u, + ssize_t siz_w, + const uv_buf_t* buf_u) +{ + u3_pcon* con_u = don_u->data; + + if ( 0 > siz_w ) { + if ( UV_EOF != siz_w ) { + u3l_log("proxy: read downstream: %s\n", uv_strerror(siz_w)); + } + _proxy_conn_close(con_u); + } + else { + _proxy_write(con_u, (uv_stream_t*)con_u->upt_u, + uv_buf_init(buf_u->base, siz_w)); + } +} + +/* _proxy_read_upstream_cb(): read from upstream, write downstream. +*/ +static void +_proxy_read_upstream_cb(uv_stream_t* upt_u, + ssize_t siz_w, + const uv_buf_t* buf_u) +{ + u3_pcon* con_u = upt_u->data; + + if ( 0 > siz_w ) { + if ( UV_EOF != siz_w ) { + u3l_log("proxy: read upstream: %s\n", uv_strerror(siz_w)); + } + _proxy_conn_close(con_u); + } + else { + _proxy_write(con_u, (uv_stream_t*)&(con_u->don_u), + uv_buf_init(buf_u->base, siz_w)); + } +} + +/* _proxy_fire(): send pending buffer upstream, setup full duplex. +*/ +static void +_proxy_fire(u3_pcon* con_u) +{ + if ( 0 != con_u->buf_u.base ) { + uv_buf_t fub_u = con_u->buf_u; + con_u->buf_u = uv_buf_init(0, 0); + + if ( 0 != _proxy_write(con_u, (uv_stream_t*)con_u->upt_u, fub_u) ) { + return; + } + } + + // XX set cooldown timers to close these? + + uv_read_start((uv_stream_t*)&con_u->don_u, + _proxy_alloc, _proxy_read_downstream_cb); + + uv_read_start((uv_stream_t*)con_u->upt_u, + _proxy_alloc, _proxy_read_upstream_cb); +} + +/* _proxy_loop_connect_cb(): callback for loopback proxy connect. +*/ +static void +_proxy_loop_connect_cb(uv_connect_t * upc_u, c3_i sas_i) +{ + u3_pcon* con_u = upc_u->data; + + if ( 0 != sas_i ) { + u3l_log("proxy: connect: %s\n", uv_strerror(sas_i)); + _proxy_conn_close(con_u); + } + else { + _proxy_fire(con_u); + } + + free(upc_u); +} + +/* _proxy_loop_connect(): connect to loopback. +*/ +static void +_proxy_loop_connect(u3_pcon* con_u) +{ + uv_tcp_t* upt_u = c3_malloc(sizeof(*upt_u)); + + con_u->upt_u = upt_u; + upt_u->data = con_u; + + uv_tcp_init(u3L, upt_u); + + struct sockaddr_in lop_u; + + memset(&lop_u, 0, sizeof(lop_u)); + lop_u.sin_family = AF_INET; + lop_u.sin_addr.s_addr = htonl(INADDR_LOOPBACK); + + // get the loopback port from the linked server + { + u3_http* htp_u; + + switch ( con_u->typ_e ) { + default: c3_assert(0); + + case u3_ptyp_ward: { + htp_u = con_u->src_u.cli_u->htp_u; + break; + } + + case u3_ptyp_prox: { + htp_u = con_u->src_u.lis_u->htp_u; + break; + } + } + + // XX make unpossible? + c3_assert( (0 != htp_u) && (0 != htp_u->por_s) ); + + lop_u.sin_port = htons(htp_u->por_s); + } + + uv_connect_t* upc_u = c3_malloc(sizeof(*upc_u)); + upc_u->data = con_u; + + c3_i sas_i; + + if ( 0 != (sas_i = uv_tcp_connect(upc_u, upt_u, + (const struct sockaddr*)&lop_u, + _proxy_loop_connect_cb)) ) { + u3l_log("proxy: connect: %s\n", uv_strerror(sas_i)); + free(upc_u); + _proxy_conn_close(con_u); + } +} + +/* _proxy_wcon_link(): link wcon to ward. +*/ +static void +_proxy_wcon_link(u3_wcon* won_u, u3_ward* rev_u) +{ + won_u->nex_u = rev_u->won_u; + rev_u->won_u = won_u; +} + +/* _proxy_wcon_unlink(): unlink wcon from ward. +*/ +static void +_proxy_wcon_unlink(u3_wcon* won_u) +{ + u3_ward* rev_u = won_u->rev_u; + + if ( rev_u->won_u == won_u ) { + rev_u->won_u = won_u->nex_u; + } + else { + u3_wcon* pre_u = rev_u->won_u; + + // XX glories of linear search + // + while ( 0 != pre_u ) { + if ( pre_u->nex_u == won_u ) { + pre_u->nex_u = won_u->nex_u; + } + else pre_u = pre_u->nex_u; + } + } +} + +/* _proxy_wcon_free(): free ward upstream candidate. +*/ +static void +_proxy_wcon_free(uv_handle_t* han_u) +{ + u3_wcon* won_u = han_u->data; + + // Note: not unlinked here, freed concurrent with u3_ward + free(won_u); +} + +/* _proxy_wcon_close(): close ward upstream candidate. +*/ +static void +_proxy_wcon_close(u3_wcon* won_u) +{ + uv_read_stop((uv_stream_t*)&won_u->upt_u); + uv_close((uv_handle_t*)&won_u->upt_u, _proxy_wcon_free); +} + +/* _proxy_wcon_new(): allocate ward upstream candidate. +*/ +static u3_wcon* +_proxy_wcon_new(u3_ward* rev_u) +{ + u3_wcon* won_u = c3_malloc(sizeof(*won_u)); + won_u->upt_u.data = won_u; + won_u->rev_u = rev_u; + won_u->nex_u = 0; + + _proxy_wcon_link(won_u, rev_u); + + return won_u; +} + +/* _proxy_ward_link(): link ward to listener. +*/ +static void +_proxy_ward_link(u3_pcon* con_u, u3_ward* rev_u) +{ + // XX link also to con_u as upstream? + c3_assert( u3_ptyp_prox == con_u->typ_e ); + + u3_prox* lis_u = con_u->src_u.lis_u; + + rev_u->nex_u = lis_u->rev_u; + + if ( 0 != rev_u->nex_u ) { + rev_u->nex_u->pre_u = rev_u; + } + lis_u->rev_u = rev_u; +} + +/* _proxy_ward_unlink(): unlink ward from listener. +*/ +static void +_proxy_ward_unlink(u3_ward* rev_u) +{ + if ( 0 != rev_u->pre_u ) { + rev_u->pre_u->nex_u = rev_u->nex_u; + + if ( 0 != rev_u->nex_u ) { + rev_u->nex_u->pre_u = rev_u->pre_u; + } + } + else { + c3_assert( u3_ptyp_prox == rev_u->con_u->typ_e ); + + u3_prox* lis_u = rev_u->con_u->src_u.lis_u; + lis_u->rev_u = rev_u->nex_u; + + if ( 0 != rev_u->nex_u ) { + rev_u->nex_u->pre_u = 0; + } + } +} + +/* _proxy_ward_free(): free reverse proxy listener +*/ +static void +_proxy_ward_free(uv_handle_t* han_u) +{ + u3_ward* rev_u = han_u->data; + + free(rev_u->non_u.base); + free(rev_u); +} + +/* _proxy_ward_close_timer(): close ward timer +*/ +static void +_proxy_ward_close_timer(uv_handle_t* han_u) +{ + u3_ward* rev_u = han_u->data; + + uv_close((uv_handle_t*)&rev_u->tim_u, _proxy_ward_free); +} + +/* _proxy_ward_close(): close ward (ship-specific listener) +*/ +static void +_proxy_ward_close(u3_ward* rev_u) +{ + _proxy_ward_unlink(rev_u); + + while ( 0 != rev_u->won_u ) { + _proxy_wcon_close(rev_u->won_u); + rev_u->won_u = rev_u->won_u->nex_u; + } + + uv_close((uv_handle_t*)&rev_u->tcp_u, _proxy_ward_close_timer); +} + +/* _proxy_ward_new(): allocate reverse proxy listener +*/ +static u3_ward* +_proxy_ward_new(u3_pcon* con_u, u3_atom sip) +{ + u3_ward* rev_u = c3_calloc(sizeof(*rev_u)); + rev_u->tcp_u.data = rev_u; + rev_u->tim_u.data = rev_u; + rev_u->con_u = con_u; + + u3r_chubs(0, 2, rev_u->who_d, sip); + _proxy_ward_link(con_u, rev_u); + + u3z(sip); + + return rev_u; +} + +/* _proxy_wcon_peek_read_cb(): authenticate connection by checking nonce. +*/ +static void +_proxy_wcon_peek_read_cb(uv_stream_t* upt_u, + ssize_t siz_w, + const uv_buf_t* buf_u) +{ + u3_wcon* won_u = upt_u->data; + u3_ward* rev_u = won_u->rev_u; + + if ( 0 > siz_w ) { + if ( UV_EOF != siz_w ) { + u3l_log("proxy: ward peek: %s\n", uv_strerror(siz_w)); + } + _proxy_wcon_close(won_u); + } + else { + uv_read_stop(upt_u); + + c3_w len_w = rev_u->non_u.len; + + if ( ((len_w + 1) != siz_w) || + (len_w != buf_u->base[0]) || + (0 != memcmp(rev_u->non_u.base, buf_u->base + 1, len_w)) ) { + // u3l_log("proxy: ward auth fail\n"); + _proxy_wcon_unlink(won_u); + _proxy_wcon_close(won_u); + } + else { + _proxy_wcon_unlink(won_u); + + u3_pcon* con_u = rev_u->con_u; + con_u->upt_u = (uv_tcp_t*)&won_u->upt_u; + con_u->upt_u->data = con_u; + + _proxy_fire(con_u); + _proxy_ward_close(rev_u); + } + } +} + +/* _proxy_wcon_peek(): peek at a new incoming connection +*/ +static void +_proxy_wcon_peek(u3_wcon* won_u) +{ + uv_read_start((uv_stream_t*)&won_u->upt_u, + _proxy_alloc, _proxy_wcon_peek_read_cb); +} + +/* _proxy_ward_accept(): accept new connection on ward +*/ +static void +_proxy_ward_accept(u3_ward* rev_u) +{ + u3_wcon* won_u = _proxy_wcon_new(rev_u); + + uv_tcp_init(u3L, &won_u->upt_u); + + c3_i sas_i; + + if ( 0 != (sas_i = uv_accept((uv_stream_t*)&rev_u->tcp_u, + (uv_stream_t*)&won_u->upt_u)) ) { + u3l_log("proxy: accept: %s\n", uv_strerror(sas_i)); + _proxy_wcon_close(won_u); + } + else { + _proxy_wcon_peek(won_u); + } +} + +/* _proxy_ward_listen_cb(): listen callback for ward +*/ +static void +_proxy_ward_listen_cb(uv_stream_t* tcp_u, c3_i sas_i) +{ + u3_ward* rev_u = (u3_ward*)tcp_u; + + if ( 0 != sas_i ) { + u3l_log("proxy: ward: %s\n", uv_strerror(sas_i)); + } + else { + _proxy_ward_accept(rev_u); + } +} + +/* _proxy_ward_timer_cb(): expiration timer for ward +*/ +static void +_proxy_ward_timer_cb(uv_timer_t* tim_u) +{ + u3_ward* rev_u = tim_u->data; + + if ( 0 != rev_u ) { + u3l_log("proxy: ward expired: %d\n", rev_u->por_s); + _proxy_ward_close(rev_u); + _proxy_conn_close(rev_u->con_u); + } +} + +/* _proxy_ward_plan(): notify ship of new ward +*/ +static void +_proxy_ward_plan(u3_ward* rev_u) +{ + u3_noun non; + + { + c3_w* non_w = c3_malloc(64); + c3_w len_w; + + c3_rand(non_w); + + non = u3i_words(16, non_w); + len_w = u3r_met(3, non); + + // the nonce is saved to authenticate u3_wcon + // and will be freed with u3_ward + // + rev_u->non_u = uv_buf_init((c3_c*)non_w, len_w); + } + + // XX confirm duct + u3_noun pax = u3nq(u3_blip, c3__http, c3__prox, + u3nc(u3k(u3A->sen), u3_nul)); + + u3_noun wis = u3nc(c3__wise, u3nq(u3i_chubs(2, rev_u->who_d), + rev_u->por_s, + u3k(rev_u->con_u->sec), + non)); + u3_pier_plan(pax, wis); +} + +/* _proxy_ward_start(): start ward (ship-specific listener). +*/ +static void +_proxy_ward_start(u3_pcon* con_u, u3_noun sip) +{ + u3_ward* rev_u = _proxy_ward_new(con_u, u3k(sip)); + + uv_tcp_init(u3L, &rev_u->tcp_u); + + struct sockaddr_in add_u; + c3_i add_i = sizeof(add_u); + memset(&add_u, 0, add_i); + add_u.sin_family = AF_INET; + add_u.sin_addr.s_addr = INADDR_ANY; + add_u.sin_port = 0; // first available + + c3_i sas_i; + + if ( 0 != (sas_i = uv_tcp_bind(&rev_u->tcp_u, + (const struct sockaddr*)&add_u, 0)) || + 0 != (sas_i = uv_listen((uv_stream_t*)&rev_u->tcp_u, + TCP_BACKLOG, _proxy_ward_listen_cb)) || + 0 != (sas_i = uv_tcp_getsockname(&rev_u->tcp_u, + (struct sockaddr*)&add_u, &add_i))) { + u3l_log("proxy: ward: %s\n", uv_strerror(sas_i)); + _proxy_ward_close(rev_u); + _proxy_conn_close(con_u); + } + else { + rev_u->por_s = ntohs(add_u.sin_port); + +#if 0 + { + u3_noun who = u3dc("scot", 'p', u3k(sip)); + c3_c* who_c = u3r_string(who); + u3l_log("\r\nward for %s started on %u\r\n", who_c, rev_u->por_s); + free(who_c); + u3z(who); + } +#endif + + _proxy_ward_plan(rev_u); + + // XX how long? + // + uv_timer_init(u3L, &rev_u->tim_u); + uv_timer_start(&rev_u->tim_u, _proxy_ward_timer_cb, 300 * 1000, 0); + } + + u3z(sip); +} + +/* _proxy_ward_connect_cb(): ward connection callback +*/ +static void +_proxy_ward_connect_cb(uv_connect_t * upc_u, c3_i sas_i) +{ + u3_pcon* con_u = upc_u->data; + + if ( 0 != sas_i ) { + u3l_log("proxy: ward connect: %s\n", uv_strerror(sas_i)); + _proxy_conn_close(con_u); + } + else { + // XX can con_u close before the loopback conn is established? + _proxy_loop_connect(con_u); + + u3_warc* cli_u = con_u->src_u.cli_u; + + // send %that nonce to ward for authentication + _proxy_write(con_u, (uv_stream_t*)&(con_u->don_u), cli_u->non_u); + + cli_u->non_u = uv_buf_init(0, 0); + } + + free(upc_u); +} + +/* _proxy_ward_connect(): connect to remote ward +*/ +static void +_proxy_ward_connect(u3_warc* cli_u) +{ + u3_pcon* con_u = _proxy_conn_new(u3_ptyp_ward, cli_u); + + uv_tcp_init(u3L, &con_u->don_u); + + struct sockaddr_in add_u; + + memset(&add_u, 0, sizeof(add_u)); + add_u.sin_family = AF_INET; + add_u.sin_addr.s_addr = htonl(cli_u->ipf_w); + add_u.sin_port = htons(cli_u->por_s); + + uv_connect_t* upc_u = c3_malloc(sizeof(*upc_u)); + upc_u->data = con_u; + + c3_i sas_i; + + if ( 0 != (sas_i = uv_tcp_connect(upc_u, &con_u->don_u, + (const struct sockaddr*)&add_u, + _proxy_ward_connect_cb)) ) { + u3l_log("proxy: ward connect: %s\n", uv_strerror(sas_i)); + free(upc_u); + _proxy_conn_close(con_u); + } +} + +/* _proxy_ward_resolve_cb(): ward IP address resolution callback +*/ +static void +_proxy_ward_resolve_cb(uv_getaddrinfo_t* adr_u, + c3_i sas_i, + struct addrinfo* aif_u) +{ + u3_warc* cli_u = adr_u->data; + + if ( 0 != sas_i ) { + u3l_log("proxy: ward: resolve: %s\n", uv_strerror(sas_i)); + _proxy_warc_free(cli_u); + } + else { + // XX traverse struct a la _ames_czar_cb + cli_u->ipf_w = ntohl(((struct sockaddr_in *)aif_u->ai_addr)->sin_addr.s_addr); + _proxy_ward_connect(cli_u); + } + + free(adr_u); + uv_freeaddrinfo(aif_u); +} + +/* _proxy_reverse_resolve(): resolve IP address of remote ward +*/ +static void +_proxy_ward_resolve(u3_warc* cli_u) +{ + uv_getaddrinfo_t* adr_u = c3_malloc(sizeof(*adr_u)); + adr_u->data = cli_u; + + struct addrinfo hin_u; + memset(&hin_u, 0, sizeof(struct addrinfo)); + + hin_u.ai_family = PF_INET; + hin_u.ai_socktype = SOCK_STREAM; + hin_u.ai_protocol = IPPROTO_TCP; + + // XX why the conditional? + // + if ( 0 == cli_u->hot_c ) { + u3_noun sip = u3dc("scot", 'p', u3i_chubs(2, cli_u->who_d)); + c3_c* sip_c = u3r_string(sip); + c3_w len_w = 1 + strlen(sip_c) + strlen(PROXY_DOMAIN); + cli_u->hot_c = c3_malloc(len_w); + // incremented to skip '~' + snprintf(cli_u->hot_c, len_w, "%s.%s", sip_c + 1, PROXY_DOMAIN); + + free(sip_c); + u3z(sip); + } + + c3_i sas_i; + + if ( 0 != (sas_i = uv_getaddrinfo(u3L, adr_u, _proxy_ward_resolve_cb, + cli_u->hot_c, 0, &hin_u)) ) { + u3l_log("proxy: ward: resolve: %s\n", uv_strerror(sas_i)); + _proxy_warc_free(cli_u); + } +} + +/* _proxy_parse_host(): parse plaintext buffer for Host header +*/ +static u3_proxy_pars +_proxy_parse_host(const uv_buf_t* buf_u, c3_c** hot_c) +{ + struct phr_header hed_u[H2O_MAX_HEADERS]; + size_t hed_t = H2O_MAX_HEADERS; + + { + // unused + c3_i ver_i; + const c3_c* met_c; + size_t met_t; + const c3_c* pat_c; + size_t pat_t; + + size_t len_t = buf_u->len < H2O_MAX_REQLEN ? buf_u->len : H2O_MAX_REQLEN; + // XX slowloris? + c3_i las_i = 0; + c3_i sas_i; + + sas_i = phr_parse_request(buf_u->base, len_t, &met_c, &met_t, + &pat_c, &pat_t, &ver_i, hed_u, &hed_t, las_i); + + switch ( sas_i ) { + case -1: return u3_pars_fail; + case -2: return u3_pars_moar; + } + } + + const h2o_token_t* tok_t; + size_t i; + + for ( i = 0; i < hed_t; i++ ) { + // XX in-place, copy first + h2o_strtolower((c3_c*)hed_u[i].name, hed_u[i].name_len); + + if ( 0 != (tok_t = h2o_lookup_token(hed_u[i].name, hed_u[i].name_len)) ) { + if ( tok_t->is_init_header_special && H2O_TOKEN_HOST == tok_t ) { + c3_c* val_c; + c3_c* por_c; + + val_c = c3_malloc(1 + hed_u[i].value_len); + val_c[hed_u[i].value_len] = 0; + memcpy(val_c, hed_u[i].value, hed_u[i].value_len); + + // 'truncate' by replacing port separator ':' with 0 + if ( 0 != (por_c = strchr(val_c, ':')) ) { + por_c[0] = 0; + } + + *hot_c = val_c; + break; + } + } + } + + return u3_pars_good; +} + +/* _proxy_parse_sni(): parse clienthello buffer for SNI +*/ +static u3_proxy_pars +_proxy_parse_sni(const uv_buf_t* buf_u, c3_c** hot_c) +{ + c3_i sas_i = parse_tls_header((const uint8_t*)buf_u->base, + buf_u->len, hot_c); + + if ( 0 > sas_i ) { + switch ( sas_i ) { + case -1: return u3_pars_moar; + case -2: return u3_pars_good; // SNI not present + default: return u3_pars_fail; + } + } + + return u3_pars_good; +} + +/* _proxy_parse_ship(): determine destination (unit ship) for proxied request +*/ +static u3_noun +_proxy_parse_ship(c3_c* hot_c) +{ + if ( 0 == hot_c ) { + return u3_nul; + } + else { + c3_c* dom_c = strchr(hot_c, '.'); + + if ( 0 == dom_c ) { + return u3_nul; + } + else { + // length of the first subdomain + // + c3_w dif_w = dom_c - hot_c; + c3_w dns_w = strlen(PROXY_DOMAIN); + + // validate that everything after the first subdomain + // matches the proxy domain + // (skipped if networking is disabled) + // + if ( (c3y == u3_Host.ops_u.net) && + ( (dns_w != strlen(hot_c) - (dif_w + 1)) || + (0 != strncmp(dom_c + 1, PROXY_DOMAIN, dns_w)) ) ) + { + return u3_nul; + } + else { + // attempt to parse the first subdomain as a @p + // + u3_noun sip; + c3_c* sip_c = c3_malloc(2 + dif_w); + + strncpy(sip_c + 1, hot_c, dif_w); + sip_c[0] = '~'; + sip_c[1 + dif_w] = 0; + + sip = u3dc("slaw", 'p', u3i_string(sip_c)); + free(sip_c); + + return sip; + } + } + } +} + +/* _proxy_dest(): proxy to destination +*/ +static void +_proxy_dest(u3_pcon* con_u, u3_noun sip) +{ + if ( u3_nul == sip ) { + _proxy_loop_connect(con_u); + } + else { + // XX revisit + u3_pier* pir_u = u3_pier_stub(); + u3_noun our = u3i_chubs(2, pir_u->who_d); + u3_noun hip = u3t(sip); + + if ( c3y == u3r_sing(our, hip) ) { + _proxy_loop_connect(con_u); + } + else { + // XX we should u3v_peek %j /=sein= to confirm + // that we're sponsoring this ship + // + _proxy_ward_start(con_u, u3k(hip)); + } + + u3z(our); + } + + u3z(sip); +} + +static void _proxy_peek_read(u3_pcon* con_u); + +/* _proxy_peek(): peek at proxied request for destination +*/ +static void +_proxy_peek(u3_pcon* con_u) +{ + c3_c* hot_c = 0; + + u3_proxy_pars sat_e = ( c3y == con_u->sec ) ? + _proxy_parse_sni(&con_u->buf_u, &hot_c) : + _proxy_parse_host(&con_u->buf_u, &hot_c); + + switch ( sat_e ) { + default: c3_assert(0); + + case u3_pars_fail: { + u3l_log("proxy: peek fail\n"); + _proxy_conn_close(con_u); + break; + } + + case u3_pars_moar: { + u3l_log("proxy: peek moar\n"); + // XX count retries, fail after some n + _proxy_peek_read(con_u); + break; + } + + case u3_pars_good: { + u3_noun sip = _proxy_parse_ship(hot_c); + _proxy_dest(con_u, sip); + break; + } + } + + if ( 0 != hot_c ) { + free(hot_c); + } +} + +/* _proxy_peek_read_cb(): read callback for peeking at proxied request +*/ +static void +_proxy_peek_read_cb(uv_stream_t* don_u, + ssize_t siz_w, + const uv_buf_t* buf_u) +{ + u3_pcon* con_u = don_u->data; + + if ( 0 > siz_w ) { + if ( UV_EOF != siz_w ) { + u3l_log("proxy: peek: %s\n", uv_strerror(siz_w)); + } + _proxy_conn_close(con_u); + } + else { + uv_read_stop(don_u); + + if ( 0 == con_u->buf_u.base ) { + con_u->buf_u = uv_buf_init(buf_u->base, siz_w); + } + else { + c3_w len_w = siz_w + con_u->buf_u.len; + void* ptr_v = c3_realloc(con_u->buf_u.base, len_w); + + memcpy(ptr_v + con_u->buf_u.len, buf_u->base, siz_w); + con_u->buf_u = uv_buf_init(ptr_v, len_w); + + free(buf_u->base); + } + + _proxy_peek(con_u); + } +} + +/* _proxy_peek_read(): start read to peek at proxied request +*/ +static void +_proxy_peek_read(u3_pcon* con_u) +{ + uv_read_start((uv_stream_t*)&con_u->don_u, + _proxy_alloc, _proxy_peek_read_cb); +} + +/* _proxy_serv_free(): free proxy listener +*/ +static void +_proxy_serv_free(u3_prox* lis_u) +{ + u3_pcon* con_u = lis_u->con_u; + + while ( con_u ) { + _proxy_conn_close(con_u); + con_u = con_u->nex_u; + } + + u3_ward* rev_u = lis_u->rev_u; + + while ( rev_u ) { + _proxy_ward_close(rev_u); + rev_u = rev_u->nex_u; + } + + // not unlinked here, owned directly by htp_u + + free(lis_u); +} + +/* _proxy_serv_close(): close proxy listener +*/ +static void +_proxy_serv_close(u3_prox* lis_u) +{ + uv_close((uv_handle_t*)&lis_u->sev_u, (uv_close_cb)_proxy_serv_free); +} + +/* _proxy_serv_new(): allocate proxy listener +*/ +static u3_prox* +_proxy_serv_new(u3_http* htp_u, c3_s por_s, c3_o sec) +{ + u3_prox* lis_u = c3_malloc(sizeof(*lis_u)); + lis_u->sev_u.data = lis_u; + lis_u->por_s = por_s; + lis_u->sec = sec; + lis_u->htp_u = htp_u; + lis_u->con_u = 0; + lis_u->rev_u = 0; + + // not linked here, owned directly by htp_u + + return lis_u; +} + +/* _proxy_serv_accept(): accept new connection. +*/ +static void +_proxy_serv_accept(u3_prox* lis_u) +{ + u3_pcon* con_u = _proxy_conn_new(u3_ptyp_prox, lis_u); + + uv_tcp_init(u3L, &con_u->don_u); + + c3_i sas_i; + if ( 0 != (sas_i = uv_accept((uv_stream_t*)&lis_u->sev_u, + (uv_stream_t*)&con_u->don_u)) ) { + u3l_log("proxy: accept: %s\n", uv_strerror(sas_i)); + _proxy_conn_close(con_u); + } + else { + _proxy_peek_read(con_u); + } +} + +/* _proxy_serv_listen_cb(): listen callback for proxy server. +*/ +static void +_proxy_serv_listen_cb(uv_stream_t* sev_u, c3_i sas_i) +{ + u3_prox* lis_u = (u3_prox*)sev_u; + + if ( 0 != sas_i ) { + u3l_log("proxy: listen_cb: %s\n", uv_strerror(sas_i)); + } + else { + _proxy_serv_accept(lis_u); + } +} + +/* _proxy_serv_start(): start reverse TCP proxy server. +*/ +static u3_prox* +_proxy_serv_start(u3_prox* lis_u) +{ + uv_tcp_init(u3L, &lis_u->sev_u); + + struct sockaddr_in add_u; + + memset(&add_u, 0, sizeof(add_u)); + add_u.sin_family = AF_INET; + add_u.sin_addr.s_addr = INADDR_ANY; + + /* Try ascending ports. + */ + while ( 1 ) { + c3_i sas_i; + + add_u.sin_port = htons(lis_u->por_s); + + if ( 0 != (sas_i = uv_tcp_bind(&lis_u->sev_u, + (const struct sockaddr*)&add_u, 0)) || + 0 != (sas_i = uv_listen((uv_stream_t*)&lis_u->sev_u, + TCP_BACKLOG, _proxy_serv_listen_cb)) ) { + if ( (UV_EADDRINUSE == sas_i) || (UV_EACCES == sas_i) ) { + if ( (c3y == lis_u->sec) && (443 == lis_u->por_s) ) { + lis_u->por_s = 9443; + } + else if ( (c3n == lis_u->sec) && (80 == lis_u->por_s) ) { + lis_u->por_s = 9080; + } + else { + lis_u->por_s++; + } + + continue; + } + + u3l_log("proxy: listen: %s\n", uv_strerror(sas_i)); + _proxy_serv_free(lis_u); + return 0; + } + + return lis_u; + } +} + +/* u3_http_ef_that(): reverse proxy requested connection notification. +*/ +void +u3_http_ef_that(u3_noun tat) +{ + u3_noun sip, por, sec, non; + + if ( ( c3n == u3r_qual(tat, &sip, &por, &sec, &non) ) || + ( c3n == u3ud(sip) ) || + ( c3n == u3a_is_cat(por) ) || + !( c3y == sec || c3n == sec ) || + ( c3n == u3ud(non) ) ) { + u3l_log("http: that: invalid card\n"); + } + else { + u3_http* htp_u; + u3_warc* cli_u; + + for ( htp_u = u3_Host.htp_u; (0 != htp_u); htp_u = htp_u->nex_u ) { + if ( c3n == htp_u->lop && sec == htp_u->sec ) { + break; + } + } + + // XX we should inform our sponsor if we aren't running a server + // so this situation can be avoided + // + if ( 0 == htp_u ) { + u3l_log("http: that: no %s server\n", + (c3y == sec) ? "secure" : "insecure"); + } + else { + cli_u = _proxy_warc_new(htp_u, (u3_atom)u3k(sip), (u3_atom)u3k(non), + (c3_s)por, (c3_o)sec); + + // resolve to loopback if networking is disabled + // + if ( c3n == u3_Host.ops_u.net ) { + cli_u->ipf_w = INADDR_LOOPBACK; + _proxy_ward_connect(cli_u); + } + else { + _proxy_ward_resolve(cli_u); + } + } + } + + u3z(tat); +} diff --git a/pkg/hs/vere/notes/c/lmdb.c b/pkg/hs/vere/notes/c/lmdb.c new file mode 100644 index 000000000..8a5fd9d90 --- /dev/null +++ b/pkg/hs/vere/notes/c/lmdb.c @@ -0,0 +1,670 @@ +/* vere/lmdb.c +*/ + +#include "all.h" + +#include +#include + +#include "vere/vere.h" + +// Event log persistence for Urbit +// +// Persistence works by having an lmdb environment opened on the main +// thread. This environment is used to create read-only transactions +// synchronously when needed. +// +// But the majority of lmdb writes operate asynchronously in the uv worker +// pool. Since individual transactions are bound to threads, we perform all +// blocking writing on worker threads. +// +// We perform the very first metadata writes on the main thread because we +// can't do anything until they persist. + +/* u3_lmdb_init(): Opens up a log environment +** +** Precondition: log_path points to an already created directory +*/ +MDB_env* u3_lmdb_init(const char* log_path) +{ + MDB_env* env = 0; + c3_w ret_w = mdb_env_create(&env); + if (ret_w != 0) { + u3l_log("lmdb: init fail: %s\n", mdb_strerror(ret_w)); + return 0; + } + + // Our databases have up to three tables: META, EVENTS, and GRAINS. + ret_w = mdb_env_set_maxdbs(env, 3); + if (ret_w != 0) { + u3l_log("lmdb: failed to set number of databases: %s\n", mdb_strerror(ret_w)); + return 0; + } + + // TODO: Start with forty gigabytes for the maximum event log size. We'll + // need to do something more sophisticated for real in the long term, though. + // + const size_t forty_gigabytes = 42949672960; + ret_w = mdb_env_set_mapsize(env, forty_gigabytes); + if (ret_w != 0) { + u3l_log("lmdb: failed to set database size: %s\n", mdb_strerror(ret_w)); + return 0; + } + + ret_w = mdb_env_open(env, log_path, 0, 0664); + if (ret_w != 0) { + u3l_log("lmdb: failed to open event log: %s\n", mdb_strerror(ret_w)); + return 0; + } + + return env; +} + +/* u3_lmdb_shutdown(): Shuts down lmdb +*/ +void u3_lmdb_shutdown(MDB_env* env) +{ + mdb_env_close(env); +} + +/* _perform_put_on_database_raw(): Writes a key/value pair to a specific +** database as part of a transaction. +** +** The raw version doesn't take ownership of either key/value and performs no +** nock calculations, so it is safe to call from any thread. +*/ +static +c3_o _perform_put_on_database_raw(MDB_txn* transaction_u, + MDB_dbi database_u, + c3_w flags, + void* key, + size_t key_len, + void* value, + size_t value_len) { + MDB_val key_val, value_val; + + key_val.mv_size = key_len; + key_val.mv_data = key; + + value_val.mv_size = value_len; + value_val.mv_data = value; + + c3_w ret_w = mdb_put(transaction_u, database_u, &key_val, &value_val, flags); + if (ret_w != 0) { + u3l_log("lmdb: write failed: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + return c3y; +} + +/* _perform_get_on_database_raw(): Reads a key/value pair to a specific +** database as part of a transaction. +*/ +static +c3_o _perform_get_on_database_raw(MDB_txn* transaction_u, + MDB_dbi database_u, + void* key, + size_t key_len, + MDB_val* value) { + MDB_val key_val; + key_val.mv_size = key_len; + key_val.mv_data = key; + + c3_w ret_w = mdb_get(transaction_u, database_u, &key_val, value); + if (ret_w != 0) { + u3l_log("lmdb: read failed: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + return c3y; +} + +/* _perform_put_on_database_noun(): Writes a noun to the database. +** +** This requires access to the loom so it must only be run from the libuv +** thread. +*/ +static +c3_o _perform_put_on_database_noun(MDB_txn* transaction_u, + MDB_dbi database_u, + c3_c* key, + u3_noun noun) { + // jam noun into an atom representation + u3_atom mat = u3ke_jam(noun); + + // copy the jammed noun into a byte buffer we can hand to lmdb + c3_w len_w = u3r_met(3, mat); + c3_y* bytes_y = (c3_y*) malloc(len_w); + u3r_bytes(0, len_w, bytes_y, mat); + + c3_o ret = _perform_put_on_database_raw( + transaction_u, + database_u, + 0, + key, strlen(key), + bytes_y, len_w); + + free(bytes_y); + u3z(mat); + + return ret; +} + +/* _perform_get_on_database_noun(): Reads a noun from the database. +** +** This requires access to the loom so it must only be run from the libuv +** thread. +*/ +static +c3_o _perform_get_on_database_noun(MDB_txn* transaction_u, + MDB_dbi database_u, + c3_c* key, + u3_noun* noun) { + MDB_val value_val; + c3_o ret = _perform_get_on_database_raw(transaction_u, + database_u, + key, strlen(key), + &value_val); + if (ret == c3n) { + return c3y; + } + + // Take the bytes and cue them. + u3_atom raw_atom = u3i_bytes(value_val.mv_size, value_val.mv_data); + *noun = u3qe_cue(raw_atom); + return c3y; +} + +/* u3_lmdb_write_request: Events to be written together +*/ +struct u3_lmdb_write_request { + // The event number of the first event. + c3_d first_event; + + // The number of events in this write request. Nonzero. + c3_d event_count; + + // An array of serialized event datas. The array size is |event_count|. We + // perform the event serialization on the main thread so we can read the loom + // and write into a malloced structure for the worker thread. + void** malloced_event_data; + + // An array of sizes of serialized event datas. We keep track of this for the + // database write. + size_t* malloced_event_data_size; +}; + +/* u3_lmdb_build_write_request(): Allocates and builds a write request +*/ +struct u3_lmdb_write_request* +u3_lmdb_build_write_request(u3_writ* event_u, c3_d count) +{ + struct u3_lmdb_write_request* request = + c3_malloc(sizeof(struct u3_lmdb_write_request)); + request->first_event = event_u->evt_d; + request->event_count = count; + request->malloced_event_data = c3_malloc(sizeof(void*) * count); + request->malloced_event_data_size = c3_malloc(sizeof(size_t) * count); + + for (c3_d i = 0; i < count; ++i) { + // Sanity check that the events in u3_writ are in order. + c3_assert(event_u->evt_d == (request->first_event + i)); + + // Serialize the jammed event log entry into a malloced buffer we can send + // to the other thread. + c3_w siz_w = u3r_met(3, event_u->mat); + c3_y* data_u = c3_calloc(siz_w); + u3r_bytes(0, siz_w, data_u, event_u->mat); + + request->malloced_event_data[i] = data_u; + request->malloced_event_data_size[i] = siz_w; + + event_u = event_u->nex_u; + } + + return request; +} + +/* u3_lmdb_free_write_request(): Frees a write request +*/ +void u3_lmdb_free_write_request(struct u3_lmdb_write_request* request) { + for (c3_d i = 0; i < request->event_count; ++i) + free(request->malloced_event_data[i]); + + free(request->malloced_event_data); + free(request->malloced_event_data_size); + free(request); +} + +/* _write_request_data: callback struct for u3_lmdb_write_event() +*/ +struct _write_request_data { + // The database environment to write to. This object is thread-safe, though + // the transactions and handles opened from it are explicitly not. + MDB_env* environment; + + // The pier that we're writing for. + u3_pier* pir_u; + + // The encapsulated request. This may contain multiple event writes. + struct u3_lmdb_write_request* request; + + // Whether the write completed successfully. + c3_o success; + + // Called on main loop thread on completion. + void (*on_complete)(c3_o, u3_pier*, c3_d, c3_d); +}; + +/* _u3_lmdb_write_event_cb(): Implementation of u3_lmdb_write_event() +** +** This is always run on a libuv background worker thread; actual nouns cannot +** be touched here. +*/ +static void _u3_lmdb_write_event_cb(uv_work_t* req) { + struct _write_request_data* data = req->data; + + // Creates the write transaction. + MDB_txn* transaction_u; + c3_w ret_w = mdb_txn_begin(data->environment, + (MDB_txn *) NULL, + 0, /* flags */ + &transaction_u); + if (0 != ret_w) { + u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); + return; + } + + // Opens the database as part of the transaction. + c3_w flags_w = MDB_CREATE | MDB_INTEGERKEY; + MDB_dbi database_u; + ret_w = mdb_dbi_open(transaction_u, + "EVENTS", + flags_w, + &database_u); + if (0 != ret_w) { + u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); + return; + } + + struct u3_lmdb_write_request* request = data->request; + for (c3_d i = 0; i < request->event_count; ++i) { + c3_d event_number = request->first_event + i; + + c3_o success = _perform_put_on_database_raw( + transaction_u, + database_u, + MDB_NOOVERWRITE, + &event_number, + sizeof(c3_d), + request->malloced_event_data[i], + request->malloced_event_data_size[i]); + + if (success == c3n) { + u3l_log("lmdb: failed to write event %" PRIu64 "\n", event_number); + mdb_txn_abort(transaction_u); + data->success = c3n; + return; + } + } + + ret_w = mdb_txn_commit(transaction_u); + if (0 != ret_w) { + if ( request->event_count == 1 ) { + u3l_log("lmdb: failed to commit event %" PRIu64 ": %s\n", + request->first_event, + mdb_strerror(ret_w)); + } else { + c3_d through = request->first_event + request->event_count - 1ULL; + u3l_log("lmdb: failed to commit events %" PRIu64 " through %" PRIu64 + ": %s\n", + request->first_event, + through, + mdb_strerror(ret_w)); + } + data->success = c3n; + return; + } + + data->success = c3y; +} + +/* _u3_lmdb_write_event_after_cb(): Implementation of u3_lmdb_write_event() +** +** This is always run on the main loop thread after the worker thread event +** completes. +*/ +static void _u3_lmdb_write_event_after_cb(uv_work_t* req, int status) { + struct _write_request_data* data = req->data; + + data->on_complete(data->success, + data->pir_u, + data->request->first_event, + data->request->event_count); + + u3_lmdb_free_write_request(data->request); + free(data); + free(req); +} + +/* u3_lmdb_write_event(): Asynchronously writes events to the database. +** +** This writes all the passed in events along with log metadata updates to the +** database as a single transaction on a worker thread. Once the transaction +** is completed, it calls the passed in callback on the main loop thread. +*/ +void u3_lmdb_write_event(MDB_env* environment, + u3_pier* pir_u, + struct u3_lmdb_write_request* request_u, + void (*on_complete)(c3_o, u3_pier*, c3_d, c3_d)) +{ + // Structure to pass to the worker thread. + struct _write_request_data* data = c3_malloc(sizeof(struct _write_request_data)); + data->environment = environment; + data->pir_u = pir_u; + data->request = request_u; + data->on_complete = on_complete; + data->success = c3n; + + // Queue asynchronous work to happen on the other thread. + uv_work_t* req = c3_malloc(sizeof(uv_work_t)); + req->data = data; + + uv_queue_work(uv_default_loop(), + req, + _u3_lmdb_write_event_cb, + _u3_lmdb_write_event_after_cb); +} + +/* u3_lmdb_read_events(): Synchronously reads events from the database. +** +** Reads back up to |len_d| events starting with |first_event_d|. For +** each event, the event will be passed to |on_event_read| and further +** reading will be aborted if the callback returns c3n. +** +** Returns c3y on complete success; c3n on any error. +*/ +c3_o u3_lmdb_read_events(u3_pier* pir_u, + c3_d first_event_d, + c3_d len_d, + c3_o(*on_event_read)(u3_pier* pir_u, c3_d id, + u3_noun mat)) +{ + // Creates the read transaction. + MDB_txn* transaction_u; + c3_w ret_w = mdb_txn_begin(pir_u->log_u->db_u, + //environment, + (MDB_txn *) NULL, + MDB_RDONLY, /* flags */ + &transaction_u); + if (0 != ret_w) { + u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + // Opens the database as part of the transaction. + c3_w flags_w = MDB_CREATE | MDB_INTEGERKEY; + MDB_dbi database_u; + ret_w = mdb_dbi_open(transaction_u, + "EVENTS", + flags_w, + &database_u); + if (0 != ret_w) { + u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + // Creates a cursor to iterate over keys starting at first_event_d. + MDB_cursor* cursor_u; + ret_w = mdb_cursor_open(transaction_u, database_u, &cursor_u); + if (0 != ret_w) { + u3l_log("lmdb: cursor_open fail: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + // Sets the cursor to the position of first_event_d. + MDB_val key; + MDB_val val; + key.mv_size = sizeof(c3_d); + key.mv_data = &first_event_d; + + ret_w = mdb_cursor_get(cursor_u, &key, &val, MDB_SET_KEY); + if (0 != ret_w) { + u3l_log("lmdb: could not find initial event %" PRIu64 ": %s\r\n", + first_event_d, mdb_strerror(ret_w)); + mdb_cursor_close(cursor_u); + return c3n; + } + + // Load up to len_d events, iterating forward across the cursor. + for (c3_d loaded = 0; (ret_w != MDB_NOTFOUND) && (loaded < len_d); ++loaded) { + // As a sanity check, we make sure that there aren't any discontinuities in + // the sequence of loaded events. + c3_d current_id = first_event_d + loaded; + if (key.mv_size != sizeof(c3_d)) { + u3l_log("lmdb: invalid cursor key\r\n"); + return c3n; + } + if (*(c3_d*)key.mv_data != current_id) { + u3l_log("lmdb: missing event in database. Expected %" PRIu64 ", received %" + PRIu64 "\r\n", + current_id, + *(c3_d*)key.mv_data); + return c3n; + } + + // Now build the atom version and then the cued version from the raw data + u3_noun mat = u3i_bytes(val.mv_size, val.mv_data); + + if (on_event_read(pir_u, current_id, mat) == c3n) { + u3z(mat); + u3l_log("lmdb: aborting replay due to error.\r\n"); + return c3n; + } + + u3z(mat); + + ret_w = mdb_cursor_get(cursor_u, &key, &val, MDB_NEXT); + if (ret_w != 0 && ret_w != MDB_NOTFOUND) { + u3l_log("lmdb: error while loading events: %s\r\n", + mdb_strerror(ret_w)); + return c3n; + } + } + + mdb_cursor_close(cursor_u); + + // Read-only transactions are aborted since we don't need to record the fact + // that we performed a read. + mdb_txn_abort(transaction_u); + + return c3y; +} + +/* u3_lmdb_get_latest_event_number(): Gets last event id persisted +** +** Reads the last key in order from the EVENTS table as the latest event +** number. On table empty, returns c3y but doesn't modify event_number. +*/ +c3_o u3_lmdb_get_latest_event_number(MDB_env* environment, c3_d* event_number) +{ + // Creates the read transaction. + MDB_txn* transaction_u; + c3_w ret_w = mdb_txn_begin(environment, + (MDB_txn *) NULL, + 0, /* flags */ + &transaction_u); + if (0 != ret_w) { + u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + // Opens the database as part of the transaction. + c3_w flags_w = MDB_CREATE | MDB_INTEGERKEY; + MDB_dbi database_u; + ret_w = mdb_dbi_open(transaction_u, + "EVENTS", + flags_w, + &database_u); + if (0 != ret_w) { + u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + // Creates a cursor to point to the last event + MDB_cursor* cursor_u; + ret_w = mdb_cursor_open(transaction_u, database_u, &cursor_u); + if (0 != ret_w) { + u3l_log("lmdb: cursor_open fail: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + // Set the cursor at the end of the line. + MDB_val key; + MDB_val val; + ret_w = mdb_cursor_get(cursor_u, &key, &val, MDB_LAST); + if (MDB_NOTFOUND == ret_w) { + // Clean up, but don't error out. + mdb_cursor_close(cursor_u); + mdb_txn_abort(transaction_u); + return c3y; + } + + if (0 != ret_w) { + u3l_log("lmdb: could not find last event: %s\r\n", mdb_strerror(ret_w)); + mdb_cursor_close(cursor_u); + mdb_txn_abort(transaction_u); + return c3n; + } + + *event_number = *(c3_d*)key.mv_data; + + mdb_cursor_close(cursor_u); + + // Read-only transactions are aborted since we don't need to record the fact + // that we performed a read. + mdb_txn_abort(transaction_u); + + return c3y; +} + +/* u3_lmdb_write_identity(): Writes the event log identity information +** +** We have a secondary database (table) in this environment named META where we +** read/write identity information from/to. +*/ +c3_o u3_lmdb_write_identity(MDB_env* environment, + u3_noun who, + u3_noun is_fake, + u3_noun life) +{ + // Creates the write transaction. + MDB_txn* transaction_u; + c3_w ret_w = mdb_txn_begin(environment, + (MDB_txn *) NULL, + 0, /* flags */ + &transaction_u); + if (0 != ret_w) { + u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + // Opens the database as part of the transaction. + c3_w flags_w = MDB_CREATE; + MDB_dbi database_u; + ret_w = mdb_dbi_open(transaction_u, + "META", + flags_w, + &database_u); + if (0 != ret_w) { + u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); + mdb_txn_abort(transaction_u); + return c3n; + } + + c3_o ret; + ret = _perform_put_on_database_noun(transaction_u, database_u, "who", who); + if (ret == c3n) { + mdb_txn_abort(transaction_u); + return c3n; + } + + ret = _perform_put_on_database_noun(transaction_u, database_u, "is-fake", + is_fake); + if (ret == c3n) { + mdb_txn_abort(transaction_u); + return c3n; + } + + ret = _perform_put_on_database_noun(transaction_u, database_u, "life", life); + if (ret == c3n) { + mdb_txn_abort(transaction_u); + return c3n; + } + + ret_w = mdb_txn_commit(transaction_u); + if (0 != ret_w) { + u3l_log("lmdb: failed to commit transaction: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + return c3y; +} + + +/* u3_lmdb_read_identity(): Reads the event log identity information. +*/ +c3_o u3_lmdb_read_identity(MDB_env* environment, + u3_noun* who, + u3_noun* is_fake, + u3_noun* life) { + // Creates the write transaction. + MDB_txn* transaction_u; + c3_w ret_w = mdb_txn_begin(environment, + (MDB_txn *) NULL, + MDB_RDONLY, /* flags */ + &transaction_u); + if (0 != ret_w) { + u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); + return c3n; + } + + // Opens the database as part of the transaction. + MDB_dbi database_u; + ret_w = mdb_dbi_open(transaction_u, + "META", + 0, + &database_u); + if (0 != ret_w) { + u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); + mdb_txn_abort(transaction_u); + return c3n; + } + + c3_o ret; + ret = _perform_get_on_database_noun(transaction_u, database_u, "who", who); + if (ret == c3n) { + mdb_txn_abort(transaction_u); + return c3n; + } + + ret = _perform_get_on_database_noun(transaction_u, database_u, "is-fake", + is_fake); + if (ret == c3n) { + mdb_txn_abort(transaction_u); + return c3n; + } + + ret = _perform_get_on_database_noun(transaction_u, database_u, "life", life); + if (ret == c3n) { + mdb_txn_abort(transaction_u); + return c3n; + } + + // Read-only transactions are aborted since we don't need to record the fact + // that we performed a read. + mdb_txn_abort(transaction_u); + + return c3y; +} diff --git a/pkg/hs/vere/notes/c/newt.c b/pkg/hs/vere/notes/c/newt.c new file mode 100644 index 000000000..67a220daa --- /dev/null +++ b/pkg/hs/vere/notes/c/newt.c @@ -0,0 +1,359 @@ +/* vere/newt.c +** +** implements noun blob messages with trivial framing. +** +** a message is a 64-bit little-endian byte count, followed +** by the indicated number of bytes. the bytes are the +** the ++cue of of a noun. +** +** the implementation is relatively inefficient and could +** lose a few copies, mallocs, etc. +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +#undef NEWT_VERBOSE + +/* _newt_consume(): advance buffer processing. +*/ +static void +_newt_consume(u3_moat* mot_u) +{ + /* process stray bytes, trying to create a new message + ** or add a block to an existing one. + */ + while ( 1 ) { + if ( mot_u->rag_y ) { + /* if there is a live message, add a block to the queue. + */ + if ( mot_u->mes_u ) { + u3_meat* met_u; + + /* create block + */ + met_u = c3_malloc(mot_u->len_d + (c3_d) sizeof(u3_meat)); + met_u->nex_u = 0; + met_u->len_d = mot_u->len_d; + memcpy(met_u->hun_y, mot_u->rag_y, mot_u->len_d); + +#ifdef NEWT_VERBOSE + u3l_log("newt: %d: create: msg %p, new block %p, len %" + PRIu64 ", has %" PRIu64 ", needs %" PRIu64 "\r\n", + getpid(), + mot_u->mes_u, + met_u, + met_u->len_d, + mot_u->mes_u->has_d, + mot_u->mes_u->len_d); +#endif + /* enqueue block + */ + if ( !mot_u->mes_u->meq_u ) { + mot_u->mes_u->meq_u = mot_u->mes_u->qem_u = met_u; + } + else { + mot_u->mes_u->qem_u->nex_u = met_u; + mot_u->mes_u->qem_u = met_u; + } + mot_u->mes_u->has_d += met_u->len_d; + + /* free consumed stray bytes + */ + c3_free(mot_u->rag_y); + mot_u->len_d = 0; + mot_u->rag_y = 0; + } + else { + /* no message, but enough stray bytes to fill in + ** a length; collect them and create a message. + */ + if ( mot_u->len_d >= 8ULL ) { + c3_d nel_d = 0; + + nel_d |= ((c3_d) mot_u->rag_y[0]) << 0ULL; + nel_d |= ((c3_d) mot_u->rag_y[1]) << 8ULL; + nel_d |= ((c3_d) mot_u->rag_y[2]) << 16ULL; + nel_d |= ((c3_d) mot_u->rag_y[3]) << 24ULL; + nel_d |= ((c3_d) mot_u->rag_y[4]) << 32ULL; + nel_d |= ((c3_d) mot_u->rag_y[5]) << 40ULL; + nel_d |= ((c3_d) mot_u->rag_y[6]) << 48ULL; + nel_d |= ((c3_d) mot_u->rag_y[7]) << 56ULL; + +#ifdef NEWT_VERBOSE + u3l_log("newt: %d: parsed length %" PRIu64 "\r\n", + getpid(), + nel_d); +#endif + mot_u->len_d -= 8ULL; + + mot_u->mes_u = c3_malloc(sizeof(u3_mess)); + mot_u->mes_u->len_d = nel_d; + mot_u->mes_u->has_d = 0; + mot_u->mes_u->meq_u = mot_u->mes_u->qem_u = 0; + + if ( !mot_u->len_d ) { + c3_free(mot_u->rag_y); + mot_u->rag_y = 0; + } + else { + /* remove consumed length from stray bytes + */ + c3_y* buf_y = c3_malloc(mot_u->len_d); + + memcpy(buf_y, mot_u->rag_y + 8, mot_u->len_d); + + c3_free(mot_u->rag_y); + mot_u->rag_y = buf_y; + + /* remaining bytes will be installed as message meat + */ + continue; + } + } + } + } + + /* check for message completions + */ + if ( mot_u->mes_u && (mot_u->mes_u->has_d >= mot_u->mes_u->len_d) ) { + c3_d len_d = mot_u->mes_u->len_d; + c3_y* buf_y = c3_malloc(len_d); + c3_d pat_d = 0; + u3_meat* met_u; + + /* we should have just cleared this + */ + c3_assert(!mot_u->rag_y); + c3_assert(!mot_u->len_d); + + /* collect queue blocks, cleaning them up; return any spare meat + ** to the rag. + */ + { + met_u = mot_u->mes_u->meq_u; + while ( met_u && (pat_d < len_d) ) { + u3_meat* nex_u = met_u->nex_u; + c3_d end_d = (pat_d + met_u->len_d); + c3_d eat_d; + c3_d rem_d; + + eat_d = c3_min(len_d, end_d) - pat_d; + memcpy(buf_y + pat_d, met_u->hun_y, eat_d); + pat_d += eat_d; + + rem_d = (met_u->len_d - eat_d); + if ( rem_d ) { + mot_u->rag_y = c3_malloc(rem_d); + memcpy(mot_u->rag_y, met_u->hun_y + eat_d, rem_d); + mot_u->len_d = rem_d; + + /* one: unless we got a bad length, this has to be the last + ** block in the message. + ** + ** two: bad data on a newt channel can cause us to assert. + ** that's actually the right thing for a private channel. + */ + c3_assert(0 == nex_u); + } + c3_free(met_u); + met_u = nex_u; + } + c3_assert(pat_d == len_d); + + /* clear the message + */ + c3_free(mot_u->mes_u); + mot_u->mes_u = 0; + } + + /* build and send the object + */ + { + u3_noun mat = u3i_bytes((c3_w) len_d, buf_y); + + mot_u->pok_f(mot_u->vod_p, mat); + } + + /* continue; spare meat may need processing + */ + continue; + } + + /* nothing happening, await next event + */ + break; + } +} + +/* _raft_alloc(): libuv-style allocator for raft. +*/ +static void +_newt_alloc(uv_handle_t* had_u, + size_t len_i, + uv_buf_t* buf_u) +{ + void* ptr_v = c3_malloc(len_i); + + *buf_u = uv_buf_init(ptr_v, len_i); +} + +/* _newt_read_cb(): stream input callback. +*/ +void +_newt_read_cb(uv_stream_t* str_u, + ssize_t len_i, + const uv_buf_t* buf_u) +{ + c3_d len_d = (c3_d) len_i; + u3_moat* mot_u = (void *)str_u; + + if ( UV_EOF == len_i ) { + // u3l_log("newt: %d: stream closed\r\n", getpid()); + uv_read_stop(str_u); + mot_u->bal_f(mot_u->vod_p, "stream closed"); + } + else { +#ifdef NEWT_VERBOSE + u3l_log("newt: %d: read %ld\r\n", getpid(), len_i); +#endif + +#ifdef NEWT_VERBOSE + u3l_log("newt: %d: ", getpid()); + for ( int i = 0; i < len_i; i++) { + if (0 == (i % 16)) u3l_log("\r\n"); + u3l_log(" %02x", (unsigned) buf_u->base[i]); + } + u3l_log("\r\nnewt: %d: \r\n", getpid()); +#endif + + // grow read buffer by `len_d` bytes + // + if ( mot_u->rag_y ) { + mot_u->rag_y = c3_realloc(mot_u->rag_y, mot_u->len_d + len_d); + memcpy(mot_u->rag_y + mot_u->len_d, buf_u->base, len_d); + c3_free(buf_u->base); + } + else { + mot_u->rag_y = (c3_y *)buf_u->base; + mot_u->len_d = len_d; + } + _newt_consume(mot_u); + } +} + +/* u3_newt_read(): start stream reading. +*/ +void +u3_newt_read(u3_moat* mot_u) +{ + c3_i err_i; + + mot_u->mes_u = 0; + mot_u->len_d = 0; + mot_u->rag_y = 0; + + err_i = uv_read_start((uv_stream_t*) &mot_u->pyp_u, + _newt_alloc, + _newt_read_cb); + + if ( err_i != 0 ) { + mot_u->bal_f(mot_u, uv_strerror(err_i)); + } +} + +/* write request for newt +*/ + struct _u3_write_t { + uv_write_t wri_u; + u3_mojo* moj_u; + void* vod_p; + c3_y* buf_y; + }; + +/* _newt_write_cb(): generic write callback. +*/ +static void +_newt_write_cb(uv_write_t* wri_u, c3_i sas_i) +{ + struct _u3_write_t* req_u = (struct _u3_write_t*)wri_u; + void* vod_p = req_u->vod_p; + u3_mojo* moj_u = req_u->moj_u; + + free(req_u->buf_y); + free(req_u); + + if ( 0 != sas_i ) { + u3l_log("newt: bad write %d\r\n", sas_i); + moj_u->bal_f(vod_p, uv_strerror(sas_i)); + } +} + +/* u3_newt_write(): write atom to stream; free atom. +*/ +void +u3_newt_write(u3_mojo* moj_u, + u3_atom mat, + void* vod_p) +{ + c3_w len_w = u3r_met(3, mat); + c3_y* buf_y = c3_malloc(len_w + 8); + struct _u3_write_t* req_u = c3_malloc(sizeof(*req_u)); + uv_buf_t buf_u; + c3_i err_i; + + /* write header; c3_d is futureproofing + */ + buf_y[0] = ((len_w >> 0) & 0xff); + buf_y[1] = ((len_w >> 8) & 0xff); + buf_y[2] = ((len_w >> 16) & 0xff); + buf_y[3] = ((len_w >> 24) & 0xff); + buf_y[4] = buf_y[5] = buf_y[6] = buf_y[7] = 0; + u3r_bytes(0, len_w, buf_y + 8, mat); + u3z(mat); + + req_u->moj_u = moj_u; + req_u->buf_y = buf_y; + buf_u.base = (c3_c*) buf_y; + buf_u.len = len_w + 8; + +#ifdef NEWT_VERBOSE + u3l_log("newt: %d: write %d\n", getpid(), len_w + 8); +#endif + +#ifdef NEWT_VERBOSE + u3l_log("newt: %d: ", getpid()); + for ( int i = 0; i < len_w+8; i++) { + if (0 == (i % 16)) u3l_log("\r\n"); + u3l_log(" %02x", (unsigned) buf_u.base[i]); + } + u3l_log("\r\nnewt: %d: \r\n", getpid()); +#endif + + if ( 0 != (err_i = uv_write((uv_write_t*)req_u, + (uv_stream_t*)&moj_u->pyp_u, + &buf_u, + 1, + _newt_write_cb)) ) + { + moj_u->bal_f(moj_u, uv_strerror(err_i)); + } +} diff --git a/pkg/hs/vere/notes/c/pier.c b/pkg/hs/vere/notes/c/pier.c new file mode 100644 index 000000000..730e47f09 --- /dev/null +++ b/pkg/hs/vere/notes/c/pier.c @@ -0,0 +1,2143 @@ +/* vere/pier.c +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +#undef VERBOSE_EVENTS + + /* event handling proceeds on a single path. across both the + ** child worker process (worker) and parent i/o process (daemon). + ** state transitions are as follows: + ** + ** generated (event numbered and queued) + ** dispatched (sent to worker) + ** computed (completed by worker) + ** commit requested (sent to storage subsystem) + ** commit complete (daemon notified) + ** released (output actions allowed) + ** + ** we dispatch one event at a time to the worker. we don't do + ** anything in parallel. + ** + ** the sanity constraints that constrain this path: + ** + ** - an event can't request a commit until it's computed. + ** - an event can't be released until it, and all events + ** preceding it, are computed and committed. + ** + ** event numbers are uint64 (c3_d) which start with 1. we order + ** events as we receive them. + ** + ** events are executed in order by the working process, and + ** (at present) committed in strict order. + ** + ** the result of computing an event can be completion (in which + ** case we go directly to commit) or replacement (in which we + ** replace the input event with a different event). + ** + ** after crash recovery, events committed but not in the snapshot + ** (the state of the worker) are replayed (re-computed), but their + ** output effects are ignored. it is possible that effects of + ** (only the last of ?) these events are not completely released to + ** the outside world -- but they should never be released more than once. + ** + ** XX analyze replay more comprehensively + */ + +static void _pier_apply(u3_pier* pir_u); +static void _pier_boot_complete(u3_pier* pir_u); +static void _pier_boot_ready(u3_pier* pir_u); +static void _pier_boot_set_ship(u3_pier* pir_u, u3_noun who, u3_noun fak); +static void _pier_exit_done(u3_pier* pir_u); +static void _pier_loop_resume(u3_pier* pir_u); + +/* _pier_db_bail(): bail from disk i/o. +*/ +static void +_pier_db_bail(void* vod_p, const c3_c* err_c) +{ + u3l_log("disk error: %s\r\n", err_c); +} + +/* _pier_db_shutdown(): close the log. +*/ +static void +_pier_db_shutdown(u3_pier* pir_u) +{ + u3_lmdb_shutdown(pir_u->log_u->db_u); +} + +/* _pier_db_commit_complete(): commit complete. + */ +static void +_pier_db_commit_complete(c3_o success, + u3_pier* pir_u, + c3_d first_event_d, + c3_d event_count_d) +{ + u3_disk* log_u = pir_u->log_u; + + if (success == c3n) { + u3l_log("Failed to persist event. Exiting to prevent corruption."); + u3_pier_bail(); + } + +#ifdef VERBOSE_EVENTS + if (event_count_d != 1) { + u3l_log("pier: (%" PRIu64 "-%" PRIu64 "): db commit: complete\r\n", + first_event_d, first_event_d + event_count_d - 1ULL); + } else { + u3l_log("pier: (%" PRIu64 "): db commit: complete\r\n", first_event_d); + } +#endif + + /* advance commit counter + */ + { + c3_assert((first_event_d + event_count_d - 1ULL) == log_u->moc_d); + c3_assert(first_event_d == (1ULL + log_u->com_d)); + log_u->com_d += event_count_d; + } + + _pier_loop_resume(pir_u); +} + +/* _pier_db_commit_request(): start commit. +*/ +static void +_pier_db_commit_request(u3_pier* pir_u, + struct u3_lmdb_write_request* request_u, + c3_d first_event_d, + c3_d count_d) +{ + u3_disk* log_u = pir_u->log_u; + +#ifdef VERBOSE_EVENTS + if (count_d != 1) { + u3l_log("pier: (%" PRIu64 "-%" PRIu64 "): db commit: request\r\n", + first_event_d, first_event_d + count_d - 1ULL); + } else { + u3l_log("pier: (%" PRIu64 "): db commit: request\r\n", first_event_d); + } +#endif + + /* put it in the database + */ + { + u3_lmdb_write_event(log_u->db_u, + pir_u, + request_u, + _pier_db_commit_complete); + } + + /* advance commit-request counter + */ + { + c3_assert(first_event_d == (1ULL + log_u->moc_d)); + log_u->moc_d += count_d; + } +} + + +static void +_pier_db_write_header(u3_pier* pir_u, + u3_noun who, + u3_noun is_fake, + u3_noun life) +{ + c3_o ret = u3_lmdb_write_identity(pir_u->log_u->db_u, + who, is_fake, life); + if (ret == c3n) { + u3_pier_bail(); + } +} + +/* _pier_db_read_header(): reads the ships metadata from lmdb + */ +static void +_pier_db_read_header(u3_pier* pir_u) +{ + u3_noun who, is_fake, life; + c3_o ret = u3_lmdb_read_identity(pir_u->log_u->db_u, + &who, &is_fake, &life); + if (ret == c3n) { + u3l_log("Failed to load identity. Exiting..."); + u3_pier_bail(); + } + + _pier_boot_set_ship(pir_u, u3k(who), u3k(is_fake)); + pir_u->lif_d = u3r_chub(0, life); + + u3z(who); + u3z(is_fake); + u3z(life); +} + +static c3_o +_pier_db_on_commit_loaded(u3_pier* pir_u, + c3_d id, + u3_noun mat) +{ + // Need to grab references to the nouns above. + u3_writ* wit_u = c3_calloc(sizeof(u3_writ)); + wit_u->pir_u = pir_u; + wit_u->evt_d = id; + wit_u->mat = u3k(mat); + + // Parse the expected mug_l and job out of mat. + u3_noun entry = u3ke_cue(u3k(mat)); + u3_noun mug, job; + if ( (c3y != u3du(entry)) || + (c3n == u3r_cell(entry, &mug, &job)) || + (c3n == u3ud(mug)) || + (1 < u3r_met(5, mug)) ) { + u3l_log("pier: load: event %" PRIu64 " malformed.\r\n", id); + return c3n; + } + + wit_u->mug_l = u3r_word(0, mug); + wit_u->job = u3k(job); + + u3z(entry); + + // Insert at queue front since we're loading events in order + if ( !pir_u->ent_u ) { + c3_assert(!pir_u->ext_u); + + pir_u->ent_u = pir_u->ext_u = wit_u; + } + else { + if ( wit_u->evt_d != (1ULL + pir_u->ent_u->evt_d) ) { + fprintf(stderr, "pier: load: commit: event gap: %" PRIx64 ", %" + PRIx64 "\r\n", + wit_u->evt_d, + pir_u->ent_u->evt_d); + _pier_db_bail(0, "pier: load: comit: event gap"); + return c3n; + } + + pir_u->ent_u->nex_u = wit_u; + pir_u->ent_u = wit_u; + } + + return c3y; +} + +/* _pier_db_load_commit(): load len_d commits >= lav_d; enqueue for replay +*/ +static void +_pier_db_load_commits(u3_pier* pir_u, + c3_d lav_d, + c3_d len_d) +{ + if (lav_d == 1) { + // We are restarting from event 1. That means we need to set the ship from + // the log identity information. + u3_noun who, fak, len; + c3_o ret = u3_lmdb_read_identity(pir_u->log_u->db_u, + &who, + &fak, + &len); + if (ret == c3n) { + u3l_log("Failed to load identity for replay. Exiting..."); + u3_pier_bail(); + } + + _pier_boot_set_ship(pir_u, u3k(who), u3k(fak)); + pir_u->lif_d = u3r_chub(0, len); + + u3z(who); + u3z(fak); + u3z(len); + } + + c3_o ret = u3_lmdb_read_events(pir_u, + lav_d, + len_d, + _pier_db_on_commit_loaded); + if (ret == c3n) { + u3l_log("Failed to read event log for replay. Exiting..."); + u3_pier_bail(); + } +} + +/* _pier_db_init(): +*/ +static c3_o +_pier_db_init(u3_disk* log_u) +{ + c3_d evt_d = 0; + c3_d pos_d = 0; + + c3_assert( c3n == log_u->liv_o ); + + // Request from the database the last event + if ( c3n == u3_lmdb_get_latest_event_number(log_u->db_u, &evt_d) ) { + u3l_log("disk init from lmdb failed."); + return c3n; + } + + log_u->liv_o = c3y; + log_u->com_d = log_u->moc_d = evt_d; + + _pier_boot_ready(log_u->pir_u); + + return c3y; +} + +/* _pier_disk_create(): load log for given point. +*/ +static c3_o +_pier_disk_create(u3_pier* pir_u) +{ + u3_disk* log_u = c3_calloc(sizeof(*log_u)); + + pir_u->log_u = log_u; + log_u->pir_u = pir_u; + log_u->liv_o = c3n; + + /* create/load pier, urbit directory, log directory. + */ + { + /* pier directory + */ + { + if ( 0 == (log_u->dir_u = u3_foil_folder(pir_u->pax_c)) ) { + return c3n; + } + } + + /* pier/.urb + */ + { + c3_c* urb_c = c3_malloc(6 + strlen(pir_u->pax_c)); + + strcpy(urb_c, pir_u->pax_c); + strcat(urb_c, "/.urb"); + + if ( 0 == (log_u->urb_u = u3_foil_folder(urb_c)) ) { + c3_free(urb_c); + return c3n; + } + c3_free(urb_c); + } + + /* pier/.urb/log + */ + { + c3_c* log_c = c3_malloc(10 + strlen(pir_u->pax_c)); + + strcpy(log_c, pir_u->pax_c); + strcat(log_c, "/.urb/log"); + + // Creates the folder + if ( 0 == (log_u->com_u = u3_foil_folder(log_c)) ) { + c3_free(log_c); + return c3n; + } + + // Inits the database + if ( 0 == (log_u->db_u = u3_lmdb_init(log_c)) ) { + c3_free(log_c); + return c3n; + } + + c3_free(log_c); + } + + /* pier/.urb/put and pier/.urb/get + */ + { + c3_c* dir_c = c3_malloc(10 + strlen(pir_u->pax_c)); + + strcpy(dir_c, pir_u->pax_c); + strcat(dir_c, "/.urb/put"); + mkdir(dir_c, 0700); + + strcpy(dir_c, pir_u->pax_c); + strcat(dir_c, "/.urb/get"); + mkdir(dir_c, 0700); + + c3_free(dir_c); + } + } + + // create/load event log + // + if ( c3n == _pier_db_init(log_u) ) { + return c3n; + } + + return c3y; +} + +/* _pier_writ_insert(): insert raw event. +*/ +static void +_pier_writ_insert(u3_pier* pir_u, + c3_l msc_l, + u3_noun job) +{ + u3_writ* wit_u = c3_calloc(sizeof(u3_writ)); + wit_u->pir_u = pir_u; + + wit_u->evt_d = pir_u->gen_d; + pir_u->gen_d++; + + wit_u->msc_l = msc_l; + + wit_u->job = job; + + if ( !pir_u->ent_u ) { + c3_assert(!pir_u->ext_u); + + pir_u->ent_u = pir_u->ext_u = wit_u; + } + else { + pir_u->ent_u->nex_u = wit_u; + pir_u->ent_u = wit_u; + } +} + +/* _pier_writ_insert_ovum(): insert raw ovum - for boot sequence. +*/ +static void +_pier_writ_insert_ovum(u3_pier* pir_u, + c3_l msc_l, + u3_noun ovo) +{ + u3_noun now; + struct timeval tim_tv; + + gettimeofday(&tim_tv, 0); + now = u3_time_in_tv(&tim_tv); + + _pier_writ_insert(pir_u, msc_l, u3nc(now, ovo)); +} + +/* _pier_writ_find(): find writ by event number. +*/ +static u3_writ* +_pier_writ_find(u3_pier* pir_u, + c3_d evt_d) +{ + u3_writ* wit_u; + + /* very unlikely to be O(n) and n is small + */ + for ( wit_u = pir_u->ext_u; wit_u; wit_u = wit_u->nex_u ) { + if ( evt_d == wit_u->evt_d ) { + return wit_u; + } + } + return 0; +} + +/* _pier_writ_unlink(): unlink writ from queue. +*/ +static void +_pier_writ_unlink(u3_writ* wit_u) +{ + u3_pier* pir_u = wit_u->pir_u; + +#ifdef VERBOSE_EVENTS + fprintf(stderr, "pier: (%" PRIu64 "): delete\r\n", wit_u->evt_d); +#endif + + pir_u->ext_u = wit_u->nex_u; + + if ( wit_u == pir_u->ent_u ) { + c3_assert(pir_u->ext_u == 0); + pir_u->ent_u = 0; + } +} + +/* _pier_writ_dispose(): dispose of writ. +*/ +static void +_pier_writ_dispose(u3_writ* wit_u) +{ + /* free contents + */ + u3z(wit_u->job); + u3z(wit_u->mat); + u3z(wit_u->act); + + c3_free(wit_u); +} + +/* _pier_work_bail(): handle subprocess error. +*/ +static void +_pier_work_bail(void* vod_p, + const c3_c* err_c) +{ + fprintf(stderr, "pier: work error: %s\r\n", err_c); +} + +/* _pier_work_boot(): prepare for boot. +*/ +static void +_pier_work_boot(u3_pier* pir_u, c3_o sav_o) +{ + u3_controller* god_u = pir_u->god_u; + + c3_assert( 0 != pir_u->lif_d ); + + u3_noun who = u3i_chubs(2, pir_u->who_d); + u3_noun len = u3i_chubs(1, &pir_u->lif_d); + + if ( c3y == sav_o ) { + _pier_db_write_header(pir_u, who, u3k(pir_u->fak_o), len); + } + + u3_noun msg = u3nq(c3__boot, who, pir_u->fak_o, len); + u3_atom mat = u3ke_jam(msg); + u3_newt_write(&god_u->inn_u, mat, 0); +} + +/* _pier_work_shutdown(): stop the worker process. +*/ +static void +_pier_work_shutdown(u3_pier* pir_u) +{ + u3_controller* god_u = pir_u->god_u; + + u3_newt_write(&god_u->inn_u, u3ke_jam(u3nc(c3__exit, 0)), 0); +} + +/* _pier_work_build(): build atomic action. +*/ +static void +_pier_work_build(u3_writ* wit_u) +{ + /* marshal into atom + */ + if ( 0 == wit_u->mat ) { + c3_assert(0 != wit_u->job); + + wit_u->mat = u3ke_jam(u3nc(wit_u->mug_l, + u3k(wit_u->job))); + } +} + +/* _pier_work_send(): send to worker. +*/ +static void +_pier_work_send(u3_writ* wit_u) +{ + u3_pier* pir_u = wit_u->pir_u; + u3_controller* god_u = pir_u->god_u; + + c3_assert(0 != wit_u->mat); + + u3_noun msg = u3ke_jam(u3nt(c3__work, + u3i_chubs(1, &wit_u->evt_d), + u3k(wit_u->mat))); + + u3_newt_write(&god_u->inn_u, msg, wit_u); +} + +/* _pier_work_save(): tell worker to save checkpoint. +*/ +static void +_pier_work_save(u3_pier* pir_u) +{ + u3_controller* god_u = pir_u->god_u; + u3_disk* log_u = pir_u->log_u; + u3_save* sav_u = pir_u->sav_u; + + c3_assert( god_u->dun_d == sav_u->req_d ); + c3_assert( log_u->com_d >= god_u->dun_d ); + + { + u3_noun mat = u3ke_jam(u3nc(c3__save, u3i_chubs(1, &god_u->dun_d))); + u3_newt_write(&god_u->inn_u, mat, 0); + + // XX wait on some report of success before updating? + // + sav_u->dun_d = sav_u->req_d; + } + + // if we're gracefully shutting down, do so now + // + if ( u3_psat_done == pir_u->sat_e ) { + _pier_exit_done(pir_u); + } +} + +/* _pier_work_release(): apply side effects. +*/ +static void +_pier_work_release(u3_writ* wit_u) +{ + u3_pier* pir_u = wit_u->pir_u; + u3_controller* god_u = pir_u->god_u; + u3_noun vir = wit_u->act; + + if ( u3_psat_pace == pir_u->sat_e ) { + fputc('.', stderr); + + // enqueue another batch of events for replay + // + { + u3_disk* log_u = pir_u->log_u; + + // XX requires that writs be unlinked before effects are released + // + if ( (0 == pir_u->ent_u) && + (wit_u->evt_d < log_u->com_d) ) + { + _pier_db_load_commits(pir_u, (1ULL + god_u->dun_d), 1000ULL); + } + } + } + else { +#ifdef VERBOSE_EVENTS + fprintf(stderr, "pier: (%" PRIu64 "): compute: release\r\n", wit_u->evt_d); +#endif + + // advance release counter + // + { + c3_assert(wit_u->evt_d == (1ULL + god_u->rel_d)); + god_u->rel_d += 1ULL; + } + + // apply actions + // + while ( u3_nul != vir ) { + u3_noun ovo, nex; + u3x_cell(vir, &ovo, &nex); + + u3_reck_kick(pir_u, u3k(ovo)); + vir = nex; + } + } + + // if we have completed the boot sequence, activate system events. + // + if ( wit_u->evt_d == pir_u->but_d ) { + _pier_boot_complete(pir_u); + } + + // take snapshot, if requested (and awaiting the commit of this event) + // + { + u3_save* sav_u = pir_u->sav_u; + + if ( (sav_u->req_d > sav_u->dun_d) && + (wit_u->evt_d == sav_u->req_d) ) + { + _pier_work_save(pir_u); + } + } +} + +/* _pier_work_complete(): worker reported completion. +*/ +static void +_pier_work_complete(u3_writ* wit_u, + c3_l mug_l, + u3_noun act) +{ + u3_pier* pir_u = wit_u->pir_u; + u3_controller* god_u = pir_u->god_u; + +#ifdef VERBOSE_EVENTS + fprintf(stderr, "pier: (%" PRIu64 "): compute: complete\r\n", wit_u->evt_d); +#endif + + god_u->dun_d += 1; + c3_assert(god_u->dun_d == wit_u->evt_d); + + god_u->mug_l = mug_l; + + c3_assert(wit_u->act == 0); + wit_u->act = act; + + if ( wit_u->evt_d > pir_u->lif_d ) { + u3_term_stop_spinner(); + } +} + +/* _pier_work_replace(): worker reported replacement. +*/ +static void +_pier_work_replace(u3_writ* wit_u, + u3_noun job) +{ + u3_pier* pir_u = wit_u->pir_u; + u3_controller* god_u = pir_u->god_u; + +#ifdef VERBOSE_EVENTS + fprintf(stderr, "pier: (%" PRIu64 "): compute: replace\r\n", wit_u->evt_d); +#endif + + c3_assert(god_u->sen_d == wit_u->evt_d); + + // something has gone very wrong, we should probably stop now + // + if ( wit_u->rep_d >= 3ULL ) { + u3_pier_bail(); + } + + /* move backward in work processing + */ + { + u3z(wit_u->job); + wit_u->job = job; + + u3z(wit_u->mat); + wit_u->mat = u3ke_jam(u3nc(wit_u->mug_l, + u3k(wit_u->job))); + + wit_u->rep_d += 1ULL; + + god_u->sen_d -= 1ULL; + } + + if ( wit_u->evt_d > pir_u->lif_d ) { + u3_term_stop_spinner(); + } +} + +/* _pier_work_compute(): dispatch for processing. +*/ +static void +_pier_work_compute(u3_writ* wit_u) +{ + u3_pier* pir_u = wit_u->pir_u; + u3_controller* god_u = pir_u->god_u; + +#ifdef VERBOSE_EVENTS + fprintf(stderr, "pier: (%" PRIu64 "): compute: request\r\n", wit_u->evt_d); +#endif + + c3_assert(wit_u->evt_d == (1 + god_u->sen_d)); + + wit_u->mug_l = god_u->mug_l; + + _pier_work_build(wit_u); + _pier_work_send(wit_u); + + god_u->sen_d += 1; + + if ( wit_u->evt_d > pir_u->lif_d ) { + u3_term_start_spinner(wit_u->job); + } +} + +/* _pier_work_play(): with active worker, create or load log. +*/ +static void +_pier_work_play(u3_pier* pir_u, + c3_d lav_d, + c3_l mug_l) +{ + u3_controller* god_u = pir_u->god_u; + +#ifdef VERBOSE_EVENTS + fprintf(stderr, "pier: (%" PRIu64 "): boot at mug %x\r\n", lav_d, mug_l); +#endif + + c3_assert( c3n == god_u->liv_o ); + god_u->liv_o = c3y; + + // all events in the worker are complete + // + god_u->rel_d = god_u->dun_d = god_u->sen_d = (lav_d - 1ULL); + god_u->mug_l = mug_l; + + _pier_boot_ready(pir_u); +} + +/* _pier_work_stdr(): prints an error message to stderr + */ +static void +_pier_work_stdr(u3_writ* wit_u, u3_noun cord) +{ + c3_c* str = u3r_string(cord); + u3C.stderr_log_f(str); + free(str); +} + +/* _pier_work_slog(): print directly. +*/ +static void +_pier_work_slog(u3_writ* wit_u, c3_w pri_w, u3_noun tan) +{ +#ifdef U3_EVENT_TIME_DEBUG + { + static int old; + static struct timeval b4, f2, d0; + static c3_d b4_d; + c3_w ms_w; + + if ( old ) { + gettimeofday(&f2, 0); + timersub(&f2, &b4, &d0); + ms_w = (d0.tv_sec * 1000) + (d0.tv_usec / 1000); + if (ms_w > 1) { + #if 0 + fprintf(stderr, "%6d.%02dms: %9d ", + ms_w, (int) (d0.tv_usec % 1000) / 10, + ((int) (u3R->pro.nox_d - b4_d))); + #else + fprintf(stderr, "%6d.%02dms ", + ms_w, (int) (d0.tv_usec % 1000) / 10); + #endif + gettimeofday(&b4, 0); + b4_d = u3R->pro.nox_d; + } + else { + fprintf(stderr, " "); + } + } + else { + gettimeofday(&b4, 0); + b4_d = u3R->pro.nox_d; + } + old = 1; + } +#endif + + switch ( pri_w ) { + case 3: fprintf(stderr, ">>> "); break; + case 2: fprintf(stderr, ">> "); break; + case 1: fprintf(stderr, "> "); break; + } + + u3_pier_tank(0, tan); +} + +/* _pier_work_exit(): handle subprocess exit. +*/ +static void +_pier_work_exit(uv_process_t* req_u, + c3_ds sas_i, + c3_i sig_i) +{ + u3_controller* god_u = (void *) req_u; + u3_pier* pir_u = god_u->pir_u; + + u3l_log("pier: exit: status %" PRIu64 ", signal %d\r\n", sas_i, sig_i); + uv_close((uv_handle_t*) req_u, 0); + + _pier_db_shutdown(pir_u); + _pier_work_shutdown(pir_u); +} + +/* _pier_work_poke(): handle subprocess result. transfer nouns. +*/ +static void +_pier_work_poke(void* vod_p, + u3_noun mat) +{ + u3_pier* pir_u = vod_p; + u3_noun jar = u3ke_cue(u3k(mat)); + u3_noun p_jar, q_jar, r_jar; + + if ( c3y != u3du(jar) ) { + goto error; + } + + switch ( u3h(jar) ) { + default: goto error; + + // the worker process starts with a %play task, + // which tells us where to start playback + // (and who we are, if it knows) XX remove in favor of event-log header + // + case c3__play: { + c3_d lav_d; + c3_l mug_l; + + if ( (c3n == u3r_qual(u3t(jar), 0, &p_jar, &q_jar, &r_jar)) || + (c3n == u3ud(p_jar)) || + (u3r_met(6, p_jar) != 1) || + (c3n == u3ud(q_jar)) || + (u3r_met(5, p_jar) != 1) || + (c3n == u3du(r_jar)) || + (c3n == u3ud(u3h(r_jar))) || + ((c3y != u3t(r_jar)) && (c3n != u3t(r_jar))) ) + { + if ( u3_nul == u3t(jar) ) { + lav_d = 1ULL; + mug_l = 0; + } + else { + goto error; + } + } + + if ( u3_nul != u3t(jar) ) { + lav_d = u3r_chub(0, p_jar); + mug_l = u3r_word(0, q_jar); + + // single-home + // + _pier_boot_set_ship(pir_u, u3k(u3h(r_jar)), u3k(u3t(r_jar))); + } + + _pier_work_play(pir_u, lav_d, mug_l); + break; + } + + case c3__work: { + if ( (c3n == u3r_trel(jar, 0, &p_jar, &q_jar)) || + (c3n == u3ud(p_jar)) || + (u3r_met(6, p_jar) != 1) ) + { + u3l_log("failed to parse replacement atom"); + goto error; + } + else { + c3_d evt_d = u3r_chub(0, p_jar); + u3_writ* wit_u = _pier_writ_find(pir_u, evt_d); + + u3_noun mug, job; + u3_noun entry = u3ke_cue(u3k(q_jar)); + if ( (c3y != u3du(entry)) || + (c3n == u3r_cell(entry, &mug, &job)) || + (c3n == u3ud(mug)) || + (1 < u3r_met(5, mug)) ) { + goto error; + } + + c3_l mug_l = u3r_word(0, mug); + if ( !wit_u || (mug_l && (mug_l != wit_u->mug_l)) ) { + goto error; + } +#ifdef VERBOSE_EVENTS + fprintf(stderr, "pier: replace: %" PRIu64 "\r\n", evt_d); +#endif + + _pier_work_replace(wit_u, u3k(job)); + } + break; + } + + case c3__done: { + if ( (c3n == u3r_qual(jar, 0, &p_jar, &q_jar, &r_jar)) || + (c3n == u3ud(p_jar)) || + (u3r_met(6, p_jar) != 1) || + (c3n == u3ud(q_jar)) || + (u3r_met(5, q_jar) > 1) ) + { + goto error; + } + else { + c3_d evt_d = u3r_chub(0, p_jar); + c3_l mug_l = u3r_word(0, q_jar); + u3_writ* wit_u = _pier_writ_find(pir_u, evt_d); + + if ( !wit_u ) { + u3l_log("poke: no writ: %" PRIu64 "\r\n", evt_d); + goto error; + } + _pier_work_complete(wit_u, mug_l, u3k(r_jar)); + } + break; + } + + case c3__stdr: { + if ( (c3n == u3r_trel(jar, 0, &p_jar, &q_jar)) || + (c3n == u3ud(p_jar)) || + (u3r_met(6, p_jar) > 1) || + (c3n == u3ud(q_jar)) ) + { + goto error; + } + else { + c3_d evt_d = u3r_chub(0, p_jar); + u3_writ* wit_u = _pier_writ_find(pir_u, evt_d); + + // Unlike slog, we always reprint interpreter errors during replay. + _pier_work_stdr(wit_u, q_jar); + } + break; + } + + case c3__slog: { + if ( (c3n == u3r_qual(jar, 0, &p_jar, &q_jar, &r_jar)) || + (c3n == u3ud(p_jar)) || + (u3r_met(6, p_jar) != 1) || + (c3n == u3ud(q_jar)) || + (u3r_met(3, q_jar) > 1) ) + { + goto error; + } + else { + c3_d evt_d = u3r_chub(0, p_jar); + c3_w pri_w = u3r_word(0, q_jar); + u3_writ* wit_u = _pier_writ_find(pir_u, evt_d); + + // skip slog during replay + // + // XX also update the worker to skip *sending* the slog during replay + // + if ( u3_psat_pace != pir_u->sat_e ) { + _pier_work_slog(wit_u, pri_w, u3k(r_jar)); + } + } + break; + } + } + + u3z(jar); u3z(mat); + _pier_loop_resume(pir_u); + return; + + error: { + u3z(jar); u3z(mat); + _pier_work_bail(0, "bad jar"); + } +} + +/* pier_work_create(): instantiate child process. +*/ +static u3_controller* +_pier_work_create(u3_pier* pir_u) +{ + u3_controller* god_u = c3_calloc(sizeof *god_u); + + pir_u->god_u = god_u; + god_u->pir_u = pir_u; + god_u->liv_o = c3n; + + /* spawn new process and connect to it + */ + { + c3_c* arg_c[5]; + c3_c* bin_c = u3_Host.wrk_c; + c3_c* pax_c; + c3_c key_c[256]; + c3_c wag_c[11]; + c3_i err_i; + + pax_c = c3_malloc(1 + strlen(pir_u->pax_c)); + strcpy(pax_c, pir_u->pax_c); + + sprintf(key_c, "%" PRIx64 ":%" PRIx64 ":%" PRIx64 ":%" PRIx64 "", + pir_u->key_d[0], + pir_u->key_d[1], + pir_u->key_d[2], + pir_u->key_d[3]); + + sprintf(wag_c, "%u", pir_u->wag_w); + + arg_c[0] = bin_c; // executable + arg_c[1] = pax_c; // path to checkpoint directory + arg_c[2] = key_c; // disk key + arg_c[3] = wag_c; // runtime config + arg_c[4] = 0; + + uv_pipe_init(u3L, &god_u->inn_u.pyp_u, 0); + uv_pipe_init(u3L, &god_u->out_u.pyp_u, 0); + + god_u->cod_u[0].flags = UV_CREATE_PIPE | UV_READABLE_PIPE; + god_u->cod_u[0].data.stream = (uv_stream_t *)&god_u->inn_u; + + god_u->cod_u[1].flags = UV_CREATE_PIPE | UV_WRITABLE_PIPE; + god_u->cod_u[1].data.stream = (uv_stream_t *)&god_u->out_u; + + god_u->cod_u[2].flags = UV_INHERIT_FD; + god_u->cod_u[2].data.fd = 2; + + god_u->ops_u.stdio = god_u->cod_u; + god_u->ops_u.stdio_count = 3; + + god_u->ops_u.exit_cb = _pier_work_exit; + god_u->ops_u.file = arg_c[0]; + god_u->ops_u.args = arg_c; + + if ( (err_i = uv_spawn(u3L, &god_u->cub_u, &god_u->ops_u)) ) { + fprintf(stderr, "spawn: %s: %s\r\n", arg_c[0], uv_strerror(err_i)); + + return 0; + } + } + + /* start reading from proc + */ + { + god_u->out_u.vod_p = pir_u; + god_u->out_u.pok_f = _pier_work_poke; + god_u->out_u.bal_f = _pier_work_bail; + + god_u->inn_u.bal_f = _pier_work_bail; + + u3_newt_read(&god_u->out_u); + } + return god_u; +} + +/* _pier_loop_time(): set time. +*/ +static void +_pier_loop_time(void) +{ + struct timeval tim_tv; + + gettimeofday(&tim_tv, 0); + u3v_time(u3_time_in_tv(&tim_tv)); +} + +/* _pier_loop_prepare(): run on every loop iteration before i/o polling. +*/ +static void +_pier_loop_prepare(uv_prepare_t* pep_u) +{ + _pier_loop_time(); +} + +/* _pier_loop_idle_cb(): run on every loop iteration after i/o polling. +*/ +static void +_pier_loop_idle_cb(uv_idle_t* idl_u) +{ + u3_pier* pir_u = idl_u->data; + _pier_apply(pir_u); + + uv_idle_stop(idl_u); +} + +/* _pier_loop_resume(): (re-)activate idle handler +*/ +static void +_pier_loop_resume(u3_pier* pir_u) +{ + if ( !uv_is_active((uv_handle_t*)&pir_u->idl_u) ) { + uv_idle_start(&pir_u->idl_u, _pier_loop_idle_cb); + } +} + +/* _pier_loop_init_pier(): initialize loop handlers. +*/ +static void +_pier_loop_init(u3_pier* pir_u) +{ + c3_l cod_l; + + _pier_loop_time(); + + // for i/o drivers that still use u3A->sen + // + u3v_numb(); + + cod_l = u3a_lush(c3__ames); + u3_ames_io_init(pir_u); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__behn); + u3_behn_io_init(pir_u); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__unix); + u3_unix_io_init(pir_u); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__save); + u3_save_io_init(pir_u); + u3a_lop(cod_l); + + // XX legacy handlers, not yet scoped to a pier + // + { + cod_l = u3a_lush(c3__term); + u3_term_io_init(); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__http); + u3_http_io_init(); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__cttp); + u3_cttp_io_init(); + u3a_lop(cod_l); + } +} + +/* _pier_loop_wake(): initialize listeners and send initial events. +*/ +static void +_pier_loop_wake(u3_pier* pir_u) +{ + c3_l cod_l; + + // inject fresh entropy + // + { + c3_w eny_w[16]; + c3_rand(eny_w); + + u3_noun wir = u3nt(u3_blip, c3__arvo, u3_nul); + u3_noun car = u3nc(c3__wack, u3i_words(16, eny_w)); + + u3_pier_work(pir_u, wir, car); + } + + cod_l = u3a_lush(c3__unix); + u3_unix_io_talk(pir_u); + u3_unix_ef_bake(pir_u); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__ames); + u3_ames_io_talk(pir_u); + u3_ames_ef_bake(pir_u); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__behn); + u3_behn_ef_bake(pir_u); + u3a_lop(cod_l); + + // XX legacy handlers, not yet scoped to a pier + // + { + cod_l = u3a_lush(c3__http); + u3_http_io_talk(); + u3_http_ef_bake(); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__term); + u3_term_io_talk(); + u3_term_ef_bake(); + u3a_lop(cod_l); + } +} + +/* _pier_loop_exit(): terminate I/O across the process. +*/ +static void +_pier_loop_exit(u3_pier* pir_u) +{ + c3_l cod_l; + + cod_l = u3a_lush(c3__unix); + u3_unix_io_exit(pir_u); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__ames); + u3_ames_io_exit(pir_u); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__save); + u3_save_io_exit(pir_u); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__behn); + u3_behn_io_exit(pir_u); + u3a_lop(cod_l); + + // XX legacy handlers, not yet scoped to a pier + // + { + cod_l = u3a_lush(c3__term); + u3_term_io_exit(); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__http); + u3_http_io_exit(); + u3a_lop(cod_l); + + cod_l = u3a_lush(c3__cttp); + u3_cttp_io_exit(); + u3a_lop(cod_l); + } +} + +/* _pier_boot_set_ship(): +*/ +static void +_pier_boot_set_ship(u3_pier* pir_u, u3_noun who, u3_noun fak) +{ + c3_assert( c3y == u3ud(who) ); + c3_assert( (c3y == fak) || (c3n == fak) ); + + c3_o fak_o = fak; + c3_d who_d[2]; + + u3r_chubs(0, 2, who_d, who); + + c3_assert( ( (0 == pir_u->fak_o) && + (0 == pir_u->who_d[0]) && + (0 == pir_u->who_d[1]) ) || + ( (fak_o == pir_u->fak_o) && + (who_d[0] == pir_u->who_d[0]) && + (who_d[1] == pir_u->who_d[1]) ) ); + + pir_u->fak_o = fak_o; + pir_u->who_d[0] = who_d[0]; + pir_u->who_d[1] = who_d[1]; + + { + u3_noun how = u3dc("scot", 'p', u3k(who)); + + c3_free(pir_u->who_c); + pir_u->who_c = u3r_string(how); + u3z(how); + } + + // Disable networking for fake ships + // + if ( c3y == pir_u->fak_o ) { + u3_Host.ops_u.net = c3n; + } + + u3z(who); u3z(fak); +} + +/* _pier_boot_create(): create boot controller +*/ +static u3_boot* +_pier_boot_create(u3_pier* pir_u, u3_noun pil, u3_noun ven) +{ + u3_boot* bot_u = c3_calloc(sizeof(u3_boot)); + bot_u->pil = u3k(pil); + bot_u->ven = u3k(ven); + bot_u->pir_u = pir_u; + + return bot_u; +} + +/* _pier_boot_dispose(): dispose of boot controller +*/ +static void +_pier_boot_dispose(u3_boot* bot_u) +{ + u3_pier* pir_u = bot_u->pir_u; + + u3z(bot_u->pil); + u3z(bot_u->ven); + free(bot_u); + pir_u->bot_u = 0; +} + +/* _pier_boot_vent(): create and enqueue boot sequence +** +** per cgy: +** this new boot sequence is almost, but not quite, +** the right thing. see new arvo. +*/ +static void +_pier_boot_vent(u3_boot* bot_u) +{ + // bot: boot formulas + // mod: module ova + // use: userpace ova + // + u3_noun bot, mod, use; + u3_pier* pir_u = bot_u->pir_u; + + // extract boot formulas and module/userspace ova from pill + // + { + u3_noun pil_p, pil_q, pil_r; + u3_noun pro; + + c3_assert( c3y == u3du(bot_u->pil) ); + + if ( c3y == u3h(bot_u->pil) ) { + u3x_trel(bot_u->pil, 0, &pil_p, &pil_q); + } + else { + u3x_qual(bot_u->pil, 0, &pil_p, &pil_q, &pil_r); + } + + pro = u3m_soft(0, u3ke_cue, u3k(pil_p)); + + if ( 0 != u3h(pro) ) { + fprintf(stderr, "boot: failed: unable to parse pill\r\n"); + exit(1); + } + + u3x_trel(u3t(pro), &bot, &mod, &use); + u3k(bot); u3k(mod); u3k(use); + + // optionally replace filesystem in userspace + // + if ( c3y == u3h(bot_u->pil) ) { + if ( u3_nul != pil_q ) { + c3_w len_w = 0; + u3_noun ova = use; + u3_noun new = u3_nul; + u3_noun ovo; + + while ( u3_nul != ova ) { + ovo = u3h(ova); + + if ( c3__into == u3h(u3t(ovo)) ) { + c3_assert( 0 == len_w ); + len_w++; + ovo = u3k(u3t(pil_q)); + } + + new = u3nc(u3k(ovo), new); + ova = u3t(ova); + } + + c3_assert( 1 == len_w ); + + u3z(use); + use = u3kb_flop(new); + } + } + // prepend %lite module and userspace ova + // + else { + mod = u3kb_weld(u3k(pil_q), mod); + use = u3kb_weld(u3k(pil_r), use); + } + + u3z(pro); + } + + // prepend entropy to the module sequence + // + { + c3_w eny_w[16]; + c3_rand(eny_w); + + u3_noun wir = u3nt(u3_blip, c3__arvo, u3_nul); + u3_noun car = u3nc(c3__wack, u3i_words(16, eny_w)); + + mod = u3nc(u3nc(wir, car), mod); + } + + // prepend identity to the module sequence, setting single-home + // + { + u3_noun wir = u3nt(u3_blip, c3__arvo, u3_nul); + u3_noun car = u3nc(c3__whom, u3i_chubs(2, pir_u->who_d)); + + mod = u3nc(u3nc(wir, car), mod); + } + + // insert boot sequence directly + // + // Note that these are not ovum or (pair @da ovum) events, + // but raw nock formulas to be directly evaluated as the + // subject of the lifecycle formula [%2 [%0 3] %0 2]. + // All subsequent events will be (pair @da ovum). + // + { + u3_noun fol = bot; + + // initialize the boot barrier + // + // And the initial lifecycle boot barrier. + // + pir_u->but_d = u3kb_lent(u3k(fol)); + pir_u->lif_d = pir_u->but_d; + + while ( u3_nul != fol ) { + _pier_writ_insert(pir_u, 0, u3k(u3h(fol))); + fol = u3t(fol); + } + } + + // insert module events + // + { + u3_noun ova = mod; + // add to the boot barrier + // + pir_u->but_d += u3kb_lent(u3k(ova)); + + while ( u3_nul != ova ) { + _pier_writ_insert_ovum(pir_u, 0, u3k(u3h(ova))); + ova = u3t(ova); + } + } + + // insert legacy boot event + // + { + // XX do something about this wire + // XX route directly to %jael? + // + c3_assert( c3y == u3du(bot_u->ven) ); + + u3_noun wir = u3nq(u3_blip, c3__term, '1', u3_nul); + u3_noun car = u3nc(c3__boot, u3k(bot_u->ven)); + u3_noun ovo = u3nc(wir, car); + + _pier_writ_insert_ovum(pir_u, 0, ovo); + } + + // insert userspace events + // + // Currently just the initial filesystem + // + { + u3_noun ova = use; + + while ( u3_nul != ova ) { + _pier_writ_insert_ovum(pir_u, 0, u3k(u3h(ova))); + ova = u3t(ova); + } + } + + u3z(bot); u3z(mod); u3z(use); +} + +/* _pier_boot_complete(): start organic event flow on boot/reboot. +*/ +static void +_pier_boot_complete(u3_pier* pir_u) +{ + if ( u3_psat_init != pir_u->sat_e ) { + u3_pier_snap(pir_u); + } + + if ( u3_psat_boot == pir_u->sat_e ) { + fprintf(stderr, "pier: boot complete\r\n"); + } + else if ( u3_psat_pace == pir_u->sat_e ) { + fprintf(stderr, "\n\r---------------- playback complete----------------\r\n"); + } + + pir_u->sat_e = u3_psat_play; + + // the main course + // + _pier_loop_wake(pir_u); + + // XX where should this go? + // + { + if ( c3y == u3_Host.ops_u.veb ) { + u3_term_ef_verb(); + } + } +} + +/* _pier_boot_ready(): +*/ +static void +_pier_boot_ready(u3_pier* pir_u) +{ + u3_controller* god_u = pir_u->god_u; + u3_disk* log_u = pir_u->log_u; + + c3_assert( u3_psat_init == pir_u->sat_e ); + + if ( ( 0 == god_u) || + ( 0 == log_u) || + (c3y != god_u->liv_o) || + (c3y != log_u->liv_o) ) + { + return; + } + + // mark all commits as released + // + god_u->rel_d = log_u->com_d; + + // set next expected event number + // + pir_u->gen_d = (1ULL + log_u->com_d); + + // boot + // + if ( 0 != pir_u->bot_u ) { + c3_assert( 0 == log_u->com_d ); + c3_assert( 0 == god_u->dun_d ); + + // construct/enqueue boot sequence + // + _pier_boot_vent(pir_u->bot_u); + _pier_boot_dispose(pir_u->bot_u); + + // prepare worker for boot sequence, write log header + // + _pier_work_boot(pir_u, c3y); + + fprintf(stderr, "boot: ship: %s%s\r\n", + pir_u->who_c, + (c3y == pir_u->fak_o) ? " (fake)" : ""); + + pir_u->sat_e = u3_psat_boot; + } + // replay + // + else if ( god_u->dun_d < log_u->com_d ) { + c3_assert( 0 != log_u->com_d ); + + fprintf(stderr, "---------------- playback starting----------------\r\n"); + + // set the boot barrier to the last committed event + // + pir_u->but_d = log_u->com_d; + + // begin queuing batches of committed events + // + _pier_db_load_commits(pir_u, (1ULL + god_u->dun_d), 1000ULL); + + if ( 0 == god_u->dun_d ) { + fprintf(stderr, "pier: replaying events 1 through %" PRIu64 "\r\n", + log_u->com_d); + + // prepare worker for replay of boot sequence, don't write log header + // + _pier_work_boot(pir_u, c3n); + } + else { + fprintf(stderr, "pier: replaying events %" PRIu64 + " through %" PRIu64 "\r\n", + god_u->dun_d, + log_u->com_d); + } + + pir_u->sat_e = u3_psat_pace; + } + // resume + // + else { + c3_assert( 0 != log_u->com_d ); + c3_assert( 0 != god_u->dun_d ); + + // set the boot barrier to the last computed event + // + pir_u->but_d = god_u->dun_d; + + // resume normal operation + // + _pier_boot_complete(pir_u); + } +} + +/* _pier_apply(): react to i/o, inbound or outbound. +*/ +static void +_pier_apply(u3_pier* pir_u) +{ + u3_disk* log_u = pir_u->log_u; + u3_controller* god_u = pir_u->god_u; + u3_save* sav_u = pir_u->sav_u; + + if ( (0 == log_u) || + (0 == god_u) || + (c3n == god_u->liv_o) || + (u3_psat_init == pir_u->sat_e) ) + { + return; + } + + u3_writ* wit_u; + c3_o act_o = c3n; + +start: + + /* iterate from queue exit, advancing any writs that can advance + */ + wit_u = pir_u->ext_u; + while ( wit_u ) { + /* if writ is (a) next in line to compute, (b) worker is inactive, + ** and (c) a snapshot has not been requested, request computation + */ + if ( (wit_u->evt_d == (1 + god_u->sen_d)) && + (god_u->sen_d == god_u->dun_d) && + (sav_u->dun_d == sav_u->req_d) ) + { + _pier_work_compute(wit_u); + act_o = c3y; + } + + /* if writ is (a) computed and (b) next in line to commit, + ** and (c) no commit is in progress and (d) we've booted, + ** request commit. + */ + if ( (wit_u->evt_d <= god_u->dun_d) && + (wit_u->evt_d == (1 + log_u->moc_d)) && + (wit_u->evt_d == (1 + log_u->com_d)) ) + { + c3_d count = 1 + (god_u->dun_d - wit_u->evt_d); + struct u3_lmdb_write_request* request = + u3_lmdb_build_write_request(wit_u, count); + c3_assert(request != 0); + + _pier_db_commit_request(pir_u, + request, + wit_u->evt_d, + count); + act_o = c3y; + } + + /* if writ is (a) committed and (b) computed, + ** release effects and delete from queue + */ + if ( (wit_u->evt_d <= log_u->com_d) && + (wit_u->evt_d <= god_u->dun_d) ) + { + // effects must be released in order + // + c3_assert(wit_u == pir_u->ext_u); + + // remove from queue + // + // Must be done before releasing effects + // + _pier_writ_unlink(wit_u); + + // release effects + // + _pier_work_release(wit_u); + + // free writ + // + _pier_writ_dispose(wit_u); + + wit_u = pir_u->ext_u; + act_o = c3y; + } + else { + /* otherwise, continue backward + */ + wit_u = wit_u->nex_u; + } + } + + /* if we did anything to the queue, make another pass. + */ + if ( c3y == act_o ) { + act_o = c3n; + goto start; + } +} + +/* _pier_create(): create a pier, loading existing. +*/ +static u3_pier* +_pier_create(c3_w wag_w, c3_c* pax_c) +{ + // create pier + // + u3_pier* pir_u = c3_calloc(sizeof *pir_u); + + pir_u->pax_c = pax_c; + pir_u->wag_w = wag_w; + pir_u->sat_e = u3_psat_init; + + pir_u->sam_u = c3_calloc(sizeof(u3_ames)); + pir_u->teh_u = c3_calloc(sizeof(u3_behn)); + pir_u->unx_u = c3_calloc(sizeof(u3_unix)); + pir_u->sav_u = c3_calloc(sizeof(u3_save)); + + // initialize persistence + // + if ( c3n == _pier_disk_create(pir_u) ) { + return 0; + } + + // start the worker process + // + if ( !(pir_u->god_u = _pier_work_create(pir_u)) ) { + return 0; + } + + // install in the pier table + // + if ( 0 == u3K.all_w ) { + u3K.all_w = 16; + u3K.tab_u = c3_malloc(16 * sizeof(u3_pier*)); + } + if ( u3K.len_w == u3K.all_w ) { + u3K.all_w = 2 * u3K.all_w; + u3K.tab_u = c3_realloc(u3K.tab_u, u3K.all_w * sizeof(u3_pier*)); + } + u3K.tab_u[u3K.len_w++] = pir_u; + + return pir_u; +} + +/* u3_pier_interrupt(): interrupt running process. +*/ +void +u3_pier_interrupt(u3_pier* pir_u) +{ + uv_process_kill(&pir_u->god_u->cub_u, SIGINT); +} + +/* _pier_exit_done(): synchronously shutting down +*/ +static void +_pier_exit_done(u3_pier* pir_u) +{ + u3l_log("pier: exit\r\n"); + + _pier_db_shutdown(pir_u); + _pier_work_shutdown(pir_u); + _pier_loop_exit(pir_u); + + // XX uninstall pier from u3K.tab_u, dispose + + // XX no can do + // + uv_stop(u3L); +} + +/* u3_pier_exit(): trigger a gentle shutdown. +*/ +void +u3_pier_exit(u3_pier* pir_u) +{ + pir_u->sat_e = u3_psat_done; + + // XX must wait for callback confirming + // + u3_pier_snap(pir_u); +} + +/* u3_pier_snap(): request snapshot +*/ +void +u3_pier_snap(u3_pier* pir_u) +{ + u3_controller* god_u = pir_u->god_u; + u3_disk* log_u = pir_u->log_u; + u3_save* sav_u = pir_u->sav_u; + + c3_d top_d = c3_max(god_u->sen_d, god_u->dun_d); + + // no-op if there are no un-snapshot'ed events + // + if ( top_d > sav_u->dun_d ) { + sav_u->req_d = top_d; + + // save eagerly if all computed events are already committed + // + if ( (log_u->com_d >= top_d) && + (god_u->dun_d == top_d) ) { + _pier_work_save(pir_u); + } + } + // if we're gracefully shutting down, do so now + // + else if ( u3_psat_done == pir_u->sat_e ) { + _pier_exit_done(pir_u); + } +} + +/* u3_pier_discover(): insert task into process controller. +*/ +void +u3_pier_discover(u3_pier* pir_u, + c3_l msc_l, + u3_noun job) +{ + _pier_writ_insert(pir_u, msc_l, job); + _pier_loop_resume(pir_u); +} + +/* u3_pier_send(): modern send with target and path. +*/ +void +u3_pier_send(u3_pier* pir_u, u3_noun pax, u3_noun tag, u3_noun fav) +{ +} + +/* u3_pier_work(): send event; real pier pointer. +** +** XX: u3_pier_work() is for legacy events sent to a real pier. +*/ +void +u3_pier_work(u3_pier* pir_u, u3_noun pax, u3_noun fav) +{ + u3_noun now; + struct timeval tim_tv; + + gettimeofday(&tim_tv, 0); + now = u3_time_in_tv(&tim_tv); + + u3_pier_discover(pir_u, 0, u3nt(now, pax, fav)); +} + +/* u3_pier_plan(): send event; fake pier pointer +** +** XX: u3_pier_plan() is maximum legacy, do not use. +*/ +void +u3_pier_plan(u3_noun pax, u3_noun fav) +{ + u3_pier_work(u3_pier_stub(), pax, fav); +} + +/* c3_rand(): fill a 512-bit (16-word) buffer. +*/ +void +c3_rand(c3_w* rad_w) +{ + if ( 0 != ent_getentropy(rad_w, 64) ) { + u3l_log("c3_rand getentropy: %s\n", strerror(errno)); + // XX review + // + u3_pier_bail(); + } +} + +/* u3_pier_bail(): immediately shutdown. +*/ +void +u3_pier_bail(void) +{ + if ( 0 != u3K.len_w ) { + _pier_exit_done(u3_pier_stub()); + } + + fflush(stdout); + exit(1); +} + +/* _pier_tape(): dump a tape, old style. Don't do this. +*/ +static void +_pier_tape(FILE* fil_u, u3_noun tep) +{ + u3_noun tap = tep; + + while ( c3y == u3du(tap) ) { + c3_c car_c; + + if ( u3h(tap) >= 127 ) { + car_c = '?'; + } else car_c = u3h(tap); + + putc(car_c, fil_u); + tap = u3t(tap); + } + u3z(tep); +} + +/* _pier_wall(): dump a wall, old style. Don't do this. +*/ +static void +_pier_wall(u3_noun wol) +{ + FILE* fil_u = u3_term_io_hija(); + u3_noun wal = wol; + + // XX temporary, for urb.py test runner + // + if ( c3y == u3_Host.ops_u.dem ) { + fil_u = stderr; + } + + while ( u3_nul != wal ) { + _pier_tape(fil_u, u3k(u3h(wal))); + + putc(13, fil_u); + putc(10, fil_u); + + wal = u3t(wal); + } + u3_term_io_loja(0); + u3z(wol); +} + +/* u3_pier_tank(): dump single tank. +*/ +void +u3_pier_tank(c3_l tab_l, u3_noun tac) +{ + u3_pier_punt(tab_l, u3nc(tac, u3_nul)); +} + +/* u3_pier_punt(): dump tank list. +*/ +void +u3_pier_punt(c3_l tab_l, u3_noun tac) +{ + u3_noun blu = u3_term_get_blew(0); + c3_l col_l = u3h(blu); + u3_noun cat = tac; + + // We are calling nock here, but hopefully need no protection. + // + while ( c3y == u3r_du(cat) ) { + if ( 0 == u3A->roc ) { + u3_noun act = u3h(cat); + + if ( c3__leaf == u3h(act) ) { + FILE* fil_u = u3_term_io_hija(); + + // XX temporary, for urb.py test runner + // + if ( c3y == u3_Host.ops_u.dem ) { + fil_u = stderr; + } + + _pier_tape(fil_u, u3k(u3t(act))); + putc(13, fil_u); + putc(10, fil_u); + + u3_term_io_loja(0); + } + } + else { + u3_noun wol = u3dc("wash", u3nc(tab_l, col_l), u3k(u3h(cat))); + + _pier_wall(wol); + } + cat = u3t(cat); + } + u3z(tac); + u3z(blu); +} + +/* u3_pier_sway(): print trace. +*/ +void +u3_pier_sway(c3_l tab_l, u3_noun tax) +{ + u3_noun mok = u3dc("mook", 2, tax); + + u3_pier_punt(tab_l, u3k(u3t(mok))); + u3z(mok); +} + +/* u3_pier_stub(): get the One Pier for unreconstructed code. +*/ +u3_pier* +u3_pier_stub(void) +{ + if ( 0 == u3K.len_w ) { + c3_assert(!"plan: no pier"); + } + else { + return u3K.tab_u[0]; + } +} + +/* _pier_init(): initialize pier i/o handles +*/ +static void +_pier_init(u3_pier* pir_u) +{ + // initialize i/o handlers + // + _pier_loop_init(pir_u); + + // initialize pre i/o polling handle + // + uv_prepare_init(u3_Host.lup_u, &pir_u->pep_u); + pir_u->pep_u.data = pir_u; + uv_prepare_start(&pir_u->pep_u, _pier_loop_prepare); + + // initialize post i/o polling handle + // + uv_idle_init(u3_Host.lup_u, &pir_u->idl_u); + pir_u->idl_u.data = pir_u; + + _pier_loop_resume(pir_u); +} + +/* u3_pier_boot(): start the new pier system. +*/ +void +u3_pier_boot(c3_w wag_w, // config flags + u3_noun who, // identity + u3_noun ven, // boot event + u3_noun pil, // type-of/path-to pill + u3_noun pax) // path to pier +{ + // make/load pier + // + u3_pier* pir_u = _pier_create(wag_w, u3r_string(pax)); + + if ( 0 == pir_u ) { + u3l_log("pier: failed to create\r\n"); + u3_daemon_bail(); + exit(1); + } + + // set boot params + // + { + pir_u->bot_u = _pier_boot_create(pir_u, u3k(pil), u3k(ven)); + + _pier_boot_set_ship(pir_u, u3k(who), ( c3__fake == u3h(ven) ) ? c3y : c3n); + } + + _pier_init(pir_u); + + u3z(who); u3z(ven); u3z(pil); u3z(pax); +} + +/* u3_pier_stay(): resume the new pier system. +*/ +void +u3_pier_stay(c3_w wag_w, u3_noun pax) +{ + // make/load pier + // + u3_pier* pir_u = _pier_create(wag_w, u3r_string(pax)); + + if ( 0 == pir_u ) { + u3l_log("pier: failed to create\r\n"); + u3_daemon_bail(); + exit(1); + } + + _pier_init(pir_u); + + u3z(pax); +} + +/* u3_pier_mark(): mark all Loom allocations in all u3_pier structs. +*/ +c3_w +u3_pier_mark(FILE* fil_u) +{ + c3_w len_w = u3K.len_w; + c3_w tot_w = 0; + u3_pier* pir_u; + + while ( 0 < len_w ) { + pir_u = u3K.tab_u[--len_w]; + u3l_log("pier: %u\r\n", len_w); + + if ( 0 != pir_u->bot_u ) { + tot_w += u3a_maid(fil_u, " boot event", u3a_mark_noun(pir_u->bot_u->ven)); + tot_w += u3a_maid(fil_u, " pill", u3a_mark_noun(pir_u->bot_u->pil)); + } + + { + u3_writ* wit_u = pir_u->ent_u; + c3_w wit_w = 0; + + while ( 0 != wit_u ) { + wit_w += u3a_mark_noun(wit_u->job); + wit_w += u3a_mark_noun(wit_u->now); + wit_w += u3a_mark_noun(wit_u->mat); + wit_w += u3a_mark_noun(wit_u->act); + wit_u = wit_u->nex_u; + } + + tot_w += u3a_maid(fil_u, " writs", wit_w); + } + } + + return tot_w; +} diff --git a/pkg/hs/vere/notes/c/reck.c b/pkg/hs/vere/notes/c/reck.c new file mode 100644 index 000000000..ba803e36c --- /dev/null +++ b/pkg/hs/vere/notes/c/reck.c @@ -0,0 +1,482 @@ +/* vere/reck.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +/* _reck_mole(): parse simple atomic mole. +*/ +static u3_noun +_reck_mole(u3_noun fot, + u3_noun san, + c3_d* ato_d) +{ + u3_noun uco = u3dc("slaw", fot, san); + u3_noun p_uco, q_uco; + + if ( (c3n == u3r_cell(uco, &p_uco, &q_uco)) || + (u3_nul != p_uco) ) + { + u3l_log("strange mole %s\n", u3r_string(san)); + + u3z(fot); u3z(uco); return c3n; + } + else { + *ato_d = u3r_chub(0, q_uco); + + u3z(fot); u3z(uco); return c3y; + } +} + +/* _reck_lily(): parse little atom. +*/ +static u3_noun +_reck_lily(u3_noun fot, u3_noun txt, c3_l* tid_l) +{ + c3_d ato_d; + + if ( c3n == _reck_mole(fot, txt, &ato_d) ) { + return c3n; + } else { + if ( ato_d >= 0x80000000ULL ) { + return c3n; + } else { + *tid_l = (c3_l) ato_d; + + return c3y; + } + } +} + +/* _reck_orchid(): parses only a number as text + * + * Parses a text string which contains a decimal number. In practice, this + * number is always '1'. + */ +static u3_noun +_reck_orchid(u3_noun fot, u3_noun txt, c3_l* tid_l) +{ + c3_c* str = u3r_string(txt); + c3_d ato_d = strtol(str, NULL, 10); + free(str); + + if ( ato_d >= 0x80000000ULL ) { + return c3n; + } else { + *tid_l = (c3_l) ato_d; + + return c3y; + } +} + +/* _reck_kick_term(): apply terminal outputs. +*/ +static u3_noun +_reck_kick_term(u3_pier* pir_u, u3_noun pox, c3_l tid_l, u3_noun fav) +{ + u3_noun p_fav; + + if ( c3n == u3du(fav) ) { + u3z(pox); u3z(fav); return c3n; + } + else switch ( u3h(fav) ) { + default: u3z(pox); u3z(fav); return c3n; + case c3__bbye: + { + u3z(pox); u3z(fav); return c3y; + } break; + + case c3__blit: p_fav = u3t(fav); + { + u3_term_ef_blit(tid_l, u3k(p_fav)); + + u3z(pox); u3z(fav); return c3y; + } break; + + // this can return through dill due to our fscked up boot sequence + // + case c3__send: { + u3_noun lan = u3k(u3h(u3t(fav))); + u3_noun pac = u3k(u3t(u3t(fav))); + + u3l_log("kick: strange send\r\n"); + u3_ames_ef_send(pir_u, lan, pac); + u3z(pox); u3z(fav); return c3y; + } break; + + case c3__logo: + { + u3_pier_exit(pir_u); + u3_Host.xit_i = u3t(fav); + + u3z(pox); u3z(fav); return c3y; + } break; + + case c3__init: p_fav = u3t(fav); + { + // daemon ignores %init + // u3A->own = u3nc(u3k(p_fav), u3A->own); + // u3l_log("kick: init: %d\n", p_fav); + u3z(pox); u3z(fav); return c3y; + } break; + + case c3__mass: p_fav = u3t(fav); + { + u3z(pox); u3z(fav); + + // gc the daemon area + // + uv_timer_start(&u3K.tim_u, (uv_timer_cb)u3_daemon_grab, 0, 0); + return c3y; + } break; + } + c3_assert(!"not reached"); return 0; +} + +/* _reck_kick_http(): apply http effects. +*/ +static u3_noun +_reck_kick_http(u3_pier* pir_u, + u3_noun pox, + c3_l sev_l, + c3_l coq_l, + c3_l seq_l, + u3_noun fav) +{ + u3_noun p_fav, q_fav; + + if ( c3n == u3du(fav) ) { + u3z(pox); u3z(fav); return c3n; + } + else switch ( u3h(fav) ) { + default: u3z(pox); u3z(fav); return c3n; + + case c3__form: p_fav = u3t(fav); + { + u3_http_ef_form(u3k(p_fav)); + + // The control server has now started. + // + // If we're in daemon mode, we need to inform the parent process + // that we've finished booting. + if (u3_Host.bot_f) { + u3_Host.bot_f(); + } + + u3z(pox); u3z(fav); + return c3y; + } + + case c3__that: p_fav = u3t(fav); + { + u3_http_ef_that(u3k(p_fav)); + + u3z(pox); u3z(fav); + return c3y; + } + + case c3__thus: p_fav = u3h(u3t(fav)); q_fav = u3t(u3t(fav)); + { + u3_cttp_ef_thus(u3r_word(0, p_fav), u3k(q_fav)); + + u3z(pox); u3z(fav); + return c3y; + } + case c3__thou: p_fav = u3t(fav); + { + u3_http_ef_thou(sev_l, coq_l, seq_l, u3k(p_fav)); + + u3z(pox); u3z(fav); + return c3y; + } break; + } + c3_assert(!"not reached"); return c3n; +} + +/* _reck_kick_behn(): apply packet network outputs. +*/ +static u3_noun +_reck_kick_behn(u3_pier* pir_u, u3_noun pox, u3_noun fav) +{ + switch ( u3h(fav) ) { + default: break; + + case c3__doze: { + u3_behn_ef_doze(pir_u, u3k(u3t(fav))); + u3z(pox); u3z(fav); return c3y; + } break; + } + u3z(pox); u3z(fav); return c3n; +} + +/* _reck_kick_sync(): apply sync outputs. +*/ +static u3_noun +_reck_kick_sync(u3_pier* pir_u, u3_noun pox, u3_noun fav) +{ + switch ( u3h(fav) ) { + default: break; + case c3__dirk: { + u3_unix_ef_dirk(pir_u, u3k(u3t(fav))); + u3z(pox); u3z(fav); return c3y; + } + case c3__ergo: { + u3_noun mon = u3k(u3h(u3t(fav))); + u3_noun can = u3k(u3t(u3t(fav))); + + u3_unix_ef_ergo(pir_u, mon, can); + u3z(pox); u3z(fav); return c3y; + } break; + case c3__ogre: { + u3_unix_ef_ogre(pir_u, u3k(u3t(fav))); + u3z(pox); u3z(fav); return c3y; + } + case c3__hill: { + u3_unix_ef_hill(pir_u, u3k(u3t(fav))); + u3z(pox); u3z(fav); return c3y; + } + } + + // XX obviously not right! + // ? looks fine to me + u3z(pox); u3z(fav); return c3n; +} + +/* _reck_kick_newt(): apply packet network outputs. +*/ +static u3_noun +_reck_kick_newt(u3_pier* pir_u, u3_noun pox, u3_noun fav) +{ + switch ( u3h(fav) ) { + default: break; + case c3__send: { + u3_noun lan = u3k(u3h(u3t(fav))); + u3_noun pac = u3k(u3t(u3t(fav))); + + u3_ames_ef_send(pir_u, lan, pac); + u3z(pox); u3z(fav); return c3y; + } break; + + case c3__turf: { + u3_ames_ef_turf(pir_u, u3k(u3t(fav))); + u3z(pox); u3z(fav); return c3y; + } break; + + } + u3z(pox); u3z(fav); return c3n; +} + +/* _reck_kick_ames(): apply packet network outputs. +*/ +static u3_noun +_reck_kick_ames(u3_pier* pir_u, u3_noun pox, u3_noun fav) +{ + u3_noun p_fav; + + switch ( u3h(fav) ) { + default: break; + case c3__init: p_fav = u3t(fav); + { + // daemon ignores %init + // u3A->own = u3nc(u3k(p_fav), u3A->own); + // u3l_log("kick: init: %d\n", p_fav); + u3z(pox); u3z(fav); return c3y; + } break; + } + u3z(pox); u3z(fav); return c3n; +} + +/* _reck_kick_spec(): apply an effect, by path. +*/ +static u3_noun +_reck_kick_spec(u3_pier* pir_u, u3_noun pox, u3_noun fav) +{ + u3_noun i_pox, t_pox; + + if ( (c3n == u3r_cell(pox, &i_pox, &t_pox)) || + ((i_pox != u3_blip) && + (i_pox != c3__gold) && + (i_pox != c3__iron) && + (i_pox != c3__lead)) ) + { + u3z(pox); u3z(fav); return c3n; + } else { + u3_noun it_pox, tt_pox; + + if ( (c3n == u3r_cell(t_pox, &it_pox, &tt_pox)) ) { + u3z(pox); u3z(fav); return c3n; + } + else switch ( it_pox ) { + default: u3z(pox); u3z(fav); return c3n; + + case c3__http: { + u3_noun pud = tt_pox; + u3_noun p_pud, t_pud, tt_pud, q_pud, r_pud, s_pud; + c3_l sev_l, coq_l, seq_l; + + if ( (c3n == u3r_cell(pud, &p_pud, &t_pud)) || + (c3n == _reck_lily(c3__uv, u3k(p_pud), &sev_l)) ) + { + u3z(pox); u3z(fav); return c3n; + } + + if ( u3_nul == t_pud ) { + coq_l = seq_l = 0; + } + else { + if ( (c3n == u3r_cell(t_pud, &q_pud, &tt_pud)) || + (c3n == _reck_lily(c3__ud, u3k(q_pud), &coq_l)) ) + { + u3z(pox); u3z(fav); return c3n; + } + + if ( u3_nul == tt_pud ) { + seq_l = 0; + } else { + if ( (c3n == u3r_cell(tt_pud, &r_pud, &s_pud)) || + (u3_nul != s_pud) || + (c3n == _reck_lily(c3__ud, u3k(r_pud), &seq_l)) ) + { + u3z(pox); u3z(fav); return c3n; + } + } + } + return _reck_kick_http(pir_u, pox, sev_l, coq_l, seq_l, fav); + } break; + + case c3__behn: { + return _reck_kick_behn(pir_u, pox, fav); + } break; + + case c3__clay: + case c3__boat: + case c3__sync: { + return _reck_kick_sync(pir_u, pox, fav); + } break; + + case c3__newt: { + return _reck_kick_newt(pir_u, pox, fav); + } break; + + case c3__ames: { + if ( (u3_nul != tt_pox) ) { + u3z(pox); u3z(fav); return c3n; + } + else { + return _reck_kick_ames(pir_u, pox, fav); + } + } break; + + case c3__init: { + // daemon ignores %init + // p_fav = u3t(fav); + // u3A->own = u3nc(u3k(p_fav), u3A->own); + // u3l_log("kick: init: %d\n", p_fav); + u3z(pox); u3z(fav); return c3y; + } break; + + case c3__term: { + u3_noun pud = tt_pox; + u3_noun p_pud, q_pud; + c3_l tid_l; + + if ( (c3n == u3r_cell(pud, &p_pud, &q_pud)) || + (u3_nul != q_pud) || + (c3n == _reck_orchid(c3__ud, u3k(p_pud), &tid_l)) ) + { + u3l_log("term: bad tire\n"); + u3z(pox); u3z(fav); return c3n; + } else { + return _reck_kick_term(pir_u, pox, tid_l, fav); + } + } break; + } + } + c3_assert(!"not reached"); + return c3n; +} + +/* _reck_kick_norm(): non path-specific effect handling. +*/ +static u3_noun +_reck_kick_norm(u3_pier* pir_u, u3_noun pox, u3_noun fav) +{ + if ( c3n == u3du(fav) ) { + u3z(pox); u3z(fav); return c3n; + } + else switch ( u3h(fav) ) { + default: u3z(pox); u3z(fav); return c3n; + + case c3__vega: + { + u3l_log("<<>>\n"); + u3z(pox); u3z(fav); + + // reclaim memory from persistent caches + // + u3m_reclaim(); + + return c3y; + } + case c3__exit: + { + u3l_log("<<>>\n"); + u3_pier_exit(pir_u); + + u3z(pox); u3z(fav); return c3y; + } break; + } + c3_assert(!"not reached"); return c3n; + u3z(pox); u3z(fav); return c3n; +} + +/* u3_reck_kick(): handle effect. +*/ +void +u3_reck_kick(u3_pier* pir_u, u3_noun ovo) +{ + if ( (c3n == _reck_kick_spec(pir_u, u3k(u3h(ovo)), u3k(u3t(ovo)))) && + (c3n == _reck_kick_norm(pir_u, u3k(u3h(ovo)), u3k(u3t(ovo)))) ) + { +#if 0 + if ( (c3__warn != u3h(u3t(ovo))) && + (c3__text != u3h(u3t(ovo))) && + (c3__note != u3h(u3t(ovo))) ) +#endif +#if 1 + if ( (c3__crud == u3h(u3t(ovo))) ) +#if 0 + (c3__talk == u3h(u3t(ovo))) || + (c3__helo == u3h(u3t(ovo))) || + (c3__init == u3h(u3t(ovo))) ) +#endif + { + u3_pier_work(pir_u, + u3nt(u3_blip, c3__term, u3_nul), + u3nc(c3__flog, u3k(u3t(ovo)))); + } + else { + u3_noun tox = u3do("spat", u3k(u3h(ovo))); + u3l_log("kick: lost %%%s on %s\n", + u3r_string(u3h(u3t(ovo))), + u3r_string(tox)); + u3z(tox); +#if 0 + if ( c3__hear == u3h(u3t(ovo)) ) { + c3_assert(0); + } +#endif + } +#endif + } + u3z(ovo); +} diff --git a/pkg/hs/vere/notes/c/save.c b/pkg/hs/vere/notes/c/save.c new file mode 100644 index 000000000..1c62e8442 --- /dev/null +++ b/pkg/hs/vere/notes/c/save.c @@ -0,0 +1,66 @@ +/* vere/save.c +** +*/ +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +/* _save_time_cb(): timer callback. +*/ +static void +_save_time_cb(uv_timer_t* tim_u) +{ + u3_pier *pir_u = tim_u->data; + u3_pier_snap(pir_u); +} + +/* u3_save_ef_chld(): report save termination. +*/ +void +u3_save_ef_chld(u3_pier *pir_u) +{ + u3_save* sav_u = pir_u->sav_u; + c3_i loc_i; + c3_w pid_w; + + /* modified for cases with no pid_w + */ + u3l_log("checkpoint: complete %d\n", sav_u->pid_w); + pid_w = wait(&loc_i); + if (0 != sav_u->pid_w) { + c3_assert(pid_w == sav_u->pid_w); + } + else { + c3_assert(pid_w > 0); + } + sav_u->pid_w = 0; +} + +/* u3_save_io_init(): initialize autosave. +*/ +void +u3_save_io_init(u3_pier *pir_u) +{ + u3_save* sav_u = pir_u->sav_u; + + sav_u->req_d = 0; + sav_u->dun_d = 0; + sav_u->pid_w = 0; + + sav_u->tim_u.data = pir_u; + uv_timer_init(u3L, &sav_u->tim_u); + uv_timer_start(&sav_u->tim_u, _save_time_cb, 120000, 120000); +} + +/* u3_save_io_exit(): terminate save I/O. +*/ +void +u3_save_io_exit(u3_pier *pir_u) +{ +} diff --git a/pkg/hs/vere/notes/c/term.c b/pkg/hs/vere/notes/c/term.c new file mode 100644 index 000000000..868a33c53 --- /dev/null +++ b/pkg/hs/vere/notes/c/term.c @@ -0,0 +1,1342 @@ +/* vere/term.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +static void _term_spinner_cb(void*); +static void _term_read_cb(uv_stream_t* tcp_u, + ssize_t siz_i, + const uv_buf_t * buf_u); +static inline void _term_suck(u3_utty*, const c3_y*, ssize_t); +static u3_utty* _term_main(); + +#define _SPIN_COOL_US 500000 // spinner activation delay when cool +#define _SPIN_WARM_US 50000 // spinner activation delay when warm +#define _SPIN_RATE_US 250000 // spinner rate (microseconds/frame) +#define _SPIN_IDLE_US 500000 // spinner cools down if stopped this long + +static void _write(int fd, const void *buf, size_t count) +{ + if (count != write(fd, buf, count)){ + u3l_log("write failed\r\n"); + c3_assert(0); + } +} + + +/* _term_msc_out_host(): unix microseconds from current host time. +*/ +static c3_d +_term_msc_out_host() +{ + struct timeval tim_tv; + gettimeofday(&tim_tv, 0); + return 1000000ULL * tim_tv.tv_sec + tim_tv.tv_usec; +} + +/* _term_alloc(): libuv buffer allocator. +*/ +static void +_term_alloc(uv_handle_t* had_u, + size_t len_i, + uv_buf_t* buf + ) +{ + // this read can range from a single byte to a paste buffer + // 123 bytes has been chosen because its not a power of 2 + // this is probably still broken + // + void* ptr_v = c3_malloc(123); + *buf = uv_buf_init(ptr_v, 123); +} + + +// XX unused, but %hook is in %zuse. +// implement or remove +// +#if 0 +/* _term_close_cb(): free terminal. +*/ +static void +_term_close_cb(uv_handle_t* han_t) +{ + u3_utty* tty_u = (void*) han_t; + if ( u3_Host.uty_u == tty_u ) { + u3_Host.uty_u = tty_u->nex_u; + } + else { + u3_utty* uty_u; + for (uty_u = u3_Host.uty_u; uty_u; uty_u = uty_u->nex_u ) { + if ( uty_u->nex_u == tty_u ) { + uty_u->nex_u = tty_u->nex_u; + break; + } + } + } + + { + u3_noun tid = u3dc("scot", c3__ud, tty_u->tid_l); + u3_noun pax = u3nq(u3_blip, c3__term, tid, u3_nul); + u3_pier_plan(u3k(pax), u3nc(c3__hook, u3_nul)); + u3z(pax); + } + free(tty_u); +} +#endif + +/* u3_term_io_init(): initialize terminal. +*/ +void +u3_term_io_init() +{ + u3_utty* uty_u = c3_calloc(sizeof(u3_utty)); + + if ( c3y == u3_Host.ops_u.dem ) { + uty_u->fid_i = 1; + + uv_pipe_init(u3L, &(uty_u->pop_u), 0); + uv_pipe_open(&(uty_u->pop_u), uty_u->fid_i); + } + else { + // Initialize event processing. Rawdog it. + // + { + uty_u->fid_i = 0; // stdin, yes we write to it... + + uv_pipe_init(u3L, &(uty_u->pop_u), 0); + uv_pipe_open(&(uty_u->pop_u), uty_u->fid_i); + uv_read_start((uv_stream_t*)&(uty_u->pop_u), _term_alloc, _term_read_cb); + } + + // Configure horrible stateful terminfo api. + // + { + if ( 0 != setupterm(0, 2, 0) ) { + c3_assert(!"init-setupterm"); + } + } + + // Load terminfo strings. + // + { + c3_w len_w; + +# define _utfo(way, nam) \ + { \ + uty_u->ufo_u.way.nam##_y = (const c3_y *) tigetstr(#nam); \ + c3_assert(uty_u->ufo_u.way.nam##_y); \ + } + + uty_u->ufo_u.inn.max_w = 0; + + _utfo(inn, kcuu1); + _utfo(inn, kcud1); + _utfo(inn, kcub1); + _utfo(inn, kcuf1); + + _utfo(out, clear); + _utfo(out, el); + // _utfo(out, el1); + _utfo(out, ed); + _utfo(out, bel); + _utfo(out, cub1); + _utfo(out, cuf1); + _utfo(out, cuu1); + _utfo(out, cud1); + // _utfo(out, cub); + // _utfo(out, cuf); + + // Terminfo chronically reports the wrong sequence for arrow + // keys on xterms. Drastic fix for ridiculous unacceptable bug. + // Yes, we could fix this with smkx/rmkx, but this is retarded as well. + { + uty_u->ufo_u.inn.kcuu1_y = (const c3_y*)"\033[A"; + uty_u->ufo_u.inn.kcud1_y = (const c3_y*)"\033[B"; + uty_u->ufo_u.inn.kcuf1_y = (const c3_y*)"\033[C"; + uty_u->ufo_u.inn.kcub1_y = (const c3_y*)"\033[D"; + } + + uty_u->ufo_u.inn.max_w = 0; + if ( (len_w = strlen((c3_c*)uty_u->ufo_u.inn.kcuu1_y)) > + uty_u->ufo_u.inn.max_w ) + { + uty_u->ufo_u.inn.max_w = len_w; + } + if ( (len_w = strlen((c3_c*)uty_u->ufo_u.inn.kcud1_y)) > + uty_u->ufo_u.inn.max_w ) + { + uty_u->ufo_u.inn.max_w = len_w; + } + if ( (len_w = strlen((c3_c*)uty_u->ufo_u.inn.kcub1_y)) > + uty_u->ufo_u.inn.max_w ) + { + uty_u->ufo_u.inn.max_w = len_w; + } + if ( (len_w = strlen((c3_c*)uty_u->ufo_u.inn.kcuf1_y)) > + uty_u->ufo_u.inn.max_w ) + { + uty_u->ufo_u.inn.max_w = len_w; + } + } + + // Load old terminal state to restore. + // + { + if ( 0 != tcgetattr(uty_u->fid_i, &uty_u->bak_u) ) { + c3_assert(!"init-tcgetattr"); + } + if ( -1 == fcntl(uty_u->fid_i, F_GETFL, &uty_u->cug_i) ) { + c3_assert(!"init-fcntl"); + } + uty_u->cug_i &= ~O_NONBLOCK; // could fix? + uty_u->nob_i = uty_u->cug_i | O_NONBLOCK; // O_NDELAY on older unix + } + + // Construct raw termios configuration. + // + { + uty_u->raw_u = uty_u->bak_u; + + uty_u->raw_u.c_lflag &= ~(ECHO | ECHONL | ICANON | IEXTEN); + uty_u->raw_u.c_iflag &= ~(ICRNL | INPCK | ISTRIP); + uty_u->raw_u.c_cflag &= ~(CSIZE | PARENB); + uty_u->raw_u.c_cflag |= CS8; + uty_u->raw_u.c_oflag &= ~(OPOST); + uty_u->raw_u.c_cc[VMIN] = 0; + uty_u->raw_u.c_cc[VTIME] = 0; + } + + // Initialize mirror and accumulator state. + // + { + uty_u->tat_u.mir.lin_w = 0; + uty_u->tat_u.mir.len_w = 0; + uty_u->tat_u.mir.cus_w = 0; + + uty_u->tat_u.esc.ape = c3n; + uty_u->tat_u.esc.bra = c3n; + + uty_u->tat_u.fut.len_w = 0; + uty_u->tat_u.fut.wid_w = 0; + } + } + + // This is terminal 1, linked in host. + // + { + uty_u->tid_l = 1; + uty_u->nex_u = 0; + u3_Host.uty_u = uty_u; + } + + if ( c3n == u3_Host.ops_u.dem ) { + // Start raw input. + // + { + if ( 0 != tcsetattr(uty_u->fid_i, TCSADRAIN, &uty_u->raw_u) ) { + c3_assert(!"init-tcsetattr"); + } + if ( -1 == fcntl(uty_u->fid_i, F_SETFL, uty_u->nob_i) ) { + c3_assert(!"init-fcntl"); + } + } + + // Start spinner thread. + // + { + uty_u->tat_u.sun.sit_u = (uv_thread_t*)malloc(sizeof(uv_thread_t)); + if ( uty_u->tat_u.sun.sit_u ) { + uv_mutex_init(&uty_u->tat_u.mex_u); + uv_mutex_lock(&uty_u->tat_u.mex_u); + + c3_w ret_w = uv_thread_create(uty_u->tat_u.sun.sit_u, + _term_spinner_cb, + uty_u); + if ( 0 != ret_w ) { + u3l_log("term: spinner start: %s\n", uv_strerror(ret_w)); + free(uty_u->tat_u.sun.sit_u); + uty_u->tat_u.sun.sit_u = NULL; + uv_mutex_unlock(&uty_u->tat_u.mex_u); + uv_mutex_destroy(&uty_u->tat_u.mex_u); + } + } + } + } +} + +void +u3_term_io_talk(void) +{ +} + +/* u3_term_io_exit(): clean up terminal. +*/ +void +u3_term_io_exit(void) +{ + if ( c3y == u3_Host.ops_u.dem ) { + uv_close((uv_handle_t*)&u3_Host.uty_u->pop_u, NULL); + } + else { + u3_utty* uty_u; + + for ( uty_u = u3_Host.uty_u; uty_u; uty_u = uty_u->nex_u ) { + if ( uty_u->fid_i == -1 ) { continue; } + if ( 0 != tcsetattr(uty_u->fid_i, TCSADRAIN, &uty_u->bak_u) ) { + c3_assert(!"exit-tcsetattr"); + } + if ( -1 == fcntl(uty_u->fid_i, F_SETFL, uty_u->cug_i) ) { + c3_assert(!"exit-fcntl"); + } + _write(uty_u->fid_i, "\r\n", 2); + +#if 0 + if ( uty_u->tat_u.sun.sit_u ) { + uv_thread_t* sit_u = uty_u->tat_u.sun.sit_u; + uty_u->tat_u.sun.sit_u = NULL; + + uv_mutex_unlock(&uty_u->tat_u.mex_u); + + // XX can block exit waiting for wakeup (max _SPIN_COOL_US) + c3_w ret_w; + if ( 0 != (ret_w = uv_thread_join(sit_u)) ) { + u3l_log("term: spinner exit: %s\n", uv_strerror(ret_w)); + } + else { + uv_mutex_destroy(&uty_u->tat_u.mex_u); + } + + free(sit_u); + } +#endif + } + } +} + +/* _term_it_buf(): create a data buffer. +*/ +static u3_ubuf* +_term_it_buf(c3_w len_w, const c3_y* hun_y) +{ + u3_ubuf* buf_u = c3_malloc(len_w + sizeof(*buf_u)); + + buf_u->len_w = len_w; + memcpy(buf_u->hun_y, hun_y, len_w); + + buf_u->nex_u = 0; + return buf_u; +} + +/* An unusual lameness in libuv. +*/ + typedef struct { + uv_write_t wri_u; + c3_y* buf_y; + } _u3_write_t; + +/* _term_write_cb(): general write callback. +*/ +static void +_term_write_cb(uv_write_t* wri_u, c3_i sas_i) +{ + _u3_write_t* ruq_u = (void *)wri_u; + + if ( 0 != sas_i ) { + // u3l_log("term: write: ERROR\n"); + } + free(ruq_u->buf_y); + free(ruq_u); +} + +/* _term_it_write_buf(): write buffer uv style. +*/ +static void +_term_it_write_buf(u3_utty* uty_u, uv_buf_t buf_u) +{ + _u3_write_t* ruq_u = (_u3_write_t*) c3_malloc(sizeof(_u3_write_t)); + + ruq_u->buf_y = (c3_y*)buf_u.base; + + c3_w ret_w; + if ( 0 != (ret_w = uv_write(&ruq_u->wri_u, + (uv_stream_t*)&(uty_u->pop_u), + &buf_u, 1, + _term_write_cb)) ) + { + u3l_log("terminal: %s\n", uv_strerror(ret_w)); + } +} + +/* _term_it_write_old(): write buffer, transferring pointer. +*/ +static void +_term_it_write_old(u3_utty* uty_u, + u3_ubuf* old_u) +{ + uv_buf_t buf_u; + + // XX extra copy here due to old code. Use hbod as base directly. + // + { + c3_y* buf_y = c3_malloc(old_u->len_w); + + memcpy(buf_y, old_u->hun_y, old_u->len_w); + buf_u = uv_buf_init((c3_c*)buf_y, old_u->len_w); + + free(old_u); + } + _term_it_write_buf(uty_u, buf_u); +} + +/* _term_it_write_bytes(): write bytes, retaining pointer. +*/ +static void +_term_it_write_bytes(u3_utty* uty_u, + c3_w len_w, + const c3_y* hun_y) +{ + _term_it_write_old(uty_u, _term_it_buf(len_w, hun_y)); +} + +/* _term_it_write_txt(): write null-terminated string, retaining pointer. +*/ +static void +_term_it_write_txt(u3_utty* uty_u, + const c3_y* hun_y) +{ + _term_it_write_bytes(uty_u, strlen((const c3_c*)hun_y), hun_y); +} + +/* _term_it_write_str(): write null-terminated string, retaining pointer. +*/ +static void +_term_it_write_str(u3_utty* uty_u, + const c3_c* str_c) +{ + _term_it_write_txt(uty_u, (const c3_y*) str_c); +} + +/* _term_it_show_wide(): show wide text, retaining. +*/ +static void +_term_it_show_wide(u3_utty* uty_u, c3_w len_w, c3_w* txt_w) +{ + u3_noun wad = u3i_words(len_w, txt_w); + u3_noun txt = u3do("tuft", wad); + c3_c* txt_c = u3r_string(txt); + + _term_it_write_str(uty_u, txt_c); + free(txt_c); + u3z(txt); + + uty_u->tat_u.mir.cus_w += len_w; +} + +/* _term_it_show_clear(): clear to the beginning of the current line. +*/ +static void +_term_it_show_clear(u3_utty* uty_u) +{ + if ( uty_u->tat_u.siz.col_l ) { + _term_it_write_str(uty_u, "\r"); + _term_it_write_txt(uty_u, uty_u->ufo_u.out.el_y); + + uty_u->tat_u.mir.len_w = 0; + uty_u->tat_u.mir.cus_w = 0; + } +} + +/* _term_it_show_blank(): blank the screen. +*/ +static void +_term_it_show_blank(u3_utty* uty_u) +{ + _term_it_write_txt(uty_u, uty_u->ufo_u.out.clear_y); +} + +/* _term_it_show_cursor(): set current line, transferring pointer. +*/ +static void +_term_it_show_cursor(u3_utty* uty_u, c3_w cur_w) +{ + if ( cur_w < uty_u->tat_u.mir.cus_w ) { + c3_w dif_w = (uty_u->tat_u.mir.cus_w - cur_w); + + while ( dif_w-- ) { + _term_it_write_txt(uty_u, uty_u->ufo_u.out.cub1_y); + } + } + else if ( cur_w > uty_u->tat_u.mir.cus_w ) { + c3_w dif_w = (cur_w - uty_u->tat_u.mir.cus_w); + + while ( dif_w-- ) { + _term_it_write_txt(uty_u, uty_u->ufo_u.out.cuf1_y); + } + } + uty_u->tat_u.mir.cus_w = cur_w; +} + +/* _term_it_show_line(): set current line +*/ +static void +_term_it_show_line(u3_utty* uty_u, c3_w* lin_w, c3_w len_w) +{ + _term_it_show_wide(uty_u, len_w, lin_w); + + if ( lin_w != uty_u->tat_u.mir.lin_w ) { + if ( uty_u->tat_u.mir.lin_w ) { + free(uty_u->tat_u.mir.lin_w); + } + uty_u->tat_u.mir.lin_w = lin_w; + } + uty_u->tat_u.mir.len_w = len_w; +} + +/* _term_it_refresh_line(): refresh current line. +*/ +static void +_term_it_refresh_line(u3_utty* uty_u) +{ + c3_w len_w = uty_u->tat_u.mir.len_w; + c3_w cus_w = uty_u->tat_u.mir.cus_w; + + _term_it_show_clear(uty_u); + _term_it_show_line(uty_u, uty_u->tat_u.mir.lin_w, len_w); + _term_it_show_cursor(uty_u, cus_w); +} + +/* _term_it_show_more(): new current line. +*/ +static void +_term_it_show_more(u3_utty* uty_u) +{ + if ( c3y == u3_Host.ops_u.dem ) { + _term_it_write_str(uty_u, "\n"); + } else { + _term_it_write_str(uty_u, "\r\n"); + } + uty_u->tat_u.mir.cus_w = 0; +} + +/* _term_it_path(): path for console file. +*/ +static c3_c* +_term_it_path(c3_o fyl, u3_noun pax) +{ + c3_w len_w; + c3_c *pas_c; + + // measure + // + len_w = strlen(u3_Host.dir_c); + { + u3_noun wiz = pax; + + while ( u3_nul != wiz ) { + len_w += (1 + u3r_met(3, u3h(wiz))); + wiz = u3t(wiz); + } + } + + // cut + // + pas_c = c3_malloc(len_w + 1); + strncpy(pas_c, u3_Host.dir_c, len_w); + pas_c[len_w] = '\0'; + { + u3_noun wiz = pax; + c3_c* waq_c = (pas_c + strlen(pas_c)); + + while ( u3_nul != wiz ) { + c3_w tis_w = u3r_met(3, u3h(wiz)); + + if ( (c3y == fyl) && (u3_nul == u3t(wiz)) ) { + *waq_c++ = '.'; + } else *waq_c++ = '/'; + + u3r_bytes(0, tis_w, (c3_y*)waq_c, u3h(wiz)); + waq_c += tis_w; + + wiz = u3t(wiz); + } + *waq_c = 0; + } + u3z(pax); + return pas_c; +} + +/* _term_it_save(): save file by path. +*/ +static void +_term_it_save(u3_noun pax, u3_noun pad) +{ + c3_c* pax_c; + c3_c* bas_c = 0; + c3_w xap_w = u3kb_lent(u3k(pax)); + u3_noun xap = u3_nul; + u3_noun urb = c3_s4('.','u','r','b'); + u3_noun put = c3_s3('p','u','t'); + + // directory base and relative path + if ( 2 < xap_w ) { + u3_noun bas = u3nt(urb, put, u3_nul); + bas_c = _term_it_path(c3n, bas); + xap = u3qb_scag(xap_w - 2, pax); + } + + pax = u3nt(urb, put, pax); + pax_c = _term_it_path(c3y, pax); + + u3_walk_save(pax_c, 0, pad, bas_c, xap); + + free(pax_c); + free(bas_c); +} + +/* _term_io_belt(): send belt. +*/ +static void +_term_io_belt(u3_utty* uty_u, u3_noun blb) +{ + u3_noun tid = u3dc("scot", c3__ud, uty_u->tid_l); + u3_noun pax = u3nq(u3_blip, c3__term, tid, u3_nul); + + u3_pier_plan(pax, u3nc(c3__belt, blb)); +} + +/* _term_io_suck_char(): process a single character. +*/ +static void +_term_io_suck_char(u3_utty* uty_u, c3_y cay_y) +{ + u3_utat* tat_u = &uty_u->tat_u; + + if ( c3y == tat_u->esc.ape ) { + if ( c3y == tat_u->esc.bra ) { + switch ( cay_y ) { + default: { + _term_it_write_txt(uty_u, uty_u->ufo_u.out.bel_y); + break; + } + case 'A': _term_io_belt(uty_u, u3nc(c3__aro, 'u')); break; + case 'B': _term_io_belt(uty_u, u3nc(c3__aro, 'd')); break; + case 'C': _term_io_belt(uty_u, u3nc(c3__aro, 'r')); break; + case 'D': _term_io_belt(uty_u, u3nc(c3__aro, 'l')); break; + } + tat_u->esc.ape = tat_u->esc.bra = c3n; + } + else { + if ( (cay_y >= 'a') && (cay_y <= 'z') ) { + tat_u->esc.ape = c3n; + _term_io_belt(uty_u, u3nc(c3__met, cay_y)); + } + else if ( '.' == cay_y ) { + tat_u->esc.ape = c3n; + _term_io_belt(uty_u, u3nc(c3__met, c3__dot)); + } + else if ( 8 == cay_y || 127 == cay_y ) { + tat_u->esc.ape = c3n; + _term_io_belt(uty_u, u3nc(c3__met, c3__bac)); + } + else if ( ('[' == cay_y) || ('O' == cay_y) ) { + tat_u->esc.bra = c3y; + } + else { + tat_u->esc.ape = c3n; + + _term_it_write_txt(uty_u, uty_u->ufo_u.out.bel_y); + } + } + } + else if ( 0 != tat_u->fut.wid_w ) { + tat_u->fut.syb_y[tat_u->fut.len_w++] = cay_y; + + if ( tat_u->fut.len_w == tat_u->fut.wid_w ) { + u3_noun huv = u3i_bytes(tat_u->fut.wid_w, tat_u->fut.syb_y); + u3_noun wug; + + // u3l_log("muck-utf8 len %d\n", tat_u->fut.len_w); + // u3l_log("muck-utf8 %x\n", huv); + wug = u3do("taft", huv); + // u3l_log("muck-utf32 %x\n", tat_u->fut.len_w); + + tat_u->fut.len_w = tat_u->fut.wid_w = 0; + _term_io_belt(uty_u, u3nt(c3__txt, wug, u3_nul)); + } + } + else { + if ( (cay_y >= 32) && (cay_y < 127) ) { + _term_io_belt(uty_u, u3nt(c3__txt, cay_y, u3_nul)); + } + else if ( 0 == cay_y ) { + _term_it_write_txt(uty_u, uty_u->ufo_u.out.bel_y); + } + else if ( 8 == cay_y || 127 == cay_y ) { + _term_io_belt(uty_u, u3nc(c3__bac, u3_nul)); + } + else if ( 13 == cay_y ) { + _term_io_belt(uty_u, u3nc(c3__ret, u3_nul)); + } +#if 0 + else if ( 6 == cay_y ) { + _term_io_flow(uty_u); // XX hack + } +#endif + else if ( cay_y <= 26 ) { + _term_io_belt(uty_u, u3nc(c3__ctl, ('a' + (cay_y - 1)))); + } + else if ( 27 == cay_y ) { + tat_u->esc.ape = c3y; + } + else if ( cay_y >= 128 ) { + tat_u->fut.len_w = 1; + tat_u->fut.syb_y[0] = cay_y; + + if ( cay_y < 224 ) { + tat_u->fut.wid_w = 2; + } else if ( cay_y < 240 ) { + tat_u->fut.wid_w = 3; + } else tat_u->fut.wid_w = 4; + } + } +} + +/* _term_suck(): process a chunk of input +*/ + +/* + * `nread` (siz_w) is > 0 if there is data available, 0 if libuv is done reading for + * now, or < 0 on error. + * + * The callee is responsible for closing the stream when an error happens + * by calling uv_close(). Trying to read from the stream again is undefined. + * + * The callee is responsible for freeing the buffer, libuv does not reuse it. + * The buffer may be a null buffer (where buf->base=NULL and buf->len=0) on + * error. + */ + +static inline void +_term_suck(u3_utty* uty_u, const c3_y* buf, ssize_t siz_i) +{ + { + if ( siz_i == UV_EOF ) { + // We hear EOF (on the third read callback) if + // 2x the _term_alloc() buffer size is pasted. + // The process hangs if we do nothing (and ctrl-z + // then corrupts the event log), so we force shutdown. + // + u3l_log("term: hangup (EOF)\r\n"); + u3_pier_exit(u3_pier_stub()); + } + else if ( siz_i < 0 ) { + u3l_log("term %d: read: %s\n", uty_u->tid_l, uv_strerror(siz_i)); + } + else { + c3_i i; + + for ( i=0; i < siz_i; i++ ) { + _term_io_suck_char(uty_u, buf[i]); + } + } + } +} + +/* _term_read_cb(): server read callback. +*/ +static void +_term_read_cb(uv_stream_t* tcp_u, + ssize_t siz_i, + const uv_buf_t * buf_u) +{ + u3_utty* uty_u = (u3_utty*)(void*)tcp_u; + _term_suck(uty_u, (const c3_y*)buf_u->base, siz_i); + free(buf_u->base); +} + +/* _term_try_write_str(): write null-terminated string (off-thread, retain). +*/ +static void +_term_try_write_str(u3_utty* uty_u, + const c3_c* hun_y) +{ + // c3_i fid_i = uv_fileno(&uty_u->pop_u); + c3_i fid_i = uty_u->pop_u.io_watcher.fd; // XX old libuv + _write(fid_i, hun_y, strlen(hun_y)); +} + +/* _term_try_move_left(): move the cursor left (off-thread). +*/ +static void +_term_try_move_left(u3_utty* uty_u) +{ + _term_try_write_str(uty_u, (const c3_c*)uty_u->ufo_u.out.cub1_y); +} + +/* _term_show_spinner(): render spinner (off-thread). +*/ +static void +_term_show_spinner(u3_utty* uty_u, c3_d lag_d) +{ + if ( 0 == uty_u->tat_u.sun.eve_d ) { + return; + } + + c3_w cus_w = uty_u->tat_u.mir.cus_w; + + if ( cus_w >= uty_u->tat_u.siz.col_l ) { // shenanigans! + return; + } + + c3_w bac_w = uty_u->tat_u.siz.col_l - 1 - cus_w; // backoff from end of line + + const c3_c daz_c[] = "|/-\\"; + const c3_c dal_c[] = "\xc2\xab"; + const c3_c dar_c[] = "\xc2\xbb"; + + c3_c buf_c[1 + 2 + 4 + 2 + 1]; + // | + « + why + » + \0 + + c3_c* cur_c = buf_c; + + *cur_c++ = daz_c[(lag_d / _SPIN_RATE_US) % strlen(daz_c)]; + c3_w sol_w = 1; // spinner length (utf-32) + + c3_c* why_c = uty_u->tat_u.sun.why_c; + if ( why_c && strlen(why_c) <= 4 ) { + strcpy(cur_c, dal_c); + cur_c += strlen(dal_c); + sol_w += 1; // length of dal_c (utf-32) + + c3_w wel_w = strlen(why_c); + strcpy(cur_c, why_c); + cur_c += wel_w; + sol_w += wel_w; + + strcpy(cur_c, dar_c); + cur_c += strlen(dar_c); + sol_w += 1; // length of dar_c (utf-32) + } + *cur_c = '\0'; + + // One-time cursor backoff. + if ( c3n == uty_u->tat_u.sun.diz_o ) { + c3_w i_w; + for ( i_w = bac_w; i_w < sol_w; i_w++ ) { + _term_try_move_left(uty_u); + } + } + + _term_try_write_str(uty_u, buf_c); + uty_u->tat_u.sun.diz_o = c3y; + + // Cursor stays on spinner. + while ( sol_w-- ) { + _term_try_move_left(uty_u); + } +} + +/* _term_start_spinner(): prepare spinner state. RETAIN. +*/ +static void +_term_start_spinner(u3_utty* uty_u, u3_noun ovo) +{ + uty_u->tat_u.sun.diz_o = c3n; + + c3_d now_d = _term_msc_out_host(); + + // If we receive an event shortly after a previous spin, use a shorter delay + // to avoid giving the impression of a half-idle system. + // + c3_d lag_d; + if ( now_d - uty_u->tat_u.sun.end_d < _SPIN_IDLE_US ) { + lag_d = _SPIN_WARM_US; + } + else { + lag_d = _SPIN_COOL_US; + } + + // second item of the event wire + // + u3_noun why = u3h(u3t(u3h(u3t(ovo)))); + if ( c3__term == why ) { + u3_noun eve = u3t(u3t(ovo)); + if ( c3__belt == u3h(eve) && c3__ret == u3h(u3t(eve)) ) { + lag_d = 0; // No delay for %ret. + } + } + else { + uty_u->tat_u.sun.why_c = (c3_c*)u3r_string(why); + } + + uty_u->tat_u.sun.eve_d = now_d + lag_d; + + uv_mutex_unlock(&uty_u->tat_u.mex_u); +} + +/* u3_term_stop_spinner(): reset spinner state and restore input line. +*/ +static void +_term_stop_spinner(u3_utty* uty_u) +{ + uv_mutex_lock(&uty_u->tat_u.mex_u); + + if ( c3y == uty_u->tat_u.sun.diz_o ) { + _term_it_refresh_line(uty_u); + uty_u->tat_u.sun.end_d = _term_msc_out_host(); + } + else { + uty_u->tat_u.sun.end_d = 0; + } + + uty_u->tat_u.sun.diz_o = c3n; + uty_u->tat_u.sun.eve_d = 0; + free(uty_u->tat_u.sun.why_c); + uty_u->tat_u.sun.why_c = NULL; +} + +/* u3_term_start_spinner(): prepare spinner state. RETAIN. +*/ +void +u3_term_start_spinner(u3_noun ovo) +{ + if ( c3n == u3_Host.ops_u.dem ) { + _term_start_spinner(_term_main(), ovo); + } +} + +/* u3_term_stop_spinner(): reset spinner state and restore input line. +*/ +void +u3_term_stop_spinner(void) +{ + if ( c3n == u3_Host.ops_u.dem ) { + _term_stop_spinner(_term_main()); + } +} + +/* _term_spinner_cb(): manage spinner (off-thread). +*/ +static void +_term_spinner_cb(void* ptr_v) +{ + // This thread shouldn't receive signals. + // + { + sigset_t set; + sigfillset(&set); + pthread_sigmask(SIG_BLOCK, &set, NULL); + } + + u3_utty* uty_u = (u3_utty*)ptr_v; + + for ( uv_mutex_lock(&uty_u->tat_u.mex_u); + uty_u->tat_u.sun.sit_u; + uv_mutex_lock(&uty_u->tat_u.mex_u) ) + { + c3_d eve_d = uty_u->tat_u.sun.eve_d; + + if ( 0 == eve_d ) { + c3_o diz_o = uty_u->tat_u.sun.diz_o; + uv_mutex_unlock(&uty_u->tat_u.mex_u); + usleep(c3y == diz_o ? _SPIN_WARM_US : _SPIN_COOL_US); + } + else { + c3_d now_d = _term_msc_out_host(); + + if (now_d < eve_d) { + uv_mutex_unlock(&uty_u->tat_u.mex_u); + usleep(eve_d - now_d); + } + else { + _term_show_spinner(uty_u, now_d - eve_d); + uv_mutex_unlock(&uty_u->tat_u.mex_u); + usleep(_SPIN_RATE_US); + } + } + } + + uv_mutex_unlock(&uty_u->tat_u.mex_u); +} + +/* _term_main(): return main or console terminal. +*/ +static u3_utty* +_term_main() +{ + u3_utty* uty_u; + + for ( uty_u = u3_Host.uty_u; uty_u; uty_u = uty_u->nex_u ) { + if ( (uty_u->fid_i != -1) && (uty_u->fid_i <= 2) ) { + return uty_u; + } + } + return u3_Host.uty_u; +} + +/* _term_ef_get(): terminal by id. +*/ +static u3_utty* +_term_ef_get(c3_l tid_l) +{ + if ( 0 != tid_l ) { + u3_utty* uty_u; + + for ( uty_u = u3_Host.uty_u; uty_u; uty_u = uty_u->nex_u ) { + if ( tid_l == uty_u->tid_l ) { + return uty_u; + } + } + } + return _term_main(); +} + +/* u3_term_get_blew(): return window size [columns rows]. +*/ +u3_noun +u3_term_get_blew(c3_l tid_l) +{ + u3_utty* uty_u = _term_ef_get(tid_l); + c3_l col_l, row_l; + + struct winsize siz_u; + if ( uty_u && (0 == ioctl(uty_u->fid_i, TIOCGWINSZ, &siz_u)) ) { + col_l = siz_u.ws_col; + row_l = siz_u.ws_row; + } else { + col_l = 80; + row_l = 24; + } + + if ( uty_u ) { + uty_u->tat_u.siz.col_l = col_l; + uty_u->tat_u.siz.row_l = row_l; + } + + return u3nc(col_l, row_l); +} + +/* u3_term_ef_winc(): window change. Just console right now. +*/ +void +u3_term_ef_winc(void) +{ + u3_noun pax = u3nq(u3_blip, c3__term, '1', u3_nul); + + u3_pier_plan(pax, u3nc(c3__blew, u3_term_get_blew(1))); +} + +/* u3_term_ef_ctlc(): send ^C on console. +*/ +void +u3_term_ef_ctlc(void) +{ + u3_noun pax = u3nq(u3_blip, c3__term, '1', u3_nul); + + u3_pier_plan(pax, u3nt(c3__belt, c3__ctl, 'c')); + + _term_it_refresh_line(_term_main()); +} + +/* u3_term_ef_verb(): initial effects for verbose events +*/ +void +u3_term_ef_verb(void) +{ + u3_noun pax = u3nq(u3_blip, c3__term, '1', u3_nul); + + u3_pier_plan(pax, u3nc(c3__verb, u3_nul)); +} + +/* u3_term_ef_bake(): initial effects for new terminal. +*/ +void +u3_term_ef_bake(void) +{ + u3_noun pax = u3nq(u3_blip, c3__term, '1', u3_nul); + + // u3_pier_plan(u3k(pax), u3nq(c3__flow, c3__seat, c3__dojo, u3_nul)); + u3_pier_plan(u3k(pax), u3nc(c3__blew, u3_term_get_blew(1))); + u3_pier_plan(u3k(pax), u3nc(c3__hail, u3_nul)); + + u3z(pax); +} + +/* _term_ef_blit(): send blit to terminal. +*/ +static void +_term_ef_blit(u3_utty* uty_u, + u3_noun blt) +{ + switch ( u3h(blt) ) { + default: break; + case c3__bee: { + if ( c3n == u3_Host.ops_u.dem ) { + if ( u3_nul == u3t(blt) ) { + _term_stop_spinner(uty_u); + } + else { + _term_start_spinner(uty_u, u3t(blt)); + } + } + } break; + + case c3__bel: { + if ( c3n == u3_Host.ops_u.dem ) { + _term_it_write_txt(uty_u, uty_u->ufo_u.out.bel_y); + } + } break; + + case c3__clr: { + if ( c3n == u3_Host.ops_u.dem ) { + _term_it_show_blank(uty_u); + _term_it_refresh_line(uty_u); + } + } break; + + case c3__hop: { + if ( c3n == u3_Host.ops_u.dem ) { + _term_it_show_cursor(uty_u, u3t(blt)); + } + } break; + + case c3__lin: { + u3_noun lin = u3t(blt); + c3_w len_w = u3kb_lent(u3k(lin)); + c3_w* lin_w = c3_malloc(4 * len_w); + + { + c3_w i_w; + + for ( i_w = 0; u3_nul != lin; i_w++, lin = u3t(lin) ) { + lin_w[i_w] = u3r_word(0, u3h(lin)); + } + } + + if ( c3n == u3_Host.ops_u.dem ) { + _term_it_show_clear(uty_u); + _term_it_show_line(uty_u, lin_w, len_w); + } else { + _term_it_show_line(uty_u, lin_w, len_w); + } + } break; + + case c3__mor: { + _term_it_show_more(uty_u); + } break; + + case c3__sav: { + _term_it_save(u3k(u3h(u3t(blt))), u3k(u3t(u3t(blt)))); + } break; + + case c3__sag: { + u3_noun pib = u3k(u3t(u3t(blt))); + u3_noun jam; + + jam = u3ke_jam(pib); + + _term_it_save(u3k(u3h(u3t(blt))), jam); + } break; + + case c3__url: { + if ( c3n == u3ud(u3t(blt)) ) { + break; + } else { + c3_c* txt_c = u3r_string(u3t(blt)); + + _term_it_show_clear(uty_u); + _term_it_write_str(uty_u, txt_c); + free(txt_c); + + _term_it_show_more(uty_u); + _term_it_refresh_line(uty_u); + } + } + } + u3z(blt); + + return; +} + +/* u3_term_ef_blit(): send %blit list to specific terminal. +*/ +void +u3_term_ef_blit(c3_l tid_l, + u3_noun bls) +{ + u3_utty* uty_u = _term_ef_get(tid_l); + + if ( 0 == uty_u ) { + // u3l_log("no terminal %d\n", tid_l); + // u3l_log("uty_u %p\n", u3_Host.uty_u); + + u3z(bls); return; + } + + { + u3_noun bis = bls; + + while ( c3y == u3du(bis) ) { + _term_ef_blit(uty_u, u3k(u3h(bis))); + bis = u3t(bis); + } + u3z(bls); + } +} + +/* u3_term_io_hija(): hijack console for fprintf, returning FILE*. +*/ +FILE* +u3_term_io_hija(void) +{ + u3_utty* uty_u = _term_main(); + + if ( uty_u ) { + if ( uty_u->fid_i > 2 ) { + // We *should* in fact, produce some kind of fake FILE* for + // non-console terminals. If we use this interface enough... + // + c3_assert(0); + } + else { + if ( c3n == u3_Host.ops_u.dem ) { + if ( 0 != tcsetattr(1, TCSADRAIN, &uty_u->bak_u) ) { + perror("hija-tcsetattr-1"); + c3_assert(!"hija-tcsetattr"); + } + if ( -1 == fcntl(1, F_SETFL, uty_u->cug_i) ) { + perror("hija-fcntl-1"); + c3_assert(!"hija-fcntl"); + } + if ( 0 != tcsetattr(0, TCSADRAIN, &uty_u->bak_u) ) { + perror("hija-tcsetattr-0"); + c3_assert(!"hija-tcsetattr"); + } + if ( -1 == fcntl(0, F_SETFL, uty_u->cug_i) ) { + perror("hija-fcntl-0"); + c3_assert(!"hija-fcntl"); + } + _write(uty_u->fid_i, "\r", 1); + _write(uty_u->fid_i, uty_u->ufo_u.out.el_y, + strlen((c3_c*) uty_u->ufo_u.out.el_y)); + } + return stdout; + } + } + else return stdout; +} + +/* u3_term_io_loja(): release console from fprintf. +*/ +void +u3_term_io_loja(int x) +{ + u3_utty* uty_u = _term_main(); + + if ( uty_u ) { + if ( uty_u->fid_i > 2 ) { + // We *should* in fact, produce some kind of fake FILE* for + // non-console terminals. If we use this interface enough... + // + c3_assert(0); + } + else { + if ( c3y == u3_Host.ops_u.dem ) { + fflush(stdout); + } + else { + if ( 0 != tcsetattr(1, TCSADRAIN, &uty_u->raw_u) ) { + perror("loja-tcsetattr-1"); + c3_assert(!"loja-tcsetattr"); + } + if ( -1 == fcntl(1, F_SETFL, uty_u->nob_i) ) { + perror("hija-fcntl-1"); + c3_assert(!"loja-fcntl"); + } + if ( 0 != tcsetattr(0, TCSADRAIN, &uty_u->raw_u) ) { + perror("loja-tcsetattr-0"); + c3_assert(!"loja-tcsetattr"); + } + if ( -1 == fcntl(0, F_SETFL, uty_u->nob_i) ) { + perror("hija-fcntl-0"); + c3_assert(!"loja-fcntl"); + } + _term_it_refresh_line(uty_u); + } + } + } +} + +/* u3_term_it_log(): writes a log message +*/ +void +u3_term_io_log(c3_c* line) +{ + FILE* stream = u3_term_io_hija(); + u3_term_io_loja(fprintf(stream, "%s", line)); +} + +/* u3_term_tape_to(): dump a tape to a file. +*/ +void +u3_term_tape_to(FILE *fil_f, u3_noun tep) +{ + u3_noun tap = tep; + + while ( u3_nul != tap ) { + c3_c car_c; + + if ( u3h(tap) >= 127 ) { + car_c = '?'; + } else car_c = u3h(tap); + + putc(car_c, fil_f); + tap = u3t(tap); + } + u3z(tep); +} + +/* u3_term_tape(): dump a tape to stdout. +*/ +void +u3_term_tape(u3_noun tep) +{ + FILE* fil_f = u3_term_io_hija(); + + u3_term_tape_to(fil_f, tep); + + u3_term_io_loja(0); +} + +/* u3_term_wall(): dump a wall to stdout. +*/ +void +u3_term_wall(u3_noun wol) +{ + FILE* fil_f = u3_term_io_hija(); + u3_noun wal = wol; + + while ( u3_nul != wal ) { + u3_term_tape_to(fil_f, u3k(u3h(wal))); + + putc(13, fil_f); + putc(10, fil_f); + + wal = u3t(wal); + } + u3_term_io_loja(0); + + u3z(wol); +} diff --git a/pkg/hs/vere/notes/c/time.c b/pkg/hs/vere/notes/c/time.c new file mode 100644 index 000000000..2a36cf822 --- /dev/null +++ b/pkg/hs/vere/notes/c/time.c @@ -0,0 +1,179 @@ +/* vere/time.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + +/* u3_time_sec_in(): urbit seconds from unix time. +** +** Adjust for future leap secs! +*/ +c3_d +u3_time_sec_in(c3_w unx_w) +{ + return 0x8000000cce9e0d80ULL + (c3_d)unx_w; +} + +/* u3_time_sec_out(): unix time from urbit seconds. +** +** Adjust for future leap secs! +*/ +c3_w +u3_time_sec_out(c3_d urs_d) +{ + c3_d adj_d = (urs_d - 0x8000000cce9e0d80ULL); + + if ( adj_d > 0xffffffffULL ) { + fprintf(stderr, "Agh! It's 2106! And no one's fixed this shite!\n"); + exit(1); + } + return (c3_w)adj_d; +} + +/* u3_time_fsc_in(): urbit fracto-seconds from unix microseconds. +*/ +c3_d +u3_time_fsc_in(c3_w usc_w) +{ + c3_d usc_d = usc_w; + + return ((usc_d * 65536ULL) / 1000000ULL) << 48ULL; +} + +/* u3_time_fsc_out: unix microseconds from urbit fracto-seconds. +*/ +c3_w +u3_time_fsc_out(c3_d ufc_d) +{ + return (c3_w) (((ufc_d >> 48ULL) * 1000000ULL) / 65536ULL); +} + +/* u3_time_msc_out: unix microseconds from urbit fracto-seconds. +*/ +c3_w +u3_time_msc_out(c3_d ufc_d) +{ + return (c3_w) (((ufc_d >> 48ULL) * 1000ULL) / 65536ULL); +} + +/* u3_time_in_tv(): urbit time from struct timeval. +*/ +u3_atom +u3_time_in_tv(struct timeval* tim_tv) +{ + c3_w unx_w = tim_tv->tv_sec; + c3_w usc_w = tim_tv->tv_usec; + c3_d cub_d[2]; + + cub_d[0] = u3_time_fsc_in(usc_w); + cub_d[1] = u3_time_sec_in(unx_w); + + return u3i_chubs(2, cub_d); +} + +/* u3_time_out_tv(): struct timeval from urbit time. +*/ +void +u3_time_out_tv(struct timeval* tim_tv, u3_noun now) +{ + c3_d ufc_d = u3r_chub(0, now); + c3_d urs_d = u3r_chub(1, now); + + tim_tv->tv_sec = u3_time_sec_out(urs_d); + tim_tv->tv_usec = u3_time_fsc_out(ufc_d); + + u3z(now); +} + +/* u3_time_in_ts(): urbit time from struct timespec. +*/ +u3_atom +u3_time_in_ts(struct timespec* tim_ts) +{ + struct timeval tim_tv; + + tim_tv.tv_sec = tim_ts->tv_sec; + tim_tv.tv_usec = (tim_ts->tv_nsec / 1000); + + return u3_time_in_tv(&tim_tv); +} + +#if defined(U3_OS_linux) +/* u3_time_t_in_ts(): urbit time from time_t. +*/ +u3_atom +u3_time_t_in_ts(time_t tim) +{ + struct timeval tim_tv; + + tim_tv.tv_sec = tim; + tim_tv.tv_usec = 0; + + return u3_time_in_tv(&tim_tv); +} +#endif // defined(U3_OS_linux) + +/* u3_time_out_ts(): struct timespec from urbit time. +*/ +void +u3_time_out_ts(struct timespec* tim_ts, u3_noun now) +{ + struct timeval tim_tv; + + u3_time_out_tv(&tim_tv, now); + + tim_ts->tv_sec = tim_tv.tv_sec; + tim_ts->tv_nsec = (tim_tv.tv_usec * 1000); +} + +/* u3_time_gap_ms(): (wen - now) in ms. +*/ +c3_d +u3_time_gap_ms(u3_noun now, u3_noun wen) +{ + if ( c3n == u3ka_gth(u3k(wen), u3k(now)) ) { + u3z(wen); u3z(now); + return 0ULL; + } + else { + u3_noun dif = u3ka_sub(wen, now); + c3_d fsc_d = u3r_chub(0, dif); + c3_d sec_d = u3r_chub(1, dif); + + u3z(dif); + return (sec_d * 1000ULL) + u3_time_msc_out(fsc_d); + } +} + +/* u3_time_gap_double(): (wen - now) in libev resolution. +*/ +double +u3_time_gap_double(u3_noun now, u3_noun wen) +{ + mpz_t now_mp, wen_mp, dif_mp; + double sec_g = (((double)(1ULL << 32ULL)) * ((double)(1ULL << 32ULL))); + double gap_g, dif_g; + + u3r_mp(now_mp, now); + u3r_mp(wen_mp, wen); + mpz_init(dif_mp); + mpz_sub(dif_mp, wen_mp, now_mp); + + u3z(now); + u3z(wen); + + dif_g = mpz_get_d(dif_mp) / sec_g; + gap_g = (dif_g > 0.0) ? dif_g : 0.0; + mpz_clear(dif_mp); mpz_clear(wen_mp); mpz_clear(now_mp); + + return gap_g; +} diff --git a/pkg/hs/vere/notes/c/unix.c b/pkg/hs/vere/notes/c/unix.c new file mode 100644 index 000000000..e3a013293 --- /dev/null +++ b/pkg/hs/vere/notes/c/unix.c @@ -0,0 +1,1333 @@ +/* vere/unix.c +** +*/ +#include "all.h" +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "vere/vere.h" + +c3_w u3_readdir_r(DIR *dirp, struct dirent *entry, struct dirent **result) +{ + errno = 0; + struct dirent * tmp_u = readdir(dirp); + + if (NULL == tmp_u){ + *result = NULL; + return (errno); // either success or error code + } else { + memcpy(entry, tmp_u, sizeof(struct dirent)); + *result = entry; + } + + return(0); +} + + +/* _unix_down(): descend path. +*/ +static c3_c* +_unix_down(c3_c* pax_c, c3_c* sub_c) +{ + c3_w pax_w = strlen(pax_c); + c3_w sub_w = strlen(sub_c); + c3_c* don_c = c3_malloc(pax_w + sub_w + 2); + + strncpy(don_c, pax_c, pax_w); + don_c[pax_w] = '/'; + strncpy(don_c + pax_w + 1, sub_c, sub_w); + don_c[pax_w + 1 + sub_w] = '\0'; + + return don_c; +} + +/* _unix_string_to_path(): convert c string to u3_noun path + * + * c string must begin with the pier path plus mountpoint +*/ +static u3_noun +_unix_string_to_path_helper(c3_c* pax_c) { + c3_assert(pax_c[-1] == '/'); + c3_c* end_w = strchr(pax_c, '/'); + if ( !end_w ) { + end_w = strrchr(pax_c, '.'); + if ( !end_w ) { + return u3nc(u3i_string(pax_c), u3_nul); + } + else { + return u3nt(u3i_bytes(end_w - pax_c, (c3_y*) pax_c), + u3i_string(end_w + 1), + u3_nul); + } + } + else { + return u3nc(u3i_bytes(end_w - pax_c, (c3_y*) pax_c), + _unix_string_to_path_helper(end_w + 1)); + } +} +static u3_noun +_unix_string_to_path(u3_pier *pir_u, c3_c* pax_c) { + pax_c += strlen(pir_u->pax_c) + 1; + c3_c* pox_c = strchr(pax_c, '/'); + if ( !pox_c ) { + pox_c = strchr(pax_c, '.'); + if ( !pox_c ) { + return u3_nul; + } + else { + return u3nc(u3i_string(pox_c + 1), u3_nul); + } + } + else { + return _unix_string_to_path_helper(pox_c + 1); + } +} + +/* _unix_rm_r_cb(): callback to delete individual files/directories +*/ +static c3_i +_unix_rm_r_cb(const c3_c* pax_c, + const struct stat* buf_u, + c3_i typeflag, + struct FTW* ftw_u) +{ + switch ( typeflag ) { + default: + u3l_log("bad file type in rm_r: %s\r\n", pax_c); + break; + case FTW_F: + if ( 0 != unlink(pax_c) && ENOENT != errno ) { + u3l_log("error unlinking (in rm_r) %s: %s\n", + pax_c, strerror(errno)); + c3_assert(0); + } + break; + case FTW_D: + u3l_log("shouldn't have gotten pure directory: %s\r\n", pax_c); + break; + case FTW_DNR: + u3l_log("couldn't read directory: %s\r\n", pax_c); + break; + case FTW_NS: + u3l_log("couldn't stat path: %s\r\n", pax_c); + break; + case FTW_DP: + if ( 0 != rmdir(pax_c) && ENOENT != errno ) { + u3l_log("error rmdiring %s: %s\n", pax_c, strerror(errno)); + c3_assert(0); + } + break; + case FTW_SL: + u3l_log("got symbolic link: %s\r\n", pax_c); + break; + case FTW_SLN: + u3l_log("got nonexistent symbolic link: %s\r\n", pax_c); + break; + } + + return 0; +} + +/* _unix_rm_r(): rm -r directory +*/ +static void +_unix_rm_r(c3_c* pax_c) +{ + if ( 0 > nftw(pax_c, _unix_rm_r_cb, 100, FTW_DEPTH | FTW_PHYS ) + && ENOENT != errno) { + u3l_log("rm_r error on %s: %s\r\n", pax_c, strerror(errno)); + } +} + +/* _unix_mkdir(): mkdir, asserting. +*/ +static void +_unix_mkdir(c3_c* pax_c) +{ + if ( 0 != mkdir(pax_c, 0755) && EEXIST != errno) { + u3l_log("error mkdiring %s: %s\n", pax_c, strerror(errno)); + c3_assert(0); + } +} + +/* _unix_write_file_hard(): write to a file, overwriting what's there +*/ +static c3_w +_unix_write_file_hard(c3_c* pax_c, u3_noun mim) +{ + c3_i fid_i = open(pax_c, O_WRONLY | O_CREAT | O_TRUNC, 0666); + c3_w len_w, rit_w, siz_w, mug_w = 0; + c3_y* dat_y; + + u3_noun dat = u3t(u3t(mim)); + + if ( fid_i < 0 ) { + u3l_log("error opening %s for writing: %s\r\n", + pax_c, strerror(errno)); + u3z(mim); + return 0; + } + + siz_w = u3h(u3t(mim)); + len_w = u3r_met(3, dat); + dat_y = c3_calloc(siz_w); + + u3r_bytes(0, len_w, dat_y, dat); + u3z(mim); + + rit_w = write(fid_i, dat_y, siz_w); + + if ( rit_w != siz_w ) { + u3l_log("error writing %s: %s\r\n", + pax_c, strerror(errno)); + mug_w = 0; + } + else { + mug_w = u3r_mug_bytes(dat_y, len_w); + } + + close(fid_i); + free(dat_y); + + return mug_w; +} + +/* _unix_write_file_soft(): write to a file, not overwriting if it's changed +*/ +static void +_unix_write_file_soft(u3_ufil* fil_u, u3_noun mim) +{ + struct stat buf_u; + c3_i fid_i = open(fil_u->pax_c, O_RDONLY, 0644); + c3_ws len_ws, red_ws; + c3_w old_w; + c3_y* old_y; + + if ( fid_i < 0 || fstat(fid_i, &buf_u) < 0 ) { + if ( ENOENT == errno ) { + goto _unix_write_file_soft_go; + } + else { + u3l_log("error opening file (soft) %s: %s\r\n", + fil_u->pax_c, strerror(errno)); + u3z(mim); + return; + } + } + + len_ws = buf_u.st_size; + old_y = c3_malloc(len_ws); + + red_ws = read(fid_i, old_y, len_ws); + + if ( close(fid_i) < 0 ) { + u3l_log("error closing file (soft) %s: %s\r\n", + fil_u->pax_c, strerror(errno)); + } + + if ( len_ws != red_ws ) { + if ( red_ws < 0 ) { + u3l_log("error reading file (soft) %s: %s\r\n", + fil_u->pax_c, strerror(errno)); + } + else { + u3l_log("wrong # of bytes read in file %s: %d %d\r\n", + fil_u->pax_c, len_ws, red_ws); + } + free(old_y); + u3z(mim); + return; + } + + old_w = u3r_mug_bytes(old_y, len_ws); + + if ( old_w != fil_u->gum_w ) { + fil_u->gum_w = u3r_mug(u3t(u3t(mim))); // XXX this might fail with + free(old_y); // trailing zeros + u3z(mim); + return; + } + + free(old_y); + +_unix_write_file_soft_go: + fil_u->gum_w = _unix_write_file_hard(fil_u->pax_c, mim); +} + +static void +_unix_watch_dir(u3_udir* dir_u, u3_udir* par_u, c3_c* pax_c); +static void +_unix_watch_file(u3_pier *pir_u, u3_ufil* fil_u, u3_udir* par_u, c3_c* pax_c); + +/* _unix_get_mount_point(): retrieve or create mount point +*/ +static u3_umon* +_unix_get_mount_point(u3_pier *pir_u, u3_noun mon) +{ + if ( c3n == u3ud(mon) ) { + c3_assert(!"mount point must be an atom"); + u3z(mon); + return NULL; + } + + c3_c* nam_c = u3r_string(mon); + u3_umon* mon_u; + + for ( mon_u = pir_u->unx_u->mon_u; + mon_u && 0 != strcmp(nam_c, mon_u->nam_c); + mon_u = mon_u->nex_u ) + { + } + + if ( !mon_u ) { + mon_u = c3_malloc(sizeof(u3_umon)); + mon_u->nam_c = nam_c; + mon_u->dir_u.dir = c3y; + mon_u->dir_u.dry = c3n; + mon_u->dir_u.pax_c = strdup(pir_u->pax_c); + mon_u->dir_u.par_u = NULL; + mon_u->dir_u.nex_u = NULL; + mon_u->dir_u.kid_u = NULL; + mon_u->nex_u = pir_u->unx_u->mon_u; + pir_u->unx_u->mon_u = mon_u; + + } + else { + free(nam_c); + } + + u3z(mon); + + return mon_u; +} + +/* _unix_scan_mount_point(): scan unix for already-existing mount point +*/ +static void +_unix_scan_mount_point(u3_pier *pir_u, u3_umon* mon_u) +{ + DIR* rid_u = opendir(mon_u->dir_u.pax_c); + if ( !rid_u ) { + u3l_log("error opening pier directory: %s: %s\r\n", + mon_u->dir_u.pax_c, strerror(errno)); + return; + } + + c3_w len_w = strlen(mon_u->nam_c); + + while ( 1 ) { + struct dirent ent_u; + struct dirent* out_u; + c3_w err_w; + + if ( 0 != (err_w = u3_readdir_r(rid_u, &ent_u, &out_u)) ) { + u3l_log("erroring loading pier directory %s: %s\r\n", + mon_u->dir_u.pax_c, strerror(errno)); + + c3_assert(0); + } + else if ( !out_u ) { + break; + } + else if ( '.' == out_u->d_name[0] ) { // unnecessary, but consistency + continue; + } + else if ( 0 != strncmp(mon_u->nam_c, out_u->d_name, len_w) ) { + continue; + } + else { + c3_c* pax_c = _unix_down(mon_u->dir_u.pax_c, out_u->d_name); + + struct stat buf_u; + + if ( 0 != stat(pax_c, &buf_u) ) { + u3l_log("can't stat pier directory %s: %s\r\n", + mon_u->dir_u.pax_c, strerror(errno)); + free(pax_c); + continue; + } + if ( S_ISDIR(buf_u.st_mode) ) { + if ( out_u->d_name[len_w] != '\0' ) { + free(pax_c); + continue; + } + else { + u3_udir* dir_u = c3_malloc(sizeof(u3_udir)); + _unix_watch_dir(dir_u, &mon_u->dir_u, pax_c); + } + } + else { + if ( '.' != out_u->d_name[len_w] + || '\0' == out_u->d_name[len_w + 1] + || '~' == out_u->d_name[strlen(out_u->d_name) - 1] + || ('#' == out_u->d_name[0] && + '#' == out_u->d_name[strlen(out_u->d_name) - 1]) + ) { + free(pax_c); + continue; + } + else { + u3_ufil* fil_u = c3_malloc(sizeof(u3_ufil)); + _unix_watch_file(pir_u, fil_u, &mon_u->dir_u, pax_c); + } + } + + free(pax_c); + } + } +} + +static u3_noun _unix_free_node(u3_pier *pir_u, u3_unod* nod_u); + +/* _unix_free_file(): free file, unlinking it +*/ +static void +_unix_free_file(u3_ufil *fil_u) +{ + if ( 0 != unlink(fil_u->pax_c) && ENOENT != errno ) { + u3l_log("error unlinking %s: %s\n", fil_u->pax_c, strerror(errno)); + c3_assert(0); + } + + free(fil_u->pax_c); + free(fil_u); +} + +/* _unix_free_dir(): free directory, deleting everything within +*/ +static void +_unix_free_dir(u3_udir *dir_u) +{ + _unix_rm_r(dir_u->pax_c); + + if ( dir_u->kid_u ) { + fprintf(stderr, "don't kill me, i've got a family %s\r\n", dir_u->pax_c); + } + else { + // fprintf(stderr, "i'm a lone, lonely loner %s\r\n", dir_u->pax_c); + } + free(dir_u->pax_c); + free(dir_u); // XXX this might be too early, how do we + // know we've freed all the children? + // i suspect we should do this only if + // our kid list is empty +} + +/* _unix_free_node(): free node, deleting everything within + * + * also deletes from parent list if in it +*/ +static u3_noun +_unix_free_node(u3_pier *pir_u, u3_unod* nod_u) +{ + u3_noun can; + if ( nod_u->par_u ) { + u3_unod* don_u = nod_u->par_u->kid_u; + + if ( !don_u ) { + } + else if ( nod_u == don_u ) { + nod_u->par_u->kid_u = nod_u->par_u->kid_u->nex_u; + } + else { + for ( ; don_u->nex_u && nod_u != don_u->nex_u; don_u = don_u->nex_u ) { + } + if ( don_u->nex_u ) { + don_u->nex_u = don_u->nex_u->nex_u; + } + } + } + + if ( c3y == nod_u->dir ) { + can = u3_nul; + u3_unod* nud_u = ((u3_udir*) nod_u)->kid_u; + while ( nud_u ) { + u3_unod* nex_u = nud_u->nex_u; + can = u3kb_weld(_unix_free_node(pir_u, nud_u), can); + nud_u = nex_u; + } + _unix_free_dir((u3_udir *)nod_u); + } + else { + can = u3nc(u3nc(_unix_string_to_path(pir_u, nod_u->pax_c), u3_nul), + u3_nul); + _unix_free_file((u3_ufil *)nod_u); + } + + return can; +} + +/* _unix_free_mount_point(): free mount point + * + * this process needs to happen in a very careful order. in particular, + * we must recurse before we get to the callback, so that libuv does all + * the child directories before it does us. + * + * tread carefully +*/ +static void +_unix_free_mount_point(u3_pier *pir_u, u3_umon* mon_u) +{ + u3_unod* nod_u; + for ( nod_u = mon_u->dir_u.kid_u; nod_u; ) { + u3_unod* nex_u = nod_u->nex_u; + u3z(_unix_free_node(pir_u, nod_u)); + nod_u = nex_u; + } + + free(mon_u->dir_u.pax_c); + free(mon_u->nam_c); + free(mon_u); +} + +/* _unix_delete_mount_point(): remove mount point from list and free +*/ +static void +_unix_delete_mount_point(u3_pier *pir_u, u3_noun mon) +{ + if ( c3n == u3ud(mon) ) { + c3_assert(!"mount point must be an atom"); + u3z(mon); + return; + } + + c3_c* nam_c = u3r_string(mon); + u3_umon* mon_u; + u3_umon* tem_u; + + mon_u = pir_u->unx_u->mon_u; + if ( !mon_u ) { + u3l_log("mount point already gone: %s\r\n", nam_c); + goto _delete_mount_point_out; + } + if ( 0 == strcmp(nam_c, mon_u->nam_c) ) { + pir_u->unx_u->mon_u = mon_u->nex_u; + _unix_free_mount_point(pir_u, mon_u); + goto _delete_mount_point_out; + } + + for ( ; + mon_u->nex_u && 0 != strcmp(nam_c, mon_u->nex_u->nam_c); + mon_u = mon_u->nex_u ) + { + } + + if ( !mon_u->nex_u ) { + u3l_log("mount point already gone: %s\r\n", nam_c); + goto _delete_mount_point_out; + } + + tem_u = mon_u->nex_u; + mon_u->nex_u = mon_u->nex_u->nex_u; + _unix_free_mount_point(pir_u, tem_u); + +_delete_mount_point_out: + free(nam_c); + u3z(mon); +} + +/* _unix_commit_mount_point: commit from mount point +*/ +static void +_unix_commit_mount_point(u3_pier *pir_u, u3_noun mon) +{ + pir_u->unx_u->dyr = c3y; + u3z(mon); + u3_unix_ef_look(pir_u, c3n); + return; +} + +/* _unix_watch_file(): initialize file +*/ +static void +_unix_watch_file(u3_pier *pir_u, u3_ufil* fil_u, u3_udir* par_u, c3_c* pax_c) +{ + // initialize fil_u + + fil_u->dir = c3n; + fil_u->dry = c3n; + fil_u->pax_c = c3_malloc(1 + strlen(pax_c)); + strcpy(fil_u->pax_c, pax_c); + fil_u->par_u = par_u; + fil_u->nex_u = NULL; + fil_u->mug_w = 0; + fil_u->gum_w = 0; + + if ( par_u ) { + fil_u->nex_u = par_u->kid_u; + par_u->kid_u = (u3_unod*) fil_u; + } +} + +/* _unix_watch_dir(): initialize directory +*/ +static void +_unix_watch_dir(u3_udir* dir_u, u3_udir* par_u, c3_c* pax_c) +{ + // initialize dir_u + + dir_u->dir = c3y; + dir_u->dry = c3n; + dir_u->pax_c = c3_malloc(1 + strlen(pax_c)); + strcpy(dir_u->pax_c, pax_c); + dir_u->par_u = par_u; + dir_u->nex_u = NULL; + dir_u->kid_u = NULL; + + if ( par_u ) { + dir_u->nex_u = par_u->kid_u; + par_u->kid_u = (u3_unod*) dir_u; + } +} + +/* _unix_create_dir(): create unix directory and watch it +*/ +static void +_unix_create_dir(u3_udir* dir_u, u3_udir* par_u, u3_noun nam) +{ + c3_c* nam_c = u3r_string(nam); + c3_w nam_w = strlen(nam_c); + c3_w pax_w = strlen(par_u->pax_c); + c3_c* pax_c = c3_malloc(pax_w + 1 + nam_w + 1); + + strncpy(pax_c, par_u->pax_c, pax_w); + pax_c[pax_w] = '/'; + strncpy(pax_c + pax_w + 1, nam_c, nam_w); + pax_c[pax_w + 1 + nam_w] = '\0'; + + free(nam_c); + u3z(nam); + + _unix_mkdir(pax_c); + _unix_watch_dir(dir_u, par_u, pax_c); +} + +static u3_noun _unix_update_node(u3_pier *pir_u, u3_unod* nod_u); + +/* _unix_update_file(): update file, producing list of changes + * + * when scanning through files, if dry, do nothing. otherwise, mark as + * dry, then check if file exists. if not, remove self from node list + * and add path plus sig to %into event. otherwise, read the file and + * get a mug checksum. if same as mug_w, move on. otherwise, overwrite + * mug_w with new mug and add path plus data to %into event. +*/ +static u3_noun +_unix_update_file(u3_pier *pir_u, u3_ufil* fil_u) +{ + c3_assert( c3n == fil_u->dir ); + + if ( c3y == fil_u->dry ) { + return u3_nul; + } + + fil_u->dry = c3n; + + struct stat buf_u; + c3_i fid_i = open(fil_u->pax_c, O_RDONLY, 0644); + c3_ws len_ws, red_ws; + c3_y* dat_y; + + if ( fid_i < 0 || fstat(fid_i, &buf_u) < 0 ) { + if ( ENOENT == errno ) { + return u3nc(u3nc(_unix_string_to_path(pir_u, fil_u->pax_c), u3_nul), u3_nul); + } + else { + u3l_log("error opening file %s: %s\r\n", + fil_u->pax_c, strerror(errno)); + return u3_nul; + } + } + + len_ws = buf_u.st_size; + dat_y = c3_malloc(len_ws); + + red_ws = read(fid_i, dat_y, len_ws); + + if ( close(fid_i) < 0 ) { + u3l_log("error closing file %s: %s\r\n", + fil_u->pax_c, strerror(errno)); + } + + if ( len_ws != red_ws ) { + if ( red_ws < 0 ) { + u3l_log("error reading file %s: %s\r\n", + fil_u->pax_c, strerror(errno)); + } + else { + u3l_log("wrong # of bytes read in file %s: %d %d\r\n", + fil_u->pax_c, len_ws, red_ws); + } + free(dat_y); + return u3_nul; + } + else { + c3_w mug_w = u3r_mug_bytes(dat_y, len_ws); + if ( mug_w == fil_u->mug_w ) { + free(dat_y); + return u3_nul; + } + else if ( mug_w == fil_u->gum_w ) { + fil_u->mug_w = mug_w; + free(dat_y); + return u3_nul; + } + else { + fil_u->mug_w = mug_w; + + u3_noun pax = _unix_string_to_path(pir_u, fil_u->pax_c); + u3_noun mim = u3nt(c3__text, u3i_string("plain"), u3_nul); + u3_noun dat = u3nt(mim, len_ws, u3i_bytes(len_ws, dat_y)); + + free(dat_y); + return u3nc(u3nt(pax, u3_nul, dat), u3_nul); + } + } +} + +/* _unix_update_dir(): update directory, producing list of changes + * + * when changing this, consider whether to also change + * _unix_initial_update_dir() +*/ +static u3_noun +_unix_update_dir(u3_pier *pir_u, u3_udir* dir_u) +{ + u3_noun can = u3_nul; + + c3_assert( c3y == dir_u->dir ); + + if ( c3y == dir_u->dry ) { + return u3_nul; + } + + dir_u->dry = c3n; + + // Check that old nodes are still there + + u3_unod* nod_u = dir_u->kid_u; + + if ( nod_u ) { + while ( nod_u ) { + if ( c3y == nod_u->dry ) { + nod_u = nod_u->nex_u; + } + else { + if ( c3y == nod_u->dir ) { + DIR* red_u = opendir(nod_u->pax_c); + if ( 0 == red_u ) { + u3_unod* nex_u = nod_u->nex_u; + can = u3kb_weld(_unix_free_node(pir_u, nod_u), can); + nod_u = nex_u; + } + else { + closedir(red_u); + nod_u = nod_u->nex_u; + } + } + else { + struct stat buf_u; + c3_i fid_i = open(nod_u->pax_c, O_RDONLY, 0644); + + if ( (fid_i < 0) || (fstat(fid_i, &buf_u) < 0) ) { + if ( ENOENT != errno ) { + u3l_log("_unix_update_dir: error opening file %s: %s\r\n", + nod_u->pax_c, strerror(errno)); + } + + u3_unod* nex_u = nod_u->nex_u; + can = u3kb_weld(_unix_free_node(pir_u, nod_u), can); + nod_u = nex_u; + } + else { + if ( close(fid_i) < 0 ) { + u3l_log("_unix_update_dir: error closing file %s: %s\r\n", + nod_u->pax_c, strerror(errno)); + } + + nod_u = nod_u->nex_u; + } + } + } + } + } + + // Check for new nodes + + DIR* rid_u = opendir(dir_u->pax_c); + if ( !rid_u ) { + u3l_log("error opening directory %s: %s\r\n", + dir_u->pax_c, strerror(errno)); + c3_assert(0); + } + + while ( 1 ) { + struct dirent ent_u; + struct dirent* out_u; + c3_w err_w; + + + if ( (err_w = u3_readdir_r(rid_u, &ent_u, &out_u)) != 0 ) { + u3l_log("error loading directory %s: %s\r\n", + dir_u->pax_c, strerror(err_w)); + c3_assert(0); + } + else if ( !out_u ) { + break; + } + else if ( '.' == out_u->d_name[0] ) { + continue; + } + else { + c3_c* pax_c = _unix_down(dir_u->pax_c, out_u->d_name); + + struct stat buf_u; + + if ( 0 != stat(pax_c, &buf_u) ) { + u3l_log("can't stat %s: %s\r\n", pax_c, strerror(errno)); + free(pax_c); + continue; + } + else { + u3_unod* nod_u; + for ( nod_u = dir_u->kid_u; nod_u; nod_u = nod_u->nex_u ) { + if ( 0 == strcmp(pax_c, nod_u->pax_c) ) { + if ( S_ISDIR(buf_u.st_mode) ) { + if ( c3n == nod_u->dir ) { + u3l_log("not a directory: %s\r\n", nod_u->pax_c); + c3_assert(0); + } + } + else { + if ( c3y == nod_u->dir ) { + u3l_log("not a file: %s\r\n", nod_u->pax_c); + c3_assert(0); + } + } + break; + } + } + + if ( !nod_u ) { + if ( !S_ISDIR(buf_u.st_mode) ) { + if ( !strchr(out_u->d_name,'.') + || '~' == out_u->d_name[strlen(out_u->d_name) - 1] + || ('#' == out_u->d_name[0] && + '#' == out_u->d_name[strlen(out_u->d_name) - 1]) + ) { + free(pax_c); + continue; + } + + u3_ufil* fil_u = c3_malloc(sizeof(u3_ufil)); + _unix_watch_file(pir_u, fil_u, dir_u, pax_c); + } + else { + u3_udir* dis_u = c3_malloc(sizeof(u3_udir)); + _unix_watch_dir(dis_u, dir_u, pax_c); + can = u3kb_weld(_unix_update_dir(pir_u, dis_u), can); // XXX unnecessary? + } + } + } + + free(pax_c); + } + } + + if ( closedir(rid_u) < 0 ) { + u3l_log("error closing directory %s: %s\r\n", + dir_u->pax_c, strerror(errno)); + } + + if ( !dir_u->kid_u ) { + return u3kb_weld(_unix_free_node(pir_u, (u3_unod*) dir_u), can); + } + + // get change list + + for ( nod_u = dir_u->kid_u; nod_u; nod_u = nod_u->nex_u ) { + can = u3kb_weld(_unix_update_node(pir_u, nod_u), can); + } + + return can; +} + +/* _unix_update_node(): update node, producing list of changes +*/ +static u3_noun +_unix_update_node(u3_pier *pir_u, u3_unod* nod_u) +{ + if ( c3y == nod_u->dir ) { + return _unix_update_dir(pir_u, (void*)nod_u); + } + else { + return _unix_update_file(pir_u, (void*)nod_u); + } +} + +/* _unix_update_mount(): update mount point +*/ +static void +_unix_update_mount(u3_pier *pir_u, u3_umon* mon_u, u3_noun all) +{ + if ( c3n == mon_u->dir_u.dry ) { + u3_noun can = u3_nul; + u3_unod* nod_u; + for ( nod_u = mon_u->dir_u.kid_u; nod_u; nod_u = nod_u->nex_u ) { + can = u3kb_weld(_unix_update_node(pir_u, nod_u), can); + } + + u3_pier_work(pir_u, + u3nq(u3_blip, c3__sync, u3k(u3A->sen), u3_nul), + u3nq(c3__into, u3i_string(mon_u->nam_c), all, can)); + } +} + +/* _unix_initial_update_file(): read file, but don't watch +** XX deduplicate with _unix_update_file() +*/ +static u3_noun +_unix_initial_update_file(c3_c* pax_c, c3_c* bas_c) +{ + struct stat buf_u; + c3_i fid_i = open(pax_c, O_RDONLY, 0644); + c3_ws len_ws, red_ws; + c3_y* dat_y; + + if ( fid_i < 0 || fstat(fid_i, &buf_u) < 0 ) { + if ( ENOENT == errno ) { + return u3_nul; + } + else { + u3l_log("error opening initial file %s: %s\r\n", + pax_c, strerror(errno)); + return u3_nul; + } + } + + len_ws = buf_u.st_size; + dat_y = c3_malloc(len_ws); + + red_ws = read(fid_i, dat_y, len_ws); + + if ( close(fid_i) < 0 ) { + u3l_log("error closing initial file %s: %s\r\n", + pax_c, strerror(errno)); + } + + if ( len_ws != red_ws ) { + if ( red_ws < 0 ) { + u3l_log("error reading initial file %s: %s\r\n", + pax_c, strerror(errno)); + } + else { + u3l_log("wrong # of bytes read in initial file %s: %d %d\r\n", + pax_c, len_ws, red_ws); + } + free(dat_y); + return u3_nul; + } + else { + u3_noun pax = _unix_string_to_path_helper(pax_c + + strlen(bas_c) + + 1); /* XX slightly less VERY BAD than before*/ + u3_noun mim = u3nt(c3__text, u3i_string("plain"), u3_nul); + u3_noun dat = u3nt(mim, len_ws, u3i_bytes(len_ws, dat_y)); + + free(dat_y); + return u3nc(u3nt(pax, u3_nul, dat), u3_nul); + } +} + +/* _unix_initial_update_dir(): read directory, but don't watch +** XX deduplicate with _unix_update_dir() +*/ +static u3_noun +_unix_initial_update_dir(c3_c* pax_c, c3_c* bas_c) +{ + u3_noun can = u3_nul; + + DIR* rid_u = opendir(pax_c); + if ( !rid_u ) { + u3l_log("error opening initial directory: %s: %s\r\n", + pax_c, strerror(errno)); + return u3_nul; + } + + while ( 1 ) { + struct dirent ent_u; + struct dirent* out_u; + c3_w err_w; + + if ( 0 != (err_w = u3_readdir_r(rid_u, &ent_u, &out_u)) ) { + u3l_log("error loading initial directory %s: %s\r\n", + pax_c, strerror(errno)); + + c3_assert(0); + } + else if ( !out_u ) { + break; + } + else if ( '.' == out_u->d_name[0] ) { + continue; + } + else { + c3_c* pox_c = _unix_down(pax_c, out_u->d_name); + + struct stat buf_u; + + if ( 0 != stat(pox_c, &buf_u) ) { + u3l_log("initial can't stat %s: %s\r\n", + pox_c, strerror(errno)); + free(pox_c); + continue; + } + else { + if ( S_ISDIR(buf_u.st_mode) ) { + can = u3kb_weld(_unix_initial_update_dir(pox_c, bas_c), can); + } + else { + can = u3kb_weld(_unix_initial_update_file(pox_c, bas_c), can); + } + free(pox_c); + } + } + } + + if ( closedir(rid_u) < 0 ) { + u3l_log("error closing initial directory %s: %s\r\n", + pax_c, strerror(errno)); + } + + return can; +} + +/* u3_unix_initial_into_card(): create initial filesystem sync card. +*/ +u3_noun +u3_unix_initial_into_card(c3_c* arv_c) +{ + u3_noun can = _unix_initial_update_dir(arv_c, arv_c); + + return u3nc(u3nt(u3_blip, c3__sync, u3_nul), + u3nq(c3__into, u3_nul, c3y, can)); +} + +/* _unix_sync_file(): sync file to unix +*/ +static void +_unix_sync_file(u3_pier *pir_u, u3_udir* par_u, u3_noun nam, u3_noun ext, u3_noun mim) +{ + c3_assert( par_u ); + c3_assert( c3y == par_u->dir ); + + // form file path + + c3_c* nam_c = u3r_string(nam); + c3_c* ext_c = u3r_string(ext); + c3_w par_w = strlen(par_u->pax_c); + c3_w nam_w = strlen(nam_c); + c3_w ext_w = strlen(ext_c); + c3_c* pax_c = c3_malloc(par_w + 1 + nam_w + 1 + ext_w + 1); + + strncpy(pax_c, par_u->pax_c, par_w); + pax_c[par_w] = '/'; + strncpy(pax_c + par_w + 1, nam_c, nam_w); + pax_c[par_w + 1 + nam_w] = '.'; + strncpy(pax_c + par_w + 1 + nam_w + 1, ext_c, ext_w); + pax_c[par_w + 1 + nam_w + 1 + ext_w] = '\0'; + + free(nam_c); free(ext_c); + u3z(nam); u3z(ext); + + // check whether we already know about this file + + u3_unod* nod_u; + for ( nod_u = par_u->kid_u; + ( nod_u && + ( c3y == nod_u->dir || + 0 != strcmp(nod_u->pax_c, pax_c) ) ); + nod_u = nod_u->nex_u ) + { } + + // apply change + + if ( u3_nul == mim ) { + if ( nod_u ) { + u3z(_unix_free_node(pir_u, nod_u)); + } + } + else { + + if ( !nod_u ) { + c3_w gum_w = _unix_write_file_hard(pax_c, u3k(u3t(mim))); + u3_ufil* fil_u = c3_malloc(sizeof(u3_ufil)); + _unix_watch_file(pir_u, fil_u, par_u, pax_c); + fil_u->gum_w = gum_w; + goto _unix_sync_file_out; + } + else { + _unix_write_file_soft((u3_ufil*) nod_u, u3k(u3t(mim))); + } + } + + free(pax_c); + +_unix_sync_file_out: + u3z(mim); +} + +/* _unix_sync_change(): sync single change to unix +*/ +static void +_unix_sync_change(u3_pier *pir_u, u3_udir* dir_u, u3_noun pax, u3_noun mim) +{ + c3_assert( c3y == dir_u->dir ); + + if ( c3n == u3du(pax) ) { + if ( u3_nul == pax ) { + u3l_log("can't sync out file as top-level, strange\r\n"); + } + else { + u3l_log("sync out: bad path\r\n"); + } + u3z(pax); u3z(mim); + return; + } + else if ( c3n == u3du(u3t(pax)) ) { + u3l_log("can't sync out file as top-level, strangely\r\n"); + u3z(pax); u3z(mim); + } + else { + u3_noun i_pax = u3h(pax); + u3_noun t_pax = u3t(pax); + u3_noun it_pax = u3h(t_pax); + u3_noun tt_pax = u3t(t_pax); + + if ( u3_nul == tt_pax ) { + _unix_sync_file(pir_u, dir_u, u3k(i_pax), u3k(it_pax), mim); + } + else { + c3_c* nam_c = u3r_string(i_pax); + c3_w pax_w = strlen(dir_u->pax_c); + u3_unod* nod_u; + + for ( nod_u = dir_u->kid_u; + ( nod_u && + ( c3n == nod_u->dir || + 0 != strcmp(nod_u->pax_c + pax_w + 1, nam_c) ) ); + nod_u = nod_u->nex_u ) + { } + + if ( !nod_u ) { + nod_u = c3_malloc(sizeof(u3_udir)); + _unix_create_dir((u3_udir*) nod_u, dir_u, u3k(i_pax)); + } + + if ( c3n == nod_u->dir ) { + u3l_log("weird, we got a file when we weren't expecting to\r\n"); + c3_assert(0); + } + + _unix_sync_change(pir_u, (u3_udir*) nod_u, u3k(t_pax), mim); + } + } + u3z(pax); +} + +/* _unix_sync_ergo(): sync list of changes to unix +*/ +static void +_unix_sync_ergo(u3_pier *pir_u, u3_umon* mon_u, u3_noun can) +{ + u3_noun nac = can; + u3_noun nam = u3i_string(mon_u->nam_c); + + while ( u3_nul != nac) { + _unix_sync_change(pir_u, &mon_u->dir_u, + u3nc(u3k(nam), u3k(u3h(u3h(nac)))), + u3k(u3t(u3h(nac)))); + nac = u3t(nac); + } + + u3z(nam); + u3z(can); +} + +/* u3_unix_ef_dirk(): commit mount point +*/ +void +u3_unix_ef_dirk(u3_pier *pir_u, u3_noun mon) +{ + _unix_commit_mount_point(pir_u, mon); +} + +/* u3_unix_ef_ergo(): update filesystem from urbit +*/ +void +u3_unix_ef_ergo(u3_pier *pir_u, u3_noun mon, u3_noun can) +{ + u3_umon* mon_u = _unix_get_mount_point(pir_u, mon); + + _unix_sync_ergo(pir_u, mon_u, can); +} + +/* u3_unix_ef_ogre(): delete mount point +*/ +void +u3_unix_ef_ogre(u3_pier *pir_u, u3_noun mon) +{ + _unix_delete_mount_point(pir_u, mon); +} + +/* u3_unix_ef_hill(): enumerate mount points +*/ +void +u3_unix_ef_hill(u3_pier *pir_u, u3_noun hil) +{ + u3_noun mon; + for ( mon = hil; c3y == u3du(mon); mon = u3t(mon) ) { + u3_umon* mon_u = _unix_get_mount_point(pir_u, u3k(u3h(mon))); + _unix_scan_mount_point(pir_u, mon_u); + } + u3z(hil); +} + +/* u3_unix_io_init(): initialize unix sync. +*/ +void +u3_unix_io_init(u3_pier *pir_u) +{ + u3_unix* unx_u = pir_u->unx_u; + + unx_u->mon_u = NULL; + + unx_u->alm = c3n; + unx_u->dyr = c3n; +} + +/* u3_unix_acquire(): acquire a lockfile, killing anything that holds it. +*/ +static void +u3_unix_acquire(c3_c* pax_c) +{ + c3_c* paf_c = _unix_down(pax_c, ".vere.lock"); + c3_w pid_w; + FILE* loq_u; + + if ( NULL != (loq_u = fopen(paf_c, "r")) ) { + if ( 1 != fscanf(loq_u, "%" SCNu32, &pid_w) ) { + u3l_log("lockfile %s is corrupt!\n", paf_c); + kill(getpid(), SIGTERM); + sleep(1); c3_assert(0); + } + else if (pid_w != getpid()) { + c3_w i_w; + + if ( -1 != kill(pid_w, SIGTERM) ) { + u3l_log("unix: stopping process %d, live in %s...\n", + pid_w, pax_c); + + for ( i_w = 0; i_w < 16; i_w++ ) { + sleep(1); + if ( -1 == kill(pid_w, SIGTERM) ) { + break; + } + } + if ( 16 == i_w ) { + for ( i_w = 0; i_w < 16; i_w++ ) { + if ( -1 == kill(pid_w, SIGKILL) ) { + break; + } + sleep(1); + } + } + if ( 16 == i_w ) { + u3l_log("process %d seems unkillable!\n", pid_w); + c3_assert(0); + } + u3l_log("unix: stopped old process %u\n", pid_w); + } + } + fclose(loq_u); + unlink(paf_c); + } + + loq_u = fopen(paf_c, "w"); + fprintf(loq_u, "%u\n", getpid()); + + { + c3_i fid_i = fileno(loq_u); +#if defined(U3_OS_linux) + fdatasync(fid_i); +#elif defined(U3_OS_osx) + fcntl(fid_i, F_FULLFSYNC); +#elif defined(U3_OS_bsd) + fsync(fid_i); +#else +# error "port: datasync" +#endif + } + fclose(loq_u); + free(paf_c); +} + +/* u3_unix_release(): release a lockfile. +*/ +static void +u3_unix_release(c3_c* pax_c) +{ + c3_c* paf_c = _unix_down(pax_c, ".vere.lock"); + + unlink(paf_c); + free(paf_c); +} + +/* u3_unix_ef_bake(): initial effects for new process. +*/ +void +u3_unix_ef_bake(u3_pier *pir_u) +{ + u3_pier_work(pir_u, + u3nt(u3_blip, c3__boat, u3_nul), + u3nc(c3__boat, u3_nul)); +} + +/* u3_unix_ef_look(): update the root. +*/ +void +u3_unix_ef_look(u3_pier *pir_u, u3_noun all) +{ + if ( c3y == pir_u->unx_u->dyr ) { + pir_u->unx_u->dyr = c3n; + u3_umon* mon_u; + + for ( mon_u = pir_u->unx_u->mon_u; mon_u; mon_u = mon_u->nex_u ) { + _unix_update_mount(pir_u, mon_u, all); + } + } +} + +/* u3_unix_io_talk(): start listening for fs events. +*/ +void +u3_unix_io_talk(u3_pier *pir_u) +{ + u3_unix_acquire(pir_u->pax_c); +} + +/* u3_unix_io_exit(): terminate unix I/O. +*/ +void +u3_unix_io_exit(u3_pier *pir_u) +{ + u3_unix_release(pir_u->pax_c); +} diff --git a/pkg/hs/vere/notes/c/walk.c b/pkg/hs/vere/notes/c/walk.c new file mode 100644 index 000000000..e3af728b2 --- /dev/null +++ b/pkg/hs/vere/notes/c/walk.c @@ -0,0 +1,334 @@ +/* vere/walk.c +** +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include "vere/vere.h" + + /* |% + ** ++ arch :: fs node + ** $% [& p=@uvI q=*] :: file, hash/data + ** [| p=(map ,@ta arch)] :: directory + ** == :: + ** -- + */ + +#if 0 +static u3_noun +_walk_ok(u3_noun nod) +{ + u3_noun don = u3n_mung(u3k(u2A->toy.arch), u3k(nod)); + + if ( c3n == u3_sing(nod, don) ) { + c3_assert(0); + } + u3z(don); + return nod; +} +#endif + +/* u3_walk_safe(): load file or 0. +*/ +u3_noun +u3_walk_safe(c3_c* pas_c) +{ + struct stat buf_b; + c3_i fid_i = open(pas_c, O_RDONLY, 0644); + c3_w fln_w, red_w; + c3_y* pad_y; + + if ( (fid_i < 0) || (fstat(fid_i, &buf_b) < 0) ) { + // u3l_log("%s: %s\n", pas_c, strerror(errno)); + return 0; + } + fln_w = buf_b.st_size; + pad_y = c3_malloc(buf_b.st_size); + + red_w = read(fid_i, pad_y, fln_w); + close(fid_i); + + if ( fln_w != red_w ) { + free(pad_y); + return 0; + } + else { + u3_noun pad = u3i_bytes(fln_w, (c3_y *)pad_y); + free(pad_y); + + return pad; + } +} + +/* u3_walk_load(): load file or bail. +*/ +u3_noun +u3_walk_load(c3_c* pas_c) +{ + struct stat buf_b; + c3_i fid_i = open(pas_c, O_RDONLY, 0644); + c3_w fln_w, red_w; + c3_y* pad_y; + + if ( (fid_i < 0) || (fstat(fid_i, &buf_b) < 0) ) { + u3l_log("%s: %s\n", pas_c, strerror(errno)); + return u3m_bail(c3__fail); + } + fln_w = buf_b.st_size; + pad_y = c3_malloc(buf_b.st_size); + + red_w = read(fid_i, pad_y, fln_w); + close(fid_i); + + if ( fln_w != red_w ) { + free(pad_y); + return u3m_bail(c3__fail); + } + else { + u3_noun pad = u3i_bytes(fln_w, (c3_y *)pad_y); + free(pad_y); + + return pad; + } +} + +/* _walk_mkdirp(): recursively make directories in pax at bas_c (RETAIN) +*/ +static void +_walk_mkdirp(c3_c* bas_c, u3_noun pax) +{ + c3_c* pax_c; + c3_y* waq_y; + c3_w pax_w, fas_w, len_w; + + if ( u3_nul == pax ) { + return; + } + + pax_w = u3r_met(3, u3h(pax)); + fas_w = strlen(bas_c); + len_w = 1 + fas_w + pax_w; + + pax_c = c3_malloc(1 + len_w); + strncpy(pax_c, bas_c, len_w); + pax_c[fas_w] = '/'; + waq_y = (void*)(1 + pax_c + fas_w); + u3r_bytes(0, pax_w, waq_y, u3h(pax)); + pax_c[len_w] = '\0'; + + if ( 0 != mkdir(pax_c, 0755) && EEXIST != errno ) { + u3l_log("error mkdiring %s: %s\n", pax_c, strerror(errno)); + u3m_bail(c3__fail); + } + + _walk_mkdirp(pax_c, u3t(pax)); + free(pax_c); +} + +/* u3_walk_save(): save file or bail. +*/ +void +u3_walk_save(c3_c* pas_c, u3_noun tim, u3_atom pad, c3_c* bas_c, u3_noun pax) +{ + c3_i fid_i = open(pas_c, O_WRONLY | O_CREAT | O_TRUNC, 0666); + c3_w fln_w, rit_w; + c3_y* pad_y; + + if ( fid_i < 0 ) { + if ( ENOENT == errno && u3_nul != pax ) { + _walk_mkdirp(bas_c, pax); + return u3_walk_save(pas_c, tim, pad, 0, u3_nul); + } + + u3l_log("%s: %s\n", pas_c, strerror(errno)); + u3m_bail(c3__fail); + } + + fln_w = u3r_met(3, pad); + pad_y = c3_malloc(fln_w); + u3r_bytes(0, fln_w, pad_y, pad); + u3z(pad); + u3z(pax); + + rit_w = write(fid_i, pad_y, fln_w); + close(fid_i); + free(pad_y); + + if ( rit_w != fln_w ) { + u3l_log("%s: %s\n", pas_c, strerror(errno)); + u3m_bail(c3__fail); + } + + if ( 0 != tim ) { + struct timeval tim_tv[2]; + + u3_time_out_tv(&tim_tv[0], u3k(tim)); + u3_time_out_tv(&tim_tv[1], tim); + + utimes(pas_c, tim_tv); + } +} + +/* _walk_in(): inner loop of _walk(), producing map. +*/ +static u3_noun +_walk_in(const c3_c* dir_c, c3_w len_w) +{ + DIR* dir_d = opendir(dir_c); + u3_noun map = u3_nul; + + if ( !dir_d ) { + return u3_nul; + } + else while ( 1 ) { + struct dirent ent_n; + struct dirent* out_n; + + if ( u3_readdir_r(dir_d, &ent_n, &out_n) != 0 ) { + u3l_log("%s: %s\n", dir_c, strerror(errno)); + break; + } + else if ( !out_n ) { + break; + } + else if ( !strcmp(out_n->d_name, ".") || + !strcmp(out_n->d_name, "..") || + ('~' == out_n->d_name[0]) || + ('.' == out_n->d_name[0]) ) // XX restricts some spans + { + continue; + } + else { + c3_c* fil_c = out_n->d_name; + c3_w lef_w = len_w + 1 + strlen(fil_c); + c3_c* pat_c = c3_malloc(lef_w + 1); + struct stat buf_b; + + strncpy(pat_c, dir_c, lef_w); + pat_c[len_w] = '/'; + strncpy(pat_c + len_w + 1, fil_c, lef_w); + pat_c[lef_w] = '\0'; + + if ( 0 != stat(pat_c, &buf_b) ) { + free(pat_c); + } else { + u3_noun tim = c3_stat_mtime(&buf_b); + + if ( !S_ISDIR(buf_b.st_mode) ) { + c3_c* dot_c = strrchr(fil_c, '.'); + c3_c* nam_c = strdup(fil_c); + c3_c* ext_c = strdup(dot_c + 1); + + nam_c[dot_c - fil_c] = 0; + { + u3_noun nam = u3i_string(nam_c); + u3_noun ext = u3i_string(ext_c); + u3_noun get = u3kdb_get(u3k(map), u3k(nam)); + u3_noun dat = u3_walk_load(pat_c); + u3_noun hax; + + if ( !strcmp("noun", ext_c) ) { + dat = u3ke_cue(dat); + } + hax = u3do("sham", u3k(dat)); + if ( u3_none == get ) { get = u3_nul; } + + get = u3kdb_put(get, ext, u3nt(c3y, hax, dat)); + map = u3kdb_put(map, nam, u3nc(c3n, get)); + } + free(nam_c); + free(ext_c); + } + else { + u3_noun dir = _walk_in(pat_c, lef_w); + + if ( u3_nul != dir ) { + map = u3kdb_put + (map, u3i_string(fil_c), u3nc(c3n, dir)); + } + else u3z(tim); + } + free(pat_c); + } + } + } + closedir(dir_d); + return map; +} + +/* u3_walk(): traverse `dir_c` to produce an arch, updating `old`. +*/ +u3_noun +u3_walk(const c3_c* dir_c, u3_noun old) +{ + // XX - obviously, cheaper to update old data. + u3z(old); + { + struct stat buf_b; + + if ( 0 != stat(dir_c, &buf_b) ) { + u3l_log("can't stat %s\n", dir_c); + // return u3m_bail(c3__fail); + c3_assert(0); + } + else { + return u3nc(c3n, + _walk_in(dir_c, strlen(dir_c))); + } + } +} + +/* u3_path(): C unix path in computer for file or directory. +*/ +c3_c* +u3_path(c3_o fyl, u3_noun pax) +{ + c3_w len_w; + c3_c *pas_c; + + // measure + // + len_w = strlen(u3_Local); + { + u3_noun wiz = pax; + + while ( u3_nul != wiz ) { + len_w += (1 + u3r_met(3, u3h(wiz))); + wiz = u3t(wiz); + } + } + + // cut + // + pas_c = c3_malloc(len_w + 1); + strncpy(pas_c, u3_Local, len_w); + pas_c[len_w] = '\0'; + { + u3_noun wiz = pax; + c3_c* waq_c = (pas_c + strlen(pas_c)); + + while ( u3_nul != wiz ) { + c3_w tis_w = u3r_met(3, u3h(wiz)); + + if ( (c3y == fyl) && (u3_nul == u3t(wiz)) ) { + *waq_c++ = '.'; + } else *waq_c++ = '/'; + + u3r_bytes(0, tis_w, (c3_y*)waq_c, u3h(wiz)); + waq_c += tis_w; + + wiz = u3t(wiz); + } + *waq_c = 0; + } + u3z(pax); + return pas_c; +} diff --git a/pkg/hs/vere/notes/c/worker.c b/pkg/hs/vere/notes/c/worker.c new file mode 100644 index 000000000..1a37ca775 --- /dev/null +++ b/pkg/hs/vere/notes/c/worker.c @@ -0,0 +1,947 @@ +/* worker/main.c +** +** the main loop of a worker process. +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "all.h" +#include + + typedef struct _u3_worker { + c3_w len_w; // boot sequence length + u3_noun roe; // lifecycle formulas + c3_d sen_d; // last event requested + c3_d dun_d; // last event processed + c3_l mug_l; // hash of state + c3_d key_d[4]; // disk key + u3_moat inn_u; // message input + u3_mojo out_u; // message output + c3_c* dir_c; // execution directory (pier) + } u3_worker; + static u3_worker u3V; + +/* +:: worker to daemon protocol +:: +|% +:: +plea: from worker to daemon +:: ++$ plea + $% :: status on startup + :: + $: %play + $= p + :: ~ if no snapshot + :: + %- unit + :: p: event number expected + :: q: mug of kernel + :: r: identity, fake flag + :: + [p=@ q=@ r=[our=@p fak=?]] + == + :: event executed unchanged (in response to %work) + :: + $: %done + :: p: event number + :: q: mug of kernel + :: r: effects + :: + [p=@ q=@ r=(list ovum)] + == + :: replace event and retry (in response to %work) + :: + $: %work + :: p: event number + :: q: mug of kernel + :: r: replacement event (at date) + :: + [p=@ q=@ r=(pair date ovum)] + == + :: sends a line to stderr while computing event + :: + $: %stdr + :: p: event number + :: q: output cord + :: + [p=@ q=cord] + == + :: send slog hint while computing event + :: + $: %slog + :: p: event number + :: q: priority + :: r: output tank + :: + [p=@ q=@ r=tank] + == == +:: +writ: from daemon to worker +:: ++$ writ + $% :: prepare to boot + :: + :: p: identity + :: q: fake? + :: r: number of boot formulas + :: + [%boot p=@p q=? r=@] + :: exit immediately + :: + :: p: exit code + :: + [%exit p=@] + :: save snapshot to disk + :: + :: p: event number + :: + [%save p=@] + :: execute event + :: + $: %work + :: p: event number + :: q: a jammed noun [mug [date ovum]] + :: + [p=@ q=@] + == == +-- +*/ + +/* _worker_space(): print n spaces. +*/ +void _worker_space(FILE* fil_u, c3_w n) +{ + for (; n > 0; n--) + (fprintf(fil_u," ")); +} + +/* _worker_print_memory(): print memory amount. +** +** Helper for _worker_prof(), just an un-captioned u3a_print_memory(). +*/ +void +_worker_print_memory(FILE* fil_u, c3_w wor_w) +{ + c3_w byt_w = (wor_w * 4); + c3_w gib_w = (byt_w / 1000000000); + c3_w mib_w = (byt_w % 1000000000) / 1000000; + c3_w kib_w = (byt_w % 1000000) / 1000; + c3_w bib_w = (byt_w % 1000); + + if ( gib_w ) { + (fprintf(fil_u, "GB/%d.%03d.%03d.%03d\r\n", + gib_w, mib_w, kib_w, bib_w)); + } + else if ( mib_w ) { + (fprintf(fil_u, "MB/%d.%03d.%03d\r\n", mib_w, kib_w, bib_w)); + } + else if ( kib_w ) { + (fprintf(fil_u, "KB/%d.%03d\r\n", kib_w, bib_w)); + } + else { + (fprintf(fil_u, "B/%d\r\n", bib_w)); + } +} + +/* _worker_prof(): print memory profile. RETAIN. +*/ +c3_w +_worker_prof(FILE* fil_u, c3_w den, u3_noun mas) +{ + c3_w tot_w = 0; + u3_noun h_mas, t_mas; + + if ( c3n == u3r_cell(mas, &h_mas, &t_mas) ) { + _worker_space(fil_u, den); + fprintf(fil_u, "mistyped mass\r\n"); + return tot_w; + } + else if ( _(u3du(h_mas)) ) { + _worker_space(fil_u, den); + fprintf(fil_u, "mistyped mass head\r\n"); + { + c3_c* lab_c = u3m_pretty(h_mas); + fprintf(fil_u, "h_mas: %s", lab_c); + free(lab_c); + } + return tot_w; + } + else { + _worker_space(fil_u, den); + + { + c3_c* lab_c = u3m_pretty(h_mas); + fprintf(fil_u, "%s: ", lab_c); + free(lab_c); + } + + u3_noun it_mas, tt_mas; + + if ( c3n == u3r_cell(t_mas, &it_mas, &tt_mas) ) { + fprintf(fil_u, "mistyped mass tail\r\n"); + return tot_w; + } + else if ( c3y == it_mas ) { + tot_w += u3a_mark_noun(tt_mas); + _worker_print_memory(fil_u, tot_w); + +#if 1 + /* The basic issue here is that tt_mas is included in .sac + * (the whole profile), so they can't both be roots in the + * normal sense. When we mark .sac later on, we want tt_mas + * to appear unmarked, but its children should be already + * marked. + */ + if ( _(u3a_is_dog(tt_mas)) ) { + u3a_box* box_u = u3a_botox(u3a_to_ptr(tt_mas)); +#ifdef U3_MEMORY_DEBUG + if ( 1 == box_u->eus_w ) { + box_u->eus_w = 0xffffffff; + } + else { + box_u->eus_w -= 1; + } +#else + if ( -1 == (c3_w)box_u->use_w ) { + box_u->use_w = 0x80000000; + } + else { + box_u->use_w += 1; + } +#endif + } +#endif + + return tot_w; + } + else if ( c3n == it_mas ) { + fprintf(fil_u, "\r\n"); + + while ( _(u3du(tt_mas)) ) { + tot_w += _worker_prof(fil_u, den+2, u3h(tt_mas)); + tt_mas = u3t(tt_mas); + } + + _worker_space(fil_u, den); + fprintf(fil_u, "--"); + _worker_print_memory(fil_u, tot_w); + + return tot_w; + + } + else { + _worker_space(fil_u, den); + fprintf(fil_u, "mistyped (strange) mass tail\r\n"); + return tot_w; + } + } +} + +/* _worker_grab(): garbage collect, checking for profiling. RETAIN. +*/ +static void +_worker_grab(u3_noun sac, u3_noun ovo, u3_noun vir) +{ + if ( u3_nul == sac) { + if ( u3C.wag_w & (u3o_debug_ram | u3o_check_corrupt) ) { + u3m_grab(sac, ovo, vir, u3_none); + } + } + else { + c3_w usr_w = 0, man_w = 0, sac_w = 0, ova_w = 0, roe_w = 0, vir_w = 0; + + FILE* fil_u; + +#ifdef U3_MEMORY_LOG + { + u3_noun wen = u3dc("scot", c3__da, u3k(u3A->now)); + c3_c* wen_c = u3r_string(wen); + + c3_c nam_c[2048]; + snprintf(nam_c, 2048, "%s/.urb/put/mass", u3P.dir_c); + + struct stat st; + if ( -1 == stat(nam_c, &st) ) { + mkdir(nam_c, 0700); + } + + c3_c man_c[2048]; + snprintf(man_c, 2048, "%s/%s.txt", nam_c, wen_c); + + fil_u = fopen(man_c, "w"); + fprintf(fil_u, "%s\r\n", wen_c); + + free(wen_c); + u3z(wen); + } +#else + { + fil_u = stderr; + } +#endif + + c3_assert( u3R == &(u3H->rod_u) ); + + fprintf(fil_u, "\r\n"); + usr_w = _worker_prof(fil_u, 0, sac); + u3a_print_memory(fil_u, "total userspace", usr_w); + + man_w = u3m_mark(fil_u); + + sac_w = u3a_mark_noun(sac); + u3a_print_memory(fil_u, "space profile", sac_w); + + ova_w = u3a_mark_noun(ovo); + u3a_print_memory(fil_u, "event", ova_w); + + roe_w = u3a_mark_noun(u3V.roe); + u3a_print_memory(fil_u, "lifecycle events", roe_w); + + vir_w = u3a_mark_noun(vir); + u3a_print_memory(fil_u, "effects", vir_w); + + u3a_print_memory(fil_u, "total marked", usr_w + man_w + sac_w + ova_w + vir_w); + + u3a_print_memory(fil_u, "sweep", u3a_sweep()); + +#ifdef U3_MEMORY_LOG + { + fclose(fil_u); + } +#endif + } +} + +/* _worker_fail(): failure stub. +*/ +static void +_worker_fail(void* vod_p, const c3_c* wut_c) +{ + u3l_log("work: fail: %s\r\n", wut_c); + exit(1); +} + +/* _worker_send(): send result back to daemon. +*/ +static void +_worker_send(u3_noun job) +{ + u3_newt_write(&u3V.out_u, u3ke_jam(job), 0); +} + +/* _worker_send_replace(): send replacement job back to daemon. +*/ +static void +_worker_send_replace(c3_d evt_d, u3_noun job) +{ + u3l_log("worker_send_replace %" PRIu64 " %s\r\n", + evt_d, + u3r_string(u3h(u3t(u3t(job))))); + + _worker_send(u3nt(c3__work, + u3i_chubs(1, &evt_d), + u3ke_jam(u3nc(u3V.mug_l, job)))); +} + +/* _worker_send_complete(): report completion. +*/ +static void +_worker_send_complete(u3_noun vir) +{ + _worker_send(u3nq(c3__done, + u3i_chubs(1, &u3V.dun_d), + u3V.mug_l, + vir)); +} + +/* _worker_send_stdr(): send stderr output +*/ +static void +_worker_send_stdr(c3_c* str_c) +{ + _worker_send(u3nt(c3__stdr, u3i_chubs(1, &u3V.sen_d), u3i_string(str_c))); +} + +/* _worker_send_slog(): send hint output (hod is [priority tank]). +*/ +static void +_worker_send_slog(u3_noun hod) +{ + _worker_send(u3nt(c3__slog, u3i_chubs(1, &u3V.sen_d), hod)); +} + +/* _worker_lame(): event failed, replace with error event. +*/ +static void +_worker_lame(c3_d evt_d, u3_noun now, u3_noun ovo, u3_noun why, u3_noun tan) +{ + u3_noun rep; + u3_noun wir, tag, cad; + + u3x_trel(ovo, &wir, &tag, &cad); + + // a deterministic error (%exit) in a network packet (%hear) + // generates a negative-acknowlegement attempt (%hole). + // + // A comment from the old implementation: + // There should be a separate path for crypto failures, + // to prevent timing attacks, but isn't right now. To deal + // with a crypto failure, just drop the packet. + // + if ( (c3__hear == tag) && (c3__exit == why) ) { + rep = u3nt(u3k(wir), c3__hole, u3k(cad)); + } + // failed event notifications (%crud) are replaced with + // an even more generic notifications, on a generic arvo wire. + // N.B this must not be allowed to fail! + // + // [%warn original-event-tag=@tas combined-trace=(list tank)] + // + else if ( c3__crud == tag ) { + u3_noun lef = u3nc(c3__leaf, u3i_tape("crude crashed!")); + u3_noun nat = u3kb_weld(u3k(u3t(cad)), u3nc(lef, u3k(tan))); + rep = u3nc(u3nt(u3_blip, c3__arvo, u3_nul), + u3nt(c3__warn, u3k(u3h(cad)), nat)); + } + // failed failure failing fails + // + else if ( c3__warn == tag ) { + _worker_fail(0, "%warn replacement event failed"); + c3_assert(0); + } + // failure notifications are sent on the same wire + // + // [%crud event-tag=@tas event-trace=(list tank)] + // + else { + // prepend failure mote to tank + // + u3_noun lef = u3nc(c3__leaf, u3kb_weld(u3i_tape("bail: "), + u3qc_rip(3, why))); + u3_noun nat = u3kb_weld(u3k(tan), u3nc(lef, u3_nul)); + rep = u3nc(u3k(wir), u3nt(c3__crud, u3k(tag), nat)); + } + + _worker_send_replace(evt_d, u3nc(now, rep)); + + u3z(ovo); u3z(why); u3z(tan); +} + +/* _worker_sure(): event succeeded, report completion. +*/ +static void +_worker_sure(u3_noun ovo, u3_noun vir, u3_noun cor) +{ + u3z(u3A->roc); + u3A->roc = cor; + u3A->ent_d = u3V.dun_d; + u3V.mug_l = u3r_mug(u3A->roc); + + u3_noun sac = u3_nul; + + // intercept |mass, observe |reset + // + { + u3_noun riv = vir; + c3_w i_w = 0; + + while ( u3_nul != riv ) { + u3_noun fec = u3t(u3h(riv)); + + // assumes a max of one %mass effect per event + // + if ( c3__mass == u3h(fec) ) { + // save a copy of the %mass data + // + sac = u3k(u3t(fec)); + // replace the %mass data with ~ + // + // For efficient transmission to daemon. + // + riv = u3kb_weld(u3qb_scag(i_w, vir), + u3nc(u3nt(u3k(u3h(u3h(riv))), c3__mass, u3_nul), + u3qb_slag(1 + i_w, vir))); + u3z(vir); + vir = riv; + break; + } + + // reclaim memory from persistent caches on |reset + // + if ( c3__vega == u3h(fec) ) { + u3m_reclaim(); + } + + riv = u3t(riv); + i_w++; + } + } + + // XX this runs on replay too + // + _worker_grab(sac, ovo, vir); + _worker_send_complete(vir); + + u3z(sac); u3z(ovo); +} + +/* _worker_work_live(): apply event. +*/ +static void +_worker_work_live(c3_d evt_d, u3_noun job) +{ + u3_noun now, ovo, gon; + u3_noun last_date; + + c3_assert(evt_d == u3V.dun_d + 1ULL); + u3V.sen_d = evt_d; + + u3x_cell(job, &now, &ovo); + + last_date = u3A->now; + u3A->now = u3k(now); + +#ifdef U3_EVENT_TIME_DEBUG + { + struct timeval b4, f2, d0; + gettimeofday(&b4, 0); + + if ( c3__belt != u3h(u3t(ovo)) ) { + c3_c* txt_c = u3r_string(u3h(u3t(ovo))); + + u3l_log("work: %s (%" PRIu64 ") live\r\n", txt_c, evt_d); + } + } +#endif + + gon = u3m_soft(0, u3v_poke, u3k(ovo)); + +#ifdef U3_EVENT_TIME_DEBUG + { + c3_c* txt_c = u3r_string(u3h(u3t(ovo))); + c3_w ms_w; + c3_w clr_w; + + gettimeofday(&f2, 0); + timersub(&f2, &b4, &d0); + ms_w = (d0.tv_sec * 1000) + (d0.tv_usec / 1000); + clr_w = ms_w > 1000 ? 1 : ms_w < 100 ? 2 : 3; // red, green, yellow + if (c3__belt != u3h(u3t(ovo)) || clr_w != 2) { + u3l_log("\x1b[3%dm%%%s (%" PRIu64 ") %4d.%02dms\x1b[0m\n", + clr_w, txt_c, evt_d, ms_w, + (int) (d0.tv_usec % 1000) / 10); + } + free(txt_c); + } +#endif + + if ( u3_blip != u3h(gon) ) { + // event rejected + // + u3V.sen_d = u3V.dun_d; + // restore previous time + // + u3_noun nex = u3A->now; + u3A->now = last_date; + + u3_noun why, tan; + u3x_cell(gon, &why, &tan); + + u3k(ovo); u3k(why); u3k(tan); + u3z(gon); u3z(job); + + _worker_lame(evt_d, nex, ovo, why, tan); + } + else { + // event accepted + // + u3V.dun_d = u3V.sen_d; + u3z(last_date); + + // vir/(list ovum) list of effects + // cor/arvo arvo core + // + u3_noun vir, cor; + u3x_trel(gon, 0, &vir, &cor); + + u3k(ovo); u3k(vir); u3k(cor); + u3z(gon); u3z(job); + + _worker_sure(ovo, vir, cor); + + // reclaim memory from persistent caches periodically + // + // XX this is a hack to work around the fact that + // the bytecode caches grow rapidly and are not + // able to be simply capped (due to internal posts). + // + if ( 0 == (evt_d % 1000ULL) ) { + u3m_reclaim(); + } + } +} + +/* _worker_work_boot(): apply initial-stage event. +*/ +static void +_worker_work_boot(c3_d evt_d, u3_noun job) +{ + // here we asset on u3V.sen_d, because u3V.dun_d isn't set until + // after u3V.sen_d == u3V.len_w (ie, after the lifecycle evaluation) + // + c3_assert(evt_d == u3V.sen_d + 1ULL); + u3V.sen_d = evt_d; + + u3V.roe = u3nc(job, u3V.roe); + + u3l_log("work: (%" PRIu64 ")| boot\r\n", evt_d); + + if ( u3V.len_w == evt_d ) { + u3_noun eve = u3kb_flop(u3V.roe); + u3V.roe = u3_nul; + + u3l_log("work: (%" PRIu64 ")| pill: %x\r\n", evt_d, u3r_mug(eve)); + + if ( c3n == u3v_boot(eve) ) { + u3l_log("work: boot failed: invalid sequence (from pill)\r\n"); + exit(1); + } + + u3V.dun_d = evt_d; + u3V.mug_l = u3r_mug(u3A->roc); + u3A->ent_d = u3V.dun_d; + + u3l_log("work: (%" PRIu64 ")| core: %x\r\n", evt_d, u3V.mug_l); + } + else { + // prior to the evaluation of the entire lifecycle sequence, + // we simply use the mug of the formula as the kernel mug + // + u3V.mug_l = u3r_mug(job); + } + + _worker_send(u3nq(c3__done, + u3i_chubs(1, &evt_d), + u3V.mug_l, + u3_nul)); +} + +/* _worker_poke_work(): apply event. +*/ +static void +_worker_poke_work(c3_d evt_d, // event number + c3_l mug_l, // mug of state + u3_noun job) // full event +{ + if ( u3C.wag_w & u3o_trace ) { + if ( u3_Host.tra_u.con_w == 0 && u3_Host.tra_u.fun_w == 0 ) { + u3t_trace_open(u3V.dir_c); + } + else if ( u3_Host.tra_u.con_w >= 100000 ) { + u3t_trace_close(); + u3t_trace_open(u3V.dir_c); + } + } + + // Require mugs to match + // + // We use mugs to enforce that %work is always performed against + // the exact kernel we expect it to be. If it isn't, we have either + // event-log corruption or non-determism on replay, or programmer error + // in normal operation. In either case, we immediately exit. + // + if ( u3V.mug_l != mug_l ) { + u3l_log("work: invalid %%work for event %" PRIu64 ".\r\n", evt_d); + u3l_log("work: computed mug is %x but event %" PRIu64 " expected %x.\r\n", + u3V.mug_l, + evt_d, + mug_l); + _worker_fail(0, "bad jar"); + return; + } + + if ( evt_d <= u3V.len_w ) { + c3_c lab_c[8]; + snprintf(lab_c, 8, "boot: %" PRIu64 "", evt_d); + + u3t_event_trace(lab_c, 'B'); + _worker_work_boot(evt_d, job); + u3t_event_trace(lab_c, 'E'); + } + else { + u3_noun wir = u3h(u3t(job)); + u3_noun cad = u3h(u3t(u3t(job))); + + c3_c lab_c[2048]; + snprintf(lab_c, 2048, "event %" PRIu64 ": [%s %s]", evt_d, + u3m_pretty_path(wir), u3m_pretty(cad)); + + u3t_event_trace(lab_c, 'B'); + _worker_work_live(evt_d, job); + u3t_event_trace(lab_c, 'E'); + } +} + +/* _worker_poke_exit(): exit on command. +*/ +static void +_worker_poke_exit(c3_w cod_w) // exit code +{ + if ( u3C.wag_w & u3o_debug_cpu ) { + u3t_damp(); + } + + exit(cod_w); +} + +/* _worker_poke_boot(): prepare to boot. +*/ +static void +_worker_poke_boot(u3_noun who, u3_noun fak, c3_w len_w) +{ + c3_assert( u3_none == u3A->our ); + c3_assert( 0 != len_w ); + + u3A->our = who; + u3A->fak = fak; + u3V.len_w = len_w; +} + +/* _worker_poke(): +*/ +void +_worker_poke(void* vod_p, u3_noun mat) +{ + u3_noun jar = u3ke_cue(mat); + + if ( c3y != u3du(jar) ) { + goto error; + } + else { + switch ( u3h(jar) ) { + default: { + goto error; + } + + case c3__boot: { + u3_noun who, fak, len; + c3_w len_w; + + if ( (c3n == u3r_qual(jar, 0, &who, &fak, &len)) || + (c3n == u3ud(who)) || + (1 < u3r_met(7, who)) || + (c3n == u3ud(fak)) || + (1 < u3r_met(0, fak)) || + (c3n == u3ud(len)) || + (1 < u3r_met(3, len)) ) + { + goto error; + } + + len_w = u3r_word(0, len); + u3k(who); + u3k(fak); + u3z(jar); + + return _worker_poke_boot(who, fak, len_w); + } + + case c3__work: { + u3_noun evt, jammed_entry, mug, job; + c3_d evt_d; + c3_l mug_l; + + if ( (c3n == u3r_trel(jar, 0, &evt, &jammed_entry)) || + (c3n == u3ud(evt)) || + (1 != u3r_met(6, evt)) ) + { + goto error; + } + + u3_noun entry = u3qe_cue(jammed_entry); + if ( (c3y != u3du(entry)) || + (c3n == u3r_cell(entry, &mug, &job)) || + (c3n == u3ud(mug)) || + (1 < u3r_met(5, mug)) ) { + goto error; + } + + evt_d = u3r_chub(0, evt); + mug_l = u3r_word(0, mug); + u3k(job); + u3z(entry); + u3z(jar); + + return _worker_poke_work(evt_d, mug_l, job); + } + + case c3__exit: { + u3_noun cod; + c3_w cod_w; + + if ( (c3n == u3r_cell(jar, 0, &cod)) || + (c3n == u3ud(cod)) || + (1 < u3r_met(3, cod)) ) + { + goto error; + } + + cod_w = u3r_word(0, cod); + u3z(jar); + + return _worker_poke_exit(cod_w); + } + + case c3__save: { + u3_noun evt; + c3_d evt_d; + + if ( (c3n == u3r_cell(jar, 0, &evt)) || + (c3n == u3ud(evt)) ) + { + goto error; + } + + evt_d = u3r_chub(0, evt); + u3z(jar); + + c3_assert( evt_d == u3V.dun_d ); + + return u3e_save(); + } + } + } + + error: { + u3z(jar); + _worker_fail(0, "bad jar"); + } +} + +/* u3_worker_boot(): send startup message to manager. +*/ +void +u3_worker_boot(void) +{ + c3_d nex_d = 1ULL; + u3_noun dat = u3_nul; + + if ( u3_none != u3A->our ) { + u3V.mug_l = u3r_mug(u3A->roc); + nex_d = u3V.dun_d + 1ULL; + dat = u3nc(u3_nul, u3nt(u3i_chubs(1, &nex_d), + u3V.mug_l, + u3nc(u3k(u3A->our), u3k(u3A->fak)))); + + // disable hashboard for fake ships + // + if ( c3y == u3A->fak ) { + u3C.wag_w |= u3o_hashless; + } + + // no boot sequence expected + // + u3V.len_w = 0; + } + + u3l_log("work: play %" PRIu64 "\r\n", nex_d); + + _worker_send(u3nc(c3__play, dat)); +} + +/* main(): main() when run as urbit-worker +*/ +c3_i +main(c3_i argc, c3_c* argv[]) +{ + uv_loop_t* lup_u = uv_default_loop(); + c3_c* dir_c = argv[1]; + c3_c* key_c = argv[2]; + c3_c* wag_c = argv[3]; + + c3_assert(4 == argc); + + memset(&u3V, 0, sizeof(u3V)); + memset(&u3_Host.tra_u, 0, sizeof(u3_Host.tra_u)); + + /* load passkey + */ + { + sscanf(key_c, "%" PRIx64 ":%" PRIx64 ":%" PRIx64 ":%" PRIx64 "", + &u3V.key_d[0], + &u3V.key_d[1], + &u3V.key_d[2], + &u3V.key_d[3]); + } + + /* load runtime config + */ + { + sscanf(wag_c, "%" SCNu32, &u3C.wag_w); + } + + /* load pier directory + */ + { + u3V.dir_c = strdup(dir_c); + } + + /* boot image + */ + { + u3V.sen_d = u3V.dun_d = u3m_boot(dir_c); + u3C.stderr_log_f = _worker_send_stdr; + u3C.slog_f = _worker_send_slog; + } + + /* configure pipe to daemon process + */ + { + c3_i err_i; + + err_i = uv_pipe_init(lup_u, &u3V.inn_u.pyp_u, 0); + c3_assert(!err_i); + uv_pipe_open(&u3V.inn_u.pyp_u, 0); + + err_i = uv_pipe_init(lup_u, &u3V.out_u.pyp_u, 0); + c3_assert(!err_i); + uv_pipe_open(&u3V.out_u.pyp_u, 1); + } + + /* set up writing + */ + u3V.out_u.bal_f = _worker_fail; + + /* start reading + */ + u3V.inn_u.vod_p = &u3V; + u3V.inn_u.pok_f = _worker_poke; + u3V.inn_u.bal_f = _worker_fail; + + u3_newt_read(&u3V.inn_u); + + /* send start request + */ + u3_worker_boot(); + + /* enter loop + */ + uv_run(lup_u, UV_RUN_DEFAULT); + return 0; +} diff --git a/pkg/hs/vere/package.yaml b/pkg/hs/vere/package.yaml index ea9f86ab7..92ba23dde 100644 --- a/pkg/hs/vere/package.yaml +++ b/pkg/hs/vere/package.yaml @@ -20,8 +20,10 @@ dependencies: - classy-prelude - stm - stm-chans + - async - lens + - largeword + - time -executables: - vere: - main: Main.hs +library: + source-dirs: . From fbf9a1b3fc5e01d37711dc7bd1df3ab232ed8759 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 8 May 2019 11:47:20 -0700 Subject: [PATCH 007/431] Urbit.Time --- pkg/hs/vere/Main.hs | 56 +++++++++++ pkg/hs/vere/{Vere => Urbit}/Behn.hs | 65 +++++------- pkg/hs/vere/Urbit/Time.hs | 149 ++++++++++++++++++++++++++++ pkg/hs/vere/package.yaml | 22 ++-- 4 files changed, 241 insertions(+), 51 deletions(-) create mode 100644 pkg/hs/vere/Main.hs rename pkg/hs/vere/{Vere => Urbit}/Behn.hs (58%) create mode 100644 pkg/hs/vere/Urbit/Time.hs diff --git a/pkg/hs/vere/Main.hs b/pkg/hs/vere/Main.hs new file mode 100644 index 000000000..80def3caa --- /dev/null +++ b/pkg/hs/vere/Main.hs @@ -0,0 +1,56 @@ +module Main where + +import Prelude +import Control.Lens + +import Data.LargeWord (Word128, LargeKey(..)) + +import qualified Urbit.Behn as Behn +import qualified Urbit.Time as Time + +-------------------------------------------------------------------------------- + +bench :: Behn.Behn -> IO (Time.Wen, Time.Wen, Time.Wen) +bench behn = do + now <- Time.now + + print (now ^. Time.wenUtcTime) + + Behn.doze behn (Just (Time.addGap now (500 ^. from Time.milliSecs))) + + wen <- Behn.wait behn + aft <- Time.now + + pure (now, wen, aft) + +main :: IO () +main = do + behn <- Behn.init + + (x1,y1,z1) <- bench behn + (x2,y2,z2) <- bench behn + (x3,y3,z3) <- bench behn + + putStrLn "----" + + print (x1 ^. Time.wenUtcTime) + print (Time.gap x1 y1 ^. Time.milliSecs) + print (y1 ^. Time.wenUtcTime) + print (Time.gap y1 z1 ^. Time.milliSecs) + print (z1 ^. Time.wenUtcTime) + + putStrLn "----" + + print (x2 ^. Time.wenUtcTime) + print (Time.gap x2 y2 ^. Time.milliSecs) + print (y2 ^. Time.wenUtcTime) + print (Time.gap y2 z2 ^. Time.milliSecs) + print (z2 ^. Time.wenUtcTime) + + putStrLn "----" + + print (x3 ^. Time.wenUtcTime) + print (Time.gap x3 y3 ^. Time.milliSecs) + print (y3 ^. Time.wenUtcTime) + print (Time.gap y3 z3 ^. Time.milliSecs) + print (z3 ^. Time.wenUtcTime) diff --git a/pkg/hs/vere/Vere/Behn.hs b/pkg/hs/vere/Urbit/Behn.hs similarity index 58% rename from pkg/hs/vere/Vere/Behn.hs rename to pkg/hs/vere/Urbit/Behn.hs index f53bd370b..b65f44209 100644 --- a/pkg/hs/vere/Vere/Behn.hs +++ b/pkg/hs/vere/Urbit/Behn.hs @@ -34,50 +34,29 @@ to return) first, and then `doze` action will wait until that finishes. -} -module Vere.Behn (Behn, init, wait, doze) where +module Urbit.Behn (Behn, init, wait, doze) where + +import Prelude hiding (init) +import Control.Lens -import Control.Concurrent -import Control.Concurrent.Async hiding (wait) -import Control.Concurrent.MVar import Data.LargeWord -import Prelude hiding (init) +import Control.Concurrent.MVar -import Data.Time.Clock.System (SystemTime(..), getSystemTime) -import Control.Lens ((&)) -import Control.Monad (void) +import Control.Concurrent.Async (Async, async, cancel, asyncThreadId) +import Control.Concurrent (threadDelay, killThread) +import Control.Monad (void) +import Data.Time.Clock.System (SystemTime(..), getSystemTime) +import Urbit.Time (Wen) +import qualified Control.Concurrent.Async as Async +import qualified Urbit.Time as Time --- Time Stuff ------------------------------------------------------------------ - -type UrbitTime = Word128 - -urNow :: IO UrbitTime -urNow = systemTimeToUrbitTime <$> getSystemTime - -{- - TODO This is wrong. - - - The high word should be `(0x8000000cce9e0d80ULL + secs)` - - The low word should be `(((usecs * 65536ULL) / 1000000ULL) << 48ULL)` --} -systemTimeToUrbitTime :: SystemTime -> UrbitTime -systemTimeToUrbitTime (MkSystemTime secs ns) = - LargeKey (fromIntegral secs) (fromIntegral ns) - --- TODO -urbitTimeToMicrosecs :: UrbitTime -> Int -urbitTimeToMicrosecs x = fromIntegral x - --- TODO Double Check this -diffTime :: UrbitTime -> UrbitTime -> UrbitTime -diffTime fst snd | fst >= snd = 0 - | otherwise = snd - fst -- Behn Stuff ------------------------------------------------------------------ data Behn = Behn - { bState :: MVar (Maybe (UrbitTime, Async ())) - , bSignal :: MVar UrbitTime + { bState :: MVar (Maybe (Wen, Async ())) + , bSignal :: MVar Wen } init :: IO Behn @@ -86,23 +65,25 @@ init = do sig <- newEmptyMVar pure (Behn st sig) -wait :: Behn -> IO UrbitTime +wait :: Behn -> IO Wen wait (Behn _ sig) = takeMVar sig -startTimerThread :: Behn -> UrbitTime -> IO (Async ()) +startTimerThread :: Behn -> Wen -> IO (Async ()) startTimerThread (Behn vSt sig) time = async $ do - now <- urNow - threadDelay (urbitTimeToMicrosecs (now `diffTime` time)) - void (swapMVar vSt Nothing >> tryPutMVar sig time) + now <- Time.now + threadDelay (Time.gap now time ^. Time.microSecs) + takeMVar vSt + void $ tryPutMVar sig time + putMVar vSt Nothing -doze :: Behn -> Maybe UrbitTime -> IO () +doze :: Behn -> Maybe Wen -> IO () doze behn@(Behn vSt sig) mNewTime = do takeMVar vSt >>= \case Nothing -> pure () Just (_,timer) -> cancel timer newSt <- mNewTime & \case - Nothing -> pure (Nothing :: Maybe (UrbitTime, Async ())) + Nothing -> pure (Nothing :: Maybe (Wen, Async ())) Just time -> do timer <- startTimerThread behn time pure (Just (time, timer)) diff --git a/pkg/hs/vere/Urbit/Time.hs b/pkg/hs/vere/Urbit/Time.hs new file mode 100644 index 000000000..d4cac0a15 --- /dev/null +++ b/pkg/hs/vere/Urbit/Time.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE NumericUnderscores, GeneralizedNewtypeDeriving #-} + +module Urbit.Time where + +import Prelude +import Control.Lens + +import Data.Coerce (coerce) +import Control.Concurrent (threadDelay) +import Control.Exception (throw, ArithException(Underflow)) +import Data.Bits (shiftL, shiftR) +import Data.LargeWord (Word128, LargeKey(..)) +import Data.Time.Clock (DiffTime, UTCTime, picosecondsToDiffTime, + diffTimeToPicoseconds) +import Data.Time.Clock.System (SystemTime(..), getSystemTime, utcToSystemTime, + systemToUTCTime) + + +-- Types ----------------------------------------------------------------------- + +newtype Gap = Gap { unGap :: Word128 } + deriving (Eq, Ord, Show) + +newtype Wen = Wen { unWen :: Word128 } + deriving (Eq, Ord, Show) + +newtype Unix = Unix { unUnix :: Word128 } + deriving (Eq, Ord, Show) + + +-- Basic Lenses ---------------------------------------------------------------- + +fractoSecs :: Iso' Gap Word128 +fractoSecs = iso unGap Gap + +sinceUrbitEpoch :: Iso' Wen Gap +sinceUrbitEpoch = iso (Gap . unWen) (Wen . unGap) + +sinceUnixEpoch :: Iso' Unix Gap +sinceUnixEpoch = iso (Gap . unUnix) (Unix . unGap) + + +-- Instances ------------------------------------------------------------------- + +instance Num Gap where + x + y = Gap (coerce x + coerce y) + x * y = Gap (coerce x * coerce y) + fromInteger = Gap . fromInteger + abs = over fractoSecs abs + signum = over fractoSecs signum + negate = over fractoSecs negate + + +-- Conversions ----------------------------------------------------------------- + +diffTime :: Iso' Gap DiffTime +diffTime = iso fromGap toGap + where + fromGap = picosecondsToDiffTime . view picoSecs + toGap = view (from picoSecs) . diffTimeToPicoseconds + +utcTime :: Iso' Unix UTCTime +utcTime = iso fromUnix toUnix + where + fromUnix = systemToUTCTime . view systemTime + toUnix = view (from systemTime) . utcToSystemTime + +wenUtcTime :: Iso' Wen UTCTime +wenUtcTime = unix . utcTime + +systemTime :: Iso' Unix SystemTime +systemTime = iso toSys fromSys + where + toSys :: Unix -> SystemTime + toSys (sinceUnixEpoch -> gap) = + MkSystemTime (gap ^. secs) (gap ^. nanoSecs `mod` 1_000_000_000) + + fromSys :: SystemTime -> Unix + fromSys (MkSystemTime numSecs ns) = + fromUnixEpoch $ (numSecs ^. from secs) + (ns ^. from nanoSecs) + + fromUnixEpoch :: Gap -> Unix + fromUnixEpoch (Gap g) = Unix g + + sinceUnixEpoch :: Unix -> Gap + sinceUnixEpoch (Unix u) = Gap u + +unixEpoch :: Wen +unixEpoch = Wen (LargeKey 0x8000_000c_ce9e_0d80 0) + +unix :: Iso' Wen Unix +unix = iso toUnix fromUnix + where + fromUnix (Unix u) = Wen (u + epoch) + toUnix (Wen w) | w >= epoch = Unix (w - epoch) + | otherwise = throw Underflow + epoch = view (sinceUrbitEpoch . fractoSecs) unixEpoch + +picoSecs :: (Integral a, Num a) => Iso' Gap a +picoSecs = iso fromGap toGap + where + fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000_000_000) 64) + toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000_000_000) + +nanoSecs :: (Integral a, Num a) => Iso' Gap a +nanoSecs = iso fromGap toGap + where + fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000_000) 64) + toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000_000) + +microSecs :: (Integral a, Num a) => Iso' Gap a +microSecs = iso fromGap toGap + where + fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000) 64) + toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000) + +milliSecs :: (Integral a, Num a) => Iso' Gap a +milliSecs = iso fromGap toGap + where + fromGap (Gap x) = fromIntegral (shiftR (x * 1_000) 64) + toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000) + +secs :: (Integral a, Num a) => Iso' Gap a +secs = iso fromGap toGap + where + fromGap (Gap x) = fromIntegral (shiftR x 64) + toGap x = Gap (shiftL (fromIntegral x) 64) + + +-------------------------------------------------------------------------------- + +now :: IO Wen +now = view (from systemTime . from unix) <$> getSystemTime + +gap :: Wen -> Wen -> Gap +gap (Wen x) (Wen y) | x > y = Gap (x - y) + | otherwise = Gap (y - x) + +addGap :: Wen -> Gap -> Wen +addGap (Wen fs) (Gap g) = Wen (fs + g) + +sleep :: Gap -> IO () +sleep gap = threadDelay (gap ^. microSecs) + +sleepUntil :: Wen -> IO () +sleepUntil end = do + now >>= \case + start | start >= end -> pure () + | otherwise -> sleep (gap start end) diff --git a/pkg/hs/vere/package.yaml b/pkg/hs/vere/package.yaml index 92ba23dde..62d19498d 100644 --- a/pkg/hs/vere/package.yaml +++ b/pkg/hs/vere/package.yaml @@ -3,17 +3,17 @@ version: 0.1.0 license: AGPL-3.0-only default-extensions: - - OverloadedStrings - - TypeApplications - - UnicodeSyntax + - DeriveGeneric - FlexibleContexts - - TemplateHaskell - - QuasiQuotes - LambdaCase - NoImplicitPrelude + - OverloadedStrings + - QuasiQuotes - ScopedTypeVariables - - DeriveAnyClass - - DeriveGeneric + - TemplateHaskell + - TypeApplications + - UnicodeSyntax + - ViewPatterns dependencies: - base @@ -25,5 +25,9 @@ dependencies: - largeword - time -library: - source-dirs: . +executables: + vere: + main: Main.hs + source-dirs: . + ghc-options: + - -threaded From e6d8d382dc70c377a18e85b2c66e0593f8a435ee Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 8 May 2019 13:00:12 -0700 Subject: [PATCH 008/431] Moved *.hs into a single package. --- pkg/{hs => hair}/.gitignore | 0 pkg/{hs => hair/app}/uterm/Main.hs | 0 pkg/{hs => hair/app}/vere/Main.hs | 0 pkg/{hs/hoon/src => hair/lib}/Arvo.hs | 0 .../lib/Language/Hoon}/AST/Parser.hs | 4 +- .../lib/Language/Hoon}/AST/Types.hs | 2 +- .../src => hair/lib/Language/Hoon}/Desugar.hs | 10 ++-- .../lib/Language/Hoon}/IR/Desugar.hs | 16 +++---- .../lib/Language/Hoon}/IR/Infer.hs | 10 ++-- .../src => hair/lib/Language/Hoon}/IR/Ty.hs | 2 +- .../src => hair/lib/Language/Hoon}/IR/Wing.hs | 4 +- .../src => hair/lib/Language/Hoon}/LL/Gen.hs | 8 ++-- .../src => hair/lib/Language/Hoon}/LL/Run.hs | 8 ++-- .../lib/Language/Hoon}/LL/Types.hs | 4 +- .../lib/Language/Hoon}/Nock/Types.hs | 2 +- pkg/hair/lib/Language/Hoon/SpecToBunt.hs | 7 +++ .../lib/Language/Hoon}/SpecToMold.hs | 4 +- .../src => hair/lib/Language/Hoon}/Types.hs | 11 +++-- pkg/{hs/vere => hair/lib}/Urbit/Behn.hs | 0 pkg/{hs/vere => hair/lib}/Urbit/Time.hs | 2 + pkg/{hs/vere => hair}/notes/BehnSketch.hs.txt | 0 pkg/{hs/vere => hair}/notes/Sketch.hs.txt | 0 pkg/{hs/vere => hair}/notes/c/ames.c | 0 pkg/{hs/vere => hair}/notes/c/behn.c | 0 pkg/{hs/vere => hair}/notes/c/cttp.c | 0 pkg/{hs/vere => hair}/notes/c/daemon.c | 0 pkg/{hs/vere => hair}/notes/c/dawn.c | 0 pkg/{hs/vere => hair}/notes/c/foil.c | 0 pkg/{hs/vere => hair}/notes/c/hash_tests.c | 0 .../vere => hair}/notes/c/hashtable_tests.c | 0 pkg/{hs/vere => hair}/notes/c/http.c | 0 pkg/{hs/vere => hair}/notes/c/lmdb.c | 0 pkg/{hs/vere => hair}/notes/c/newt.c | 0 pkg/{hs/vere => hair}/notes/c/pier.c | 0 pkg/{hs/vere => hair}/notes/c/reck.c | 0 pkg/{hs/vere => hair}/notes/c/save.c | 0 pkg/{hs/vere => hair}/notes/c/term.c | 0 pkg/{hs/vere => hair}/notes/c/time.c | 0 pkg/{hs/vere => hair}/notes/c/unix.c | 0 pkg/{hs/vere => hair}/notes/c/walk.c | 0 pkg/{hs/vere => hair}/notes/c/worker.c | 0 pkg/{hs/hoon => hair}/package.yaml | 48 +++++++++++-------- pkg/{hs => hair}/stack.yaml | 4 +- pkg/hs/hoon/ChangeLog.md | 3 -- pkg/hs/hoon/LICENSE | 30 ------------ pkg/hs/hoon/README.md | 1 - pkg/hs/hoon/Setup.hs | 2 - pkg/hs/hoon/src/SpecToBunt.hs | 7 --- pkg/hs/uterm/package.yaml | 26 ---------- pkg/hs/vere/package.yaml | 33 ------------- 50 files changed, 83 insertions(+), 165 deletions(-) rename pkg/{hs => hair}/.gitignore (100%) rename pkg/{hs => hair/app}/uterm/Main.hs (100%) rename pkg/{hs => hair/app}/vere/Main.hs (100%) rename pkg/{hs/hoon/src => hair/lib}/Arvo.hs (100%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/AST/Parser.hs (99%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/AST/Types.hs (98%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/Desugar.hs (97%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/IR/Desugar.hs (94%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/IR/Infer.hs (97%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/IR/Ty.hs (99%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/IR/Wing.hs (99%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/LL/Gen.hs (94%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/LL/Run.hs (94%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/LL/Types.hs (96%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/Nock/Types.hs (97%) create mode 100644 pkg/hair/lib/Language/Hoon/SpecToBunt.hs rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/SpecToMold.hs (69%) rename pkg/{hs/hoon/src => hair/lib/Language/Hoon}/Types.hs (96%) rename pkg/{hs/vere => hair/lib}/Urbit/Behn.hs (100%) rename pkg/{hs/vere => hair/lib}/Urbit/Time.hs (99%) rename pkg/{hs/vere => hair}/notes/BehnSketch.hs.txt (100%) rename pkg/{hs/vere => hair}/notes/Sketch.hs.txt (100%) rename pkg/{hs/vere => hair}/notes/c/ames.c (100%) rename pkg/{hs/vere => hair}/notes/c/behn.c (100%) rename pkg/{hs/vere => hair}/notes/c/cttp.c (100%) rename pkg/{hs/vere => hair}/notes/c/daemon.c (100%) rename pkg/{hs/vere => hair}/notes/c/dawn.c (100%) rename pkg/{hs/vere => hair}/notes/c/foil.c (100%) rename pkg/{hs/vere => hair}/notes/c/hash_tests.c (100%) rename pkg/{hs/vere => hair}/notes/c/hashtable_tests.c (100%) rename pkg/{hs/vere => hair}/notes/c/http.c (100%) rename pkg/{hs/vere => hair}/notes/c/lmdb.c (100%) rename pkg/{hs/vere => hair}/notes/c/newt.c (100%) rename pkg/{hs/vere => hair}/notes/c/pier.c (100%) rename pkg/{hs/vere => hair}/notes/c/reck.c (100%) rename pkg/{hs/vere => hair}/notes/c/save.c (100%) rename pkg/{hs/vere => hair}/notes/c/term.c (100%) rename pkg/{hs/vere => hair}/notes/c/time.c (100%) rename pkg/{hs/vere => hair}/notes/c/unix.c (100%) rename pkg/{hs/vere => hair}/notes/c/walk.c (100%) rename pkg/{hs/vere => hair}/notes/c/worker.c (100%) rename pkg/{hs/hoon => hair}/package.yaml (75%) rename pkg/{hs => hair}/stack.yaml (82%) delete mode 100644 pkg/hs/hoon/ChangeLog.md delete mode 100644 pkg/hs/hoon/LICENSE delete mode 100644 pkg/hs/hoon/README.md delete mode 100644 pkg/hs/hoon/Setup.hs delete mode 100644 pkg/hs/hoon/src/SpecToBunt.hs delete mode 100644 pkg/hs/uterm/package.yaml delete mode 100644 pkg/hs/vere/package.yaml diff --git a/pkg/hs/.gitignore b/pkg/hair/.gitignore similarity index 100% rename from pkg/hs/.gitignore rename to pkg/hair/.gitignore diff --git a/pkg/hs/uterm/Main.hs b/pkg/hair/app/uterm/Main.hs similarity index 100% rename from pkg/hs/uterm/Main.hs rename to pkg/hair/app/uterm/Main.hs diff --git a/pkg/hs/vere/Main.hs b/pkg/hair/app/vere/Main.hs similarity index 100% rename from pkg/hs/vere/Main.hs rename to pkg/hair/app/vere/Main.hs diff --git a/pkg/hs/hoon/src/Arvo.hs b/pkg/hair/lib/Arvo.hs similarity index 100% rename from pkg/hs/hoon/src/Arvo.hs rename to pkg/hair/lib/Arvo.hs diff --git a/pkg/hs/hoon/src/AST/Parser.hs b/pkg/hair/lib/Language/Hoon/AST/Parser.hs similarity index 99% rename from pkg/hs/hoon/src/AST/Parser.hs rename to pkg/hair/lib/Language/Hoon/AST/Parser.hs index b7ee71ddf..89ff3e3b4 100644 --- a/pkg/hs/hoon/src/AST/Parser.hs +++ b/pkg/hair/lib/Language/Hoon/AST/Parser.hs @@ -1,8 +1,8 @@ -- TODO Handle comments -module AST.Parser where +module Language.Hoon.AST.Parser where -import AST.Types +import Language.Hoon.AST.Types import ClassyPrelude hiding (head, many, some, try) import Control.Lens import Text.Megaparsec diff --git a/pkg/hs/hoon/src/AST/Types.hs b/pkg/hair/lib/Language/Hoon/AST/Types.hs similarity index 98% rename from pkg/hs/hoon/src/AST/Types.hs rename to pkg/hair/lib/Language/Hoon/AST/Types.hs index 6632c11c1..b34ded52f 100644 --- a/pkg/hs/hoon/src/AST/Types.hs +++ b/pkg/hair/lib/Language/Hoon/AST/Types.hs @@ -1,6 +1,6 @@ -- TODO Handle comments -module AST.Types where +module Language.Hoon.AST.Types where import ClassyPrelude import Data.List.NonEmpty (NonEmpty) diff --git a/pkg/hs/hoon/src/Desugar.hs b/pkg/hair/lib/Language/Hoon/Desugar.hs similarity index 97% rename from pkg/hs/hoon/src/Desugar.hs rename to pkg/hair/lib/Language/Hoon/Desugar.hs index b172489f2..9eb34ff51 100644 --- a/pkg/hs/hoon/src/Desugar.hs +++ b/pkg/hair/lib/Language/Hoon/Desugar.hs @@ -1,14 +1,14 @@ -module Desugar (desugar) where +module Language.Hoon.Desugar (desugar) where import Prelude import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.Map as Map -import Nock.Types -import Types -import SpecToMold -import SpecToBunt +import Language.Hoon.Nock.Types +import Language.Hoon.Types +import Language.Hoon.SpecToMold +import Language.Hoon.SpecToBunt -- open:ap desugar :: Bool -> Hoon -> BHoon diff --git a/pkg/hs/hoon/src/IR/Desugar.hs b/pkg/hair/lib/Language/Hoon/IR/Desugar.hs similarity index 94% rename from pkg/hs/hoon/src/IR/Desugar.hs rename to pkg/hair/lib/Language/Hoon/IR/Desugar.hs index 270dfc763..0b936d663 100644 --- a/pkg/hs/hoon/src/IR/Desugar.hs +++ b/pkg/hair/lib/Language/Hoon/IR/Desugar.hs @@ -1,8 +1,8 @@ -module IR.Desugar where +module Language.Hoon.IR.Desugar where import ClassyPrelude hiding (union) -import IR.Ty +import Language.Hoon.IR.Ty import Control.Lens import Data.Foldable (foldr1) @@ -10,14 +10,14 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Char (ord) import Text.Show.Pretty (pPrint) -import qualified AST.Parser as AST -import qualified AST.Types as AST +import qualified Language.Hoon.AST.Parser as AST +import qualified Language.Hoon.AST.Types as AST import qualified Data.Map as Map import qualified Data.Set as Set -import qualified IR.Infer as IR -import qualified IR.Ty as IR -import qualified LL.Run as LL -import qualified LL.Types as LL +import qualified Language.Hoon.IR.Infer as IR +import qualified Language.Hoon.IR.Ty as IR +import qualified Language.Hoon.LL.Run as LL +import qualified Language.Hoon.LL.Types as LL import qualified Prelude import qualified System.Exit as Sys diff --git a/pkg/hs/hoon/src/IR/Infer.hs b/pkg/hair/lib/Language/Hoon/IR/Infer.hs similarity index 97% rename from pkg/hs/hoon/src/IR/Infer.hs rename to pkg/hair/lib/Language/Hoon/IR/Infer.hs index 6ddd835a5..b26a17f4f 100644 --- a/pkg/hs/hoon/src/IR/Infer.hs +++ b/pkg/hair/lib/Language/Hoon/IR/Infer.hs @@ -1,21 +1,21 @@ -module IR.Infer where +module Language.Hoon.IR.Infer where import ClassyPrelude hiding (union, intersect, subtract, negate) import Control.Monad.Fix import Data.Void -import IR.Ty +import Language.Hoon.IR.Ty import Data.List.NonEmpty -import LL.Types hiding (L, R, Ctx) +import Language.Hoon.LL.Types hiding (L, R, Ctx) import Control.Category ((>>>)) import Control.Lens import Data.Function ((&)) import Data.Maybe (fromJust) -import qualified LL.Types as LL +import qualified Language.Hoon.LL.Types as LL import qualified Data.Map as Map import qualified Data.Set as Set -import qualified IR.Wing as Wing +import qualified Language.Hoon.IR.Wing as Wing import qualified Prelude diff --git a/pkg/hs/hoon/src/IR/Ty.hs b/pkg/hair/lib/Language/Hoon/IR/Ty.hs similarity index 99% rename from pkg/hs/hoon/src/IR/Ty.hs rename to pkg/hair/lib/Language/Hoon/IR/Ty.hs index 1ec8c3ad6..1ff1bdd0c 100644 --- a/pkg/hs/hoon/src/IR/Ty.hs +++ b/pkg/hair/lib/Language/Hoon/IR/Ty.hs @@ -1,4 +1,4 @@ -module IR.Ty where +module Language.Hoon.IR.Ty where import ClassyPrelude hiding (union, intersect) import Control.Lens diff --git a/pkg/hs/hoon/src/IR/Wing.hs b/pkg/hair/lib/Language/Hoon/IR/Wing.hs similarity index 99% rename from pkg/hs/hoon/src/IR/Wing.hs rename to pkg/hair/lib/Language/Hoon/IR/Wing.hs index 4737136ca..1b81e609e 100644 --- a/pkg/hs/hoon/src/IR/Wing.hs +++ b/pkg/hair/lib/Language/Hoon/IR/Wing.hs @@ -1,8 +1,8 @@ -module IR.Wing where +module Language.Hoon.IR.Wing where import ClassyPrelude hiding (union) import Control.Lens hiding (union) -import IR.Ty +import Language.Hoon.IR.Ty import Control.Category ((>>>)) import qualified Data.Set as Set diff --git a/pkg/hs/hoon/src/LL/Gen.hs b/pkg/hair/lib/Language/Hoon/LL/Gen.hs similarity index 94% rename from pkg/hs/hoon/src/LL/Gen.hs rename to pkg/hair/lib/Language/Hoon/LL/Gen.hs index b539e8e3a..5c5acf56c 100644 --- a/pkg/hs/hoon/src/LL/Gen.hs +++ b/pkg/hair/lib/Language/Hoon/LL/Gen.hs @@ -1,11 +1,11 @@ -module LL.Gen where +module Language.Hoon.LL.Gen where import ClassyPrelude hiding (union) import Data.Bits (shift, finiteBitSize, countLeadingZeros) -import IR.Ty (Sym, Nat) -import LL.Types -import Nock.Types +import Language.Hoon.IR.Ty (Sym, Nat) +import Language.Hoon.LL.Types +import Language.Hoon.Nock.Types import qualified Data.Map as Map import qualified Data.Set as Set diff --git a/pkg/hs/hoon/src/LL/Run.hs b/pkg/hair/lib/Language/Hoon/LL/Run.hs similarity index 94% rename from pkg/hs/hoon/src/LL/Run.hs rename to pkg/hair/lib/Language/Hoon/LL/Run.hs index 9a2d9b1a5..9ed0e312c 100644 --- a/pkg/hs/hoon/src/LL/Run.hs +++ b/pkg/hair/lib/Language/Hoon/LL/Run.hs @@ -1,18 +1,18 @@ -module LL.Run where +module Language.Hoon.LL.Run where import ClassyPrelude hiding (succ, union, intersect) import Control.Lens import Control.Lens.TH import Control.Monad.Fix import Data.Void -import IR.Ty (Ty, Nat, Sym, Hoon, HoonPath) -import LL.Types +import Language.Hoon.IR.Ty (Ty, Nat, Sym, Hoon, HoonPath) +import Language.Hoon.LL.Types import Control.Category ((>>>)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified IR.Wing as Wing +import qualified Language.Hoon.IR.Wing as Wing import qualified Prelude diff --git a/pkg/hs/hoon/src/LL/Types.hs b/pkg/hair/lib/Language/Hoon/LL/Types.hs similarity index 96% rename from pkg/hs/hoon/src/LL/Types.hs rename to pkg/hair/lib/Language/Hoon/LL/Types.hs index eae3b4a92..b49b21b1a 100644 --- a/pkg/hs/hoon/src/LL/Types.hs +++ b/pkg/hair/lib/Language/Hoon/LL/Types.hs @@ -1,7 +1,7 @@ -module LL.Types where +module Language.Hoon.LL.Types where import ClassyPrelude hiding (union, intersect) -import IR.Ty +import Language.Hoon.IR.Ty import Control.Lens import Control.Lens.TH import Control.Monad.Fix diff --git a/pkg/hs/hoon/src/Nock/Types.hs b/pkg/hair/lib/Language/Hoon/Nock/Types.hs similarity index 97% rename from pkg/hs/hoon/src/Nock/Types.hs rename to pkg/hair/lib/Language/Hoon/Nock/Types.hs index e38afec09..cce513476 100644 --- a/pkg/hs/hoon/src/Nock/Types.hs +++ b/pkg/hair/lib/Language/Hoon/Nock/Types.hs @@ -1,4 +1,4 @@ -module Nock.Types where +module Language.Hoon.Nock.Types where import ClassyPrelude diff --git a/pkg/hair/lib/Language/Hoon/SpecToBunt.hs b/pkg/hair/lib/Language/Hoon/SpecToBunt.hs new file mode 100644 index 000000000..3101174fc --- /dev/null +++ b/pkg/hair/lib/Language/Hoon/SpecToBunt.hs @@ -0,0 +1,7 @@ +module Language.Hoon.SpecToBunt (specToBunt) where + +import Prelude +import Language.Hoon.Types + +specToBunt :: Bool -> Spec -> Hoon +specToBunt = undefined diff --git a/pkg/hs/hoon/src/SpecToMold.hs b/pkg/hair/lib/Language/Hoon/SpecToMold.hs similarity index 69% rename from pkg/hs/hoon/src/SpecToMold.hs rename to pkg/hair/lib/Language/Hoon/SpecToMold.hs index dcb50eb10..dc2ffb9b3 100644 --- a/pkg/hs/hoon/src/SpecToMold.hs +++ b/pkg/hair/lib/Language/Hoon/SpecToMold.hs @@ -1,7 +1,7 @@ -module SpecToMold (specToMold) where +module Language.Hoon.SpecToMold (specToMold) where import Prelude -import Types +import Language.Hoon.Types -- | factory:ax. Given a spec and a boolean (?) produces a normalizing gate. specToMold :: Bool -> Spec -> Hoon diff --git a/pkg/hs/hoon/src/Types.hs b/pkg/hair/lib/Language/Hoon/Types.hs similarity index 96% rename from pkg/hs/hoon/src/Types.hs rename to pkg/hair/lib/Language/Hoon/Types.hs index 4631f0d3b..1370f190b 100644 --- a/pkg/hs/hoon/src/Types.hs +++ b/pkg/hair/lib/Language/Hoon/Types.hs @@ -1,14 +1,17 @@ -module Types where +module Language.Hoon.Types where import Prelude +import Language.Hoon.Nock.Types + import qualified Data.Map as Map -import Data.Map (Map) import qualified Data.Set as Set -import Data.Set (Set) + +import Data.Map (Map) +import Data.Set (Set) import Data.List.NonEmpty (NonEmpty) -import Nock.Types +-------------------------------------------------------------------------------- hoonVersion :: Atom hoonVersion = 141 diff --git a/pkg/hs/vere/Urbit/Behn.hs b/pkg/hair/lib/Urbit/Behn.hs similarity index 100% rename from pkg/hs/vere/Urbit/Behn.hs rename to pkg/hair/lib/Urbit/Behn.hs diff --git a/pkg/hs/vere/Urbit/Time.hs b/pkg/hair/lib/Urbit/Time.hs similarity index 99% rename from pkg/hs/vere/Urbit/Time.hs rename to pkg/hair/lib/Urbit/Time.hs index d4cac0a15..25d94ad92 100644 --- a/pkg/hs/vere/Urbit/Time.hs +++ b/pkg/hair/lib/Urbit/Time.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NumericUnderscores, GeneralizedNewtypeDeriving #-} +-- TODO This is slow. + module Urbit.Time where import Prelude diff --git a/pkg/hs/vere/notes/BehnSketch.hs.txt b/pkg/hair/notes/BehnSketch.hs.txt similarity index 100% rename from pkg/hs/vere/notes/BehnSketch.hs.txt rename to pkg/hair/notes/BehnSketch.hs.txt diff --git a/pkg/hs/vere/notes/Sketch.hs.txt b/pkg/hair/notes/Sketch.hs.txt similarity index 100% rename from pkg/hs/vere/notes/Sketch.hs.txt rename to pkg/hair/notes/Sketch.hs.txt diff --git a/pkg/hs/vere/notes/c/ames.c b/pkg/hair/notes/c/ames.c similarity index 100% rename from pkg/hs/vere/notes/c/ames.c rename to pkg/hair/notes/c/ames.c diff --git a/pkg/hs/vere/notes/c/behn.c b/pkg/hair/notes/c/behn.c similarity index 100% rename from pkg/hs/vere/notes/c/behn.c rename to pkg/hair/notes/c/behn.c diff --git a/pkg/hs/vere/notes/c/cttp.c b/pkg/hair/notes/c/cttp.c similarity index 100% rename from pkg/hs/vere/notes/c/cttp.c rename to pkg/hair/notes/c/cttp.c diff --git a/pkg/hs/vere/notes/c/daemon.c b/pkg/hair/notes/c/daemon.c similarity index 100% rename from pkg/hs/vere/notes/c/daemon.c rename to pkg/hair/notes/c/daemon.c diff --git a/pkg/hs/vere/notes/c/dawn.c b/pkg/hair/notes/c/dawn.c similarity index 100% rename from pkg/hs/vere/notes/c/dawn.c rename to pkg/hair/notes/c/dawn.c diff --git a/pkg/hs/vere/notes/c/foil.c b/pkg/hair/notes/c/foil.c similarity index 100% rename from pkg/hs/vere/notes/c/foil.c rename to pkg/hair/notes/c/foil.c diff --git a/pkg/hs/vere/notes/c/hash_tests.c b/pkg/hair/notes/c/hash_tests.c similarity index 100% rename from pkg/hs/vere/notes/c/hash_tests.c rename to pkg/hair/notes/c/hash_tests.c diff --git a/pkg/hs/vere/notes/c/hashtable_tests.c b/pkg/hair/notes/c/hashtable_tests.c similarity index 100% rename from pkg/hs/vere/notes/c/hashtable_tests.c rename to pkg/hair/notes/c/hashtable_tests.c diff --git a/pkg/hs/vere/notes/c/http.c b/pkg/hair/notes/c/http.c similarity index 100% rename from pkg/hs/vere/notes/c/http.c rename to pkg/hair/notes/c/http.c diff --git a/pkg/hs/vere/notes/c/lmdb.c b/pkg/hair/notes/c/lmdb.c similarity index 100% rename from pkg/hs/vere/notes/c/lmdb.c rename to pkg/hair/notes/c/lmdb.c diff --git a/pkg/hs/vere/notes/c/newt.c b/pkg/hair/notes/c/newt.c similarity index 100% rename from pkg/hs/vere/notes/c/newt.c rename to pkg/hair/notes/c/newt.c diff --git a/pkg/hs/vere/notes/c/pier.c b/pkg/hair/notes/c/pier.c similarity index 100% rename from pkg/hs/vere/notes/c/pier.c rename to pkg/hair/notes/c/pier.c diff --git a/pkg/hs/vere/notes/c/reck.c b/pkg/hair/notes/c/reck.c similarity index 100% rename from pkg/hs/vere/notes/c/reck.c rename to pkg/hair/notes/c/reck.c diff --git a/pkg/hs/vere/notes/c/save.c b/pkg/hair/notes/c/save.c similarity index 100% rename from pkg/hs/vere/notes/c/save.c rename to pkg/hair/notes/c/save.c diff --git a/pkg/hs/vere/notes/c/term.c b/pkg/hair/notes/c/term.c similarity index 100% rename from pkg/hs/vere/notes/c/term.c rename to pkg/hair/notes/c/term.c diff --git a/pkg/hs/vere/notes/c/time.c b/pkg/hair/notes/c/time.c similarity index 100% rename from pkg/hs/vere/notes/c/time.c rename to pkg/hair/notes/c/time.c diff --git a/pkg/hs/vere/notes/c/unix.c b/pkg/hair/notes/c/unix.c similarity index 100% rename from pkg/hs/vere/notes/c/unix.c rename to pkg/hair/notes/c/unix.c diff --git a/pkg/hs/vere/notes/c/walk.c b/pkg/hair/notes/c/walk.c similarity index 100% rename from pkg/hs/vere/notes/c/walk.c rename to pkg/hair/notes/c/walk.c diff --git a/pkg/hs/vere/notes/c/worker.c b/pkg/hair/notes/c/worker.c similarity index 100% rename from pkg/hs/vere/notes/c/worker.c rename to pkg/hair/notes/c/worker.c diff --git a/pkg/hs/hoon/package.yaml b/pkg/hair/package.yaml similarity index 75% rename from pkg/hs/hoon/package.yaml rename to pkg/hair/package.yaml index 3a308cf0a..8504245d8 100644 --- a/pkg/hs/hoon/package.yaml +++ b/pkg/hair/package.yaml @@ -1,22 +1,37 @@ -name: language-hoon -version: 0.1.0.0 -github: "urbit/urbit" -license: BSD3 +name: vere +version: 0.1.0 +license: AGPL-3.0-only library: - source-dirs: src + source-dirs: lib -extra-source-files: - - README.md - - ChangeLog.md +executables: + uterm: + main: Main.hs + source-dirs: app/uterm + dependencies: ["vere"] + + vere: + main: Main.hs + source-dirs: app/vere + dependencies: ["vere"] + +ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -fwarn-incomplete-patterns + - -O2 dependencies: + - async - base - classy-prelude - containers - data-fix - - integer-gmp - ghc-prim + - integer-gmp + - largeword - lens - megaparsec - mtl @@ -26,23 +41,21 @@ dependencies: - QuickCheck - semigroups - smallcheck + - stm + - stm-chans - tasty - tasty-quickcheck - tasty-th - text - these + - time - unordered-containers - vector -ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -fwarn-incomplete-patterns - default-extensions: - ApplicativeDo - BangPatterns + - BlockArguments - DeriveFoldable - DeriveGeneric - DeriveTraversable @@ -51,13 +64,13 @@ default-extensions: - FlexibleInstances - FunctionalDependencies - GADTs - - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - NamedFieldPuns - NoImplicitPrelude - OverloadedStrings - PartialTypeSignatures + - QuasiQuotes - Rank2Types - RankNTypes - RecordWildCards @@ -68,6 +81,3 @@ default-extensions: - TypeFamilies - UnicodeSyntax - ViewPatterns - - BlockArguments - - NamedFieldPuns - - TemplateHaskell diff --git a/pkg/hs/stack.yaml b/pkg/hair/stack.yaml similarity index 82% rename from pkg/hs/stack.yaml rename to pkg/hair/stack.yaml index c7595d138..289b16243 100644 --- a/pkg/hs/stack.yaml +++ b/pkg/hair/stack.yaml @@ -1,9 +1,7 @@ resolver: lts-13.10 packages: - - hoon - - uterm - - vere + - . extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 diff --git a/pkg/hs/hoon/ChangeLog.md b/pkg/hs/hoon/ChangeLog.md deleted file mode 100644 index dd46edd71..000000000 --- a/pkg/hs/hoon/ChangeLog.md +++ /dev/null @@ -1,3 +0,0 @@ -# Changelog for hoon-hs - -## Unreleased changes diff --git a/pkg/hs/hoon/LICENSE b/pkg/hs/hoon/LICENSE deleted file mode 100644 index 102126f58..000000000 --- a/pkg/hs/hoon/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Author name here (c) 2019 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Author name here nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/pkg/hs/hoon/README.md b/pkg/hs/hoon/README.md deleted file mode 100644 index 0ddf296ac..000000000 --- a/pkg/hs/hoon/README.md +++ /dev/null @@ -1 +0,0 @@ -# hoon-hs diff --git a/pkg/hs/hoon/Setup.hs b/pkg/hs/hoon/Setup.hs deleted file mode 100644 index 9a994af67..000000000 --- a/pkg/hs/hoon/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/pkg/hs/hoon/src/SpecToBunt.hs b/pkg/hs/hoon/src/SpecToBunt.hs deleted file mode 100644 index 4177166a8..000000000 --- a/pkg/hs/hoon/src/SpecToBunt.hs +++ /dev/null @@ -1,7 +0,0 @@ -module SpecToBunt (specToBunt) where - -import Prelude -import Types - -specToBunt :: Bool -> Spec -> Hoon -specToBunt = undefined diff --git a/pkg/hs/uterm/package.yaml b/pkg/hs/uterm/package.yaml deleted file mode 100644 index 281073988..000000000 --- a/pkg/hs/uterm/package.yaml +++ /dev/null @@ -1,26 +0,0 @@ -name: "uterm" -version: 0.1.0 -license: AGPL-3.0-only - -default-extensions: - - OverloadedStrings - - TypeApplications - - UnicodeSyntax - - FlexibleContexts - - TemplateHaskell - - QuasiQuotes - - LambdaCase - - NoImplicitPrelude - - ScopedTypeVariables - - DeriveAnyClass - - DeriveGeneric - -dependencies: - - base - - classy-prelude - - lens - - language-hoon - -executables: - pomo: - main: "Main.hs" diff --git a/pkg/hs/vere/package.yaml b/pkg/hs/vere/package.yaml deleted file mode 100644 index 62d19498d..000000000 --- a/pkg/hs/vere/package.yaml +++ /dev/null @@ -1,33 +0,0 @@ -name: vere -version: 0.1.0 -license: AGPL-3.0-only - -default-extensions: - - DeriveGeneric - - FlexibleContexts - - LambdaCase - - NoImplicitPrelude - - OverloadedStrings - - QuasiQuotes - - ScopedTypeVariables - - TemplateHaskell - - TypeApplications - - UnicodeSyntax - - ViewPatterns - -dependencies: - - base - - classy-prelude - - stm - - stm-chans - - async - - lens - - largeword - - time - -executables: - vere: - main: Main.hs - source-dirs: . - ghc-options: - - -threaded From eaac71ce6ba4362d79814d3fa4654158a286b1b6 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 8 May 2019 13:51:04 -0700 Subject: [PATCH 009/431] Debugged behn timer accuracy. --- pkg/hair/app/vere/Main.hs | 47 +++++++++++++++++++++++--------------- pkg/hair/lib/Urbit/Behn.hs | 10 ++++++-- pkg/hair/lib/Urbit/Time.hs | 2 +- 3 files changed, 37 insertions(+), 22 deletions(-) diff --git a/pkg/hair/app/vere/Main.hs b/pkg/hair/app/vere/Main.hs index 80def3caa..a666d4899 100644 --- a/pkg/hair/app/vere/Main.hs +++ b/pkg/hair/app/vere/Main.hs @@ -3,6 +3,9 @@ module Main where import Prelude import Control.Lens +import Control.Concurrent.MVar +import Control.Concurrent (threadDelay, forkIO) +import Control.Monad (replicateM_, when) import Data.LargeWord (Word128, LargeKey(..)) import qualified Urbit.Behn as Behn @@ -10,13 +13,32 @@ import qualified Urbit.Time as Time -------------------------------------------------------------------------------- +threadDelayBench :: IO Time.Gap +threadDelayBench = do + before <- Time.now + mvar :: MVar () <- newEmptyMVar + forkIO $ do threadDelay 100 + putMVar mvar () + takeMVar mvar + after <- Time.now + pure (Time.gap before after) + +simpleBench :: Behn.Behn -> IO Time.Gap +simpleBench behn = do + before <- Time.now + target <- pure (Time.addGap before (10 ^. from Time.milliSecs)) + _ <- Behn.doze behn (Just target) + after <- Behn.wait behn >> Time.now + + pure (Time.gap target after) + bench :: Behn.Behn -> IO (Time.Wen, Time.Wen, Time.Wen) bench behn = do now <- Time.now print (now ^. Time.wenUtcTime) - Behn.doze behn (Just (Time.addGap now (500 ^. from Time.milliSecs))) + Behn.doze behn (Just (Time.addGap now (2 ^. from Time.milliSecs))) wen <- Behn.wait behn aft <- Time.now @@ -27,30 +49,17 @@ main :: IO () main = do behn <- Behn.init + replicateM_ 5 (threadDelayBench >>= (print . view Time.microSecs)) + putStrLn "" + + replicateM_ 5 (simpleBench behn >>= (print . view Time.microSecs)) + (x1,y1,z1) <- bench behn (x2,y2,z2) <- bench behn (x3,y3,z3) <- bench behn putStrLn "----" - print (x1 ^. Time.wenUtcTime) - print (Time.gap x1 y1 ^. Time.milliSecs) - print (y1 ^. Time.wenUtcTime) print (Time.gap y1 z1 ^. Time.milliSecs) - print (z1 ^. Time.wenUtcTime) - - putStrLn "----" - - print (x2 ^. Time.wenUtcTime) - print (Time.gap x2 y2 ^. Time.milliSecs) - print (y2 ^. Time.wenUtcTime) print (Time.gap y2 z2 ^. Time.milliSecs) - print (z2 ^. Time.wenUtcTime) - - putStrLn "----" - - print (x3 ^. Time.wenUtcTime) - print (Time.gap x3 y3 ^. Time.milliSecs) - print (y3 ^. Time.wenUtcTime) print (Time.gap y3 z3 ^. Time.milliSecs) - print (z3 ^. Time.wenUtcTime) diff --git a/pkg/hair/lib/Urbit/Behn.hs b/pkg/hair/lib/Urbit/Behn.hs index b65f44209..bf27a05fd 100644 --- a/pkg/hair/lib/Urbit/Behn.hs +++ b/pkg/hair/lib/Urbit/Behn.hs @@ -32,6 +32,12 @@ before releasing it. - If the timer gets the the lock first, it will fire (causeing `wait` to return) first, and then `doze` action will wait until that finishes. + + ## TODO + + `threadDelay` has low accuracy. Consider using + `GHC.Event.registerTimeout` instead. It's API is very close to what + we want for this anyways. -} module Urbit.Behn (Behn, init, wait, doze) where @@ -44,7 +50,7 @@ import Control.Concurrent.MVar import Control.Concurrent.Async (Async, async, cancel, asyncThreadId) import Control.Concurrent (threadDelay, killThread) -import Control.Monad (void) +import Control.Monad (void, when) import Data.Time.Clock.System (SystemTime(..), getSystemTime) import Urbit.Time (Wen) @@ -72,7 +78,7 @@ startTimerThread :: Behn -> Wen -> IO (Async ()) startTimerThread (Behn vSt sig) time = async $ do now <- Time.now - threadDelay (Time.gap now time ^. Time.microSecs) + Time.sleepUntil time takeMVar vSt void $ tryPutMVar sig time putMVar vSt Nothing diff --git a/pkg/hair/lib/Urbit/Time.hs b/pkg/hair/lib/Urbit/Time.hs index 25d94ad92..6faad0d8d 100644 --- a/pkg/hair/lib/Urbit/Time.hs +++ b/pkg/hair/lib/Urbit/Time.hs @@ -142,7 +142,7 @@ addGap :: Wen -> Gap -> Wen addGap (Wen fs) (Gap g) = Wen (fs + g) sleep :: Gap -> IO () -sleep gap = threadDelay (gap ^. microSecs) +sleep gap = do threadDelay (gap ^. microSecs) sleepUntil :: Wen -> IO () sleepUntil end = do From 9fd6aa04b46f000ca1ec5793fa4ed7f1c7096fb9 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 8 May 2019 16:57:34 -0700 Subject: [PATCH 010/431] Faster Behn --- pkg/hair/app/vere/Main.hs | 47 ++++--------------- pkg/hair/lib/Urbit/Behn.hs | 93 ++++++++++++++------------------------ pkg/hair/lib/Urbit/CTTP.hs | 1 + pkg/hair/package.yaml | 2 +- 4 files changed, 45 insertions(+), 98 deletions(-) create mode 100644 pkg/hair/lib/Urbit/CTTP.hs diff --git a/pkg/hair/app/vere/Main.hs b/pkg/hair/app/vere/Main.hs index a666d4899..b765677a6 100644 --- a/pkg/hair/app/vere/Main.hs +++ b/pkg/hair/app/vere/Main.hs @@ -13,53 +13,22 @@ import qualified Urbit.Time as Time -------------------------------------------------------------------------------- -threadDelayBench :: IO Time.Gap -threadDelayBench = do - before <- Time.now - mvar :: MVar () <- newEmptyMVar - forkIO $ do threadDelay 100 - putMVar mvar () - takeMVar mvar - after <- Time.now - pure (Time.gap before after) - -simpleBench :: Behn.Behn -> IO Time.Gap -simpleBench behn = do - before <- Time.now - target <- pure (Time.addGap before (10 ^. from Time.milliSecs)) - _ <- Behn.doze behn (Just target) - after <- Behn.wait behn >> Time.now - - pure (Time.gap target after) - -bench :: Behn.Behn -> IO (Time.Wen, Time.Wen, Time.Wen) +bench :: Behn.Behn -> IO () bench behn = do now <- Time.now - print (now ^. Time.wenUtcTime) + let wen = Time.addGap now (2 ^. from Time.milliSecs) + Behn.doze behn (Just wen) - Behn.doze behn (Just (Time.addGap now (2 ^. from Time.milliSecs))) - - wen <- Behn.wait behn + () <- Behn.wait behn aft <- Time.now - pure (now, wen, aft) + print (Time.gap wen aft ^. Time.milliSecs) main :: IO () main = do behn <- Behn.init - replicateM_ 5 (threadDelayBench >>= (print . view Time.microSecs)) - putStrLn "" - - replicateM_ 5 (simpleBench behn >>= (print . view Time.microSecs)) - - (x1,y1,z1) <- bench behn - (x2,y2,z2) <- bench behn - (x3,y3,z3) <- bench behn - - putStrLn "----" - - print (Time.gap y1 z1 ^. Time.milliSecs) - print (Time.gap y2 z2 ^. Time.milliSecs) - print (Time.gap y3 z3 ^. Time.milliSecs) + putStrLn "" + replicateM_ 50 (bench behn) + putStrLn "" diff --git a/pkg/hair/lib/Urbit/Behn.hs b/pkg/hair/lib/Urbit/Behn.hs index bf27a05fd..7e0a1ea0b 100644 --- a/pkg/hair/lib/Urbit/Behn.hs +++ b/pkg/hair/lib/Urbit/Behn.hs @@ -14,30 +14,6 @@ replaces the old one. - If a timer is unset (with `doze _ Nothing`), the timer will not fire until a new time has been set. - - ## Implementation Notes - - We use `tryPutMVar` when the timer fires, so that things will continue - to work correctly if the user does not call `wait`. If a timer fires - before `wait` is called, `wait` will return immediatly. - - To handle race conditions, the MVar in `bState` is used as a lock. The - code for setting a timer and the thread that runs when the timer fires - (which causes `wait` to return) both take that MVar before acting. - - So, if the timer fires conncurently with a call to `doze`, - then one of those threads will get the lock and the other will wait: - - - If the `doze` call gets the lock first, it will kill the timer thread - before releasing it. - - If the timer gets the the lock first, it will fire (causeing `wait` - to return) first, and then `doze` action will wait until that finishes. - - ## TODO - - `threadDelay` has low accuracy. Consider using - `GHC.Event.registerTimeout` instead. It's API is very close to what - we want for this anyways. -} module Urbit.Behn (Behn, init, wait, doze) where @@ -45,52 +21,53 @@ module Urbit.Behn (Behn, init, wait, doze) where import Prelude hiding (init) import Control.Lens -import Data.LargeWord -import Control.Concurrent.MVar +import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar, putMVar) +import Control.Monad (void, when) +import Data.IORef (IORef, writeIORef, readIORef, newIORef) -import Control.Concurrent.Async (Async, async, cancel, asyncThreadId) -import Control.Concurrent (threadDelay, killThread) -import Control.Monad (void, when) -import Data.Time.Clock.System (SystemTime(..), getSystemTime) -import Urbit.Time (Wen) - -import qualified Control.Concurrent.Async as Async -import qualified Urbit.Time as Time +import qualified Urbit.Time as Time +import qualified GHC.Event as Ev -- Behn Stuff ------------------------------------------------------------------ data Behn = Behn - { bState :: MVar (Maybe (Wen, Async ())) - , bSignal :: MVar Wen + { bState :: IORef (Maybe Ev.TimeoutKey) + , bSignal :: MVar () + , bManager :: Ev.TimerManager } init :: IO Behn init = do - st <- newMVar Nothing + st <- newIORef Nothing sig <- newEmptyMVar - pure (Behn st sig) + man <- Ev.getSystemTimerManager + pure (Behn st sig man) -wait :: Behn -> IO Wen -wait (Behn _ sig) = takeMVar sig +wait :: Behn -> IO () +wait (Behn _ sig _) = takeMVar sig -startTimerThread :: Behn -> Wen -> IO (Async ()) -startTimerThread (Behn vSt sig) time = - async $ do - now <- Time.now - Time.sleepUntil time - takeMVar vSt - void $ tryPutMVar sig time - putMVar vSt Nothing +setTimer :: Behn -> Time.Wen -> IO () +setTimer behn@(Behn vSt sig man) time = do + killTimer behn + now <- Time.now + case (now >= time) of + True -> void (putMVar sig ()) + False -> do + let microSleep = Time.gap now time ^. Time.microSecs + let fire = putMVar sig () >> killTimer behn + key <- Ev.registerTimeout man microSleep fire + writeIORef vSt $! Just key -doze :: Behn -> Maybe Wen -> IO () -doze behn@(Behn vSt sig) mNewTime = do - takeMVar vSt >>= \case Nothing -> pure () - Just (_,timer) -> cancel timer +killTimer :: Behn -> IO () +killTimer (Behn vSt sig man) = do + mKey <- do st <- readIORef vSt + writeIORef vSt $! Nothing + pure st + mKey & \case + Just k -> Ev.unregisterTimeout man k + Nothing -> pure () - newSt <- mNewTime & \case - Nothing -> pure (Nothing :: Maybe (Wen, Async ())) - Just time -> do timer <- startTimerThread behn time - pure (Just (time, timer)) - - void (putMVar vSt newSt) +doze :: Behn -> Maybe Time.Wen -> IO () +doze behn Nothing = killTimer behn +doze behn (Just t) = setTimer behn t diff --git a/pkg/hair/lib/Urbit/CTTP.hs b/pkg/hair/lib/Urbit/CTTP.hs new file mode 100644 index 000000000..560c02cee --- /dev/null +++ b/pkg/hair/lib/Urbit/CTTP.hs @@ -0,0 +1 @@ +module Urbit.CTTP where diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 8504245d8..8c7784ddc 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -19,7 +19,7 @@ executables: ghc-options: - -threaded - -rtsopts - - -with-rtsopts=-N + - "-with-rtsopts=-H128m" - -fwarn-incomplete-patterns - -O2 From 52d7d64f0288b14b04308e9b0a03dee8843b9c1a Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 9 May 2019 13:01:22 -0700 Subject: [PATCH 011/431] Fixed a couple of bugs in time conversions. --- pkg/hair/app/vere/Main.hs | 41 +++++++--- pkg/hair/lib/Urbit/Behn.hs | 43 +++------- pkg/hair/lib/Urbit/CTTP.hs | 9 +++ pkg/hair/lib/Urbit/Time.hs | 157 +++++++++++++----------------------- pkg/hair/lib/Urbit/Timer.hs | 48 +++++++++++ pkg/hair/package.yaml | 17 ++-- pkg/urbit/vere/cttp.c | 5 +- 7 files changed, 168 insertions(+), 152 deletions(-) create mode 100644 pkg/hair/lib/Urbit/Timer.hs diff --git a/pkg/hair/app/vere/Main.hs b/pkg/hair/app/vere/Main.hs index b765677a6..0e5573909 100644 --- a/pkg/hair/app/vere/Main.hs +++ b/pkg/hair/app/vere/Main.hs @@ -3,32 +3,47 @@ module Main where import Prelude import Control.Lens -import Control.Concurrent.MVar -import Control.Concurrent (threadDelay, forkIO) -import Control.Monad (replicateM_, when) -import Data.LargeWord (Word128, LargeKey(..)) +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 -import qualified Urbit.Behn as Behn -import qualified Urbit.Time as Time -------------------------------------------------------------------------------- +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 (2 ^. from Time.milliSecs) + 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.milliSecs) + print (Time.gap wen aft ^. Time.microSecs) main :: IO () main = do - behn <- Behn.init + behn <- Behn.init + timer <- Timer.init + + putStrLn "" + replicateM_ 10 (benchTimer timer) + putStrLn "" putStrLn "" - replicateM_ 50 (bench behn) + replicateM_ 10 (bench behn) putStrLn "" diff --git a/pkg/hair/lib/Urbit/Behn.hs b/pkg/hair/lib/Urbit/Behn.hs index 7e0a1ea0b..a2555ddb8 100644 --- a/pkg/hair/lib/Urbit/Behn.hs +++ b/pkg/hair/lib/Urbit/Behn.hs @@ -25,49 +25,28 @@ import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar, putMVar) import Control.Monad (void, when) import Data.IORef (IORef, writeIORef, readIORef, newIORef) -import qualified Urbit.Time as Time -import qualified GHC.Event as Ev +import qualified Urbit.Timer as Timer +import qualified Urbit.Time as Time +import qualified GHC.Event as Ev -- Behn Stuff ------------------------------------------------------------------ data Behn = Behn - { bState :: IORef (Maybe Ev.TimeoutKey) - , bSignal :: MVar () - , bManager :: Ev.TimerManager + { bTimer :: Timer.Timer + , bSignal :: MVar () } init :: IO Behn init = do - st <- newIORef Nothing + tim <- Timer.init sig <- newEmptyMVar - man <- Ev.getSystemTimerManager - pure (Behn st sig man) + pure (Behn tim sig) wait :: Behn -> IO () -wait (Behn _ sig _) = takeMVar sig - -setTimer :: Behn -> Time.Wen -> IO () -setTimer behn@(Behn vSt sig man) time = do - killTimer behn - now <- Time.now - case (now >= time) of - True -> void (putMVar sig ()) - False -> do - let microSleep = Time.gap now time ^. Time.microSecs - let fire = putMVar sig () >> killTimer behn - key <- Ev.registerTimeout man microSleep fire - writeIORef vSt $! Just key - -killTimer :: Behn -> IO () -killTimer (Behn vSt sig man) = do - mKey <- do st <- readIORef vSt - writeIORef vSt $! Nothing - pure st - mKey & \case - Just k -> Ev.unregisterTimeout man k - Nothing -> pure () +wait (Behn _ sig) = takeMVar sig doze :: Behn -> Maybe Time.Wen -> IO () -doze behn Nothing = killTimer behn -doze behn (Just t) = setTimer behn t +doze behn Nothing = Timer.stop (bTimer behn) +doze (Behn tim sig) (Just t) = + Timer.start tim (t ^. Time.systemTime) (putMVar sig ()) diff --git a/pkg/hair/lib/Urbit/CTTP.hs b/pkg/hair/lib/Urbit/CTTP.hs index 560c02cee..9d96d7bfd 100644 --- a/pkg/hair/lib/Urbit/CTTP.hs +++ b/pkg/hair/lib/Urbit/CTTP.hs @@ -1 +1,10 @@ module Urbit.CTTP where + +{- +h2o_iovec_t +_cttp_vec_to_atom +u3_hhed* + type HHed = [(Text, Text)] +u3_hbod* + type HBod = [ByteString] +-} diff --git a/pkg/hair/lib/Urbit/Time.hs b/pkg/hair/lib/Urbit/Time.hs index 6faad0d8d..962b7c185 100644 --- a/pkg/hair/lib/Urbit/Time.hs +++ b/pkg/hair/lib/Urbit/Time.hs @@ -7,11 +7,7 @@ module Urbit.Time where import Prelude import Control.Lens -import Data.Coerce (coerce) -import Control.Concurrent (threadDelay) -import Control.Exception (throw, ArithException(Underflow)) import Data.Bits (shiftL, shiftR) -import Data.LargeWord (Word128, LargeKey(..)) import Data.Time.Clock (DiffTime, UTCTime, picosecondsToDiffTime, diffTimeToPicoseconds) import Data.Time.Clock.System (SystemTime(..), getSystemTime, utcToSystemTime, @@ -20,40 +16,21 @@ import Data.Time.Clock.System (SystemTime(..), getSystemTime, utcToSystemTime, -- Types ----------------------------------------------------------------------- -newtype Gap = Gap { unGap :: Word128 } +newtype Gap = Gap { _fractoSecs :: Integer } + deriving (Eq, Ord, Show, Num) + +newtype Unix = Unix { _sinceUnixEpoch :: Gap } deriving (Eq, Ord, Show) -newtype Wen = Wen { unWen :: Word128 } - deriving (Eq, Ord, Show) - -newtype Unix = Unix { unUnix :: Word128 } +newtype Wen = Wen { _sinceUrbitEpoch :: Gap } deriving (Eq, Ord, Show) --- Basic Lenses ---------------------------------------------------------------- +-- Lenses ---------------------------------------------------------------------- -fractoSecs :: Iso' Gap Word128 -fractoSecs = iso unGap Gap - -sinceUrbitEpoch :: Iso' Wen Gap -sinceUrbitEpoch = iso (Gap . unWen) (Wen . unGap) - -sinceUnixEpoch :: Iso' Unix Gap -sinceUnixEpoch = iso (Gap . unUnix) (Unix . unGap) - - --- Instances ------------------------------------------------------------------- - -instance Num Gap where - x + y = Gap (coerce x + coerce y) - x * y = Gap (coerce x * coerce y) - fromInteger = Gap . fromInteger - abs = over fractoSecs abs - signum = over fractoSecs signum - negate = over fractoSecs negate - - --- Conversions ----------------------------------------------------------------- +makeLenses ''Gap +makeLenses ''Unix +makeLenses ''Wen diffTime :: Iso' Gap DiffTime diffTime = iso fromGap toGap @@ -61,91 +38,73 @@ diffTime = iso fromGap toGap fromGap = picosecondsToDiffTime . view picoSecs toGap = view (from picoSecs) . diffTimeToPicoseconds -utcTime :: Iso' Unix UTCTime -utcTime = iso fromUnix toUnix - where - fromUnix = systemToUTCTime . view systemTime - toUnix = view (from systemTime) . utcToSystemTime +sysUTC :: Iso' SystemTime UTCTime +sysUTC = iso systemToUTCTime utcToSystemTime -wenUtcTime :: Iso' Wen UTCTime -wenUtcTime = unix . utcTime - -systemTime :: Iso' Unix SystemTime -systemTime = iso toSys fromSys - where - toSys :: Unix -> SystemTime - toSys (sinceUnixEpoch -> gap) = - MkSystemTime (gap ^. secs) (gap ^. nanoSecs `mod` 1_000_000_000) - - fromSys :: SystemTime -> Unix - fromSys (MkSystemTime numSecs ns) = - fromUnixEpoch $ (numSecs ^. from secs) + (ns ^. from nanoSecs) - - fromUnixEpoch :: Gap -> Unix - fromUnixEpoch (Gap g) = Unix g - - sinceUnixEpoch :: Unix -> Gap - sinceUnixEpoch (Unix u) = Gap u +utcTime :: Iso' Wen UTCTime +utcTime = systemTime . sysUTC unixEpoch :: Wen -unixEpoch = Wen (LargeKey 0x8000_000c_ce9e_0d80 0) +unixEpoch = Wen (Gap 0x8000_000c_ce9e_0d80_0000_0000_0000_0000) + +unixSystemTime :: Iso' Unix SystemTime +unixSystemTime = iso toSys fromSys + where + toSys (Unix gap) = MkSystemTime (fromInteger sec) (fromInteger ns) + where (sec, ns) = quotRem (gap ^. nanoSecs) 1_000_000_000 + fromSys (MkSystemTime sec ns) = + Unix $ (toInteger sec ^. from secs) + + (toInteger ns ^. from nanoSecs) unix :: Iso' Wen Unix unix = iso toUnix fromUnix where - fromUnix (Unix u) = Wen (u + epoch) - toUnix (Wen w) | w >= epoch = Unix (w - epoch) - | otherwise = throw Underflow - epoch = view (sinceUrbitEpoch . fractoSecs) unixEpoch + toUnix (Wen g) = Unix (g - unWen unixEpoch) + fromUnix (Unix g) = Wen (unWen unixEpoch + g) + unWen (Wen x) = x -picoSecs :: (Integral a, Num a) => Iso' Gap a -picoSecs = iso fromGap toGap - where - fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000_000_000) 64) - toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000_000_000) +systemTime :: Iso' Wen SystemTime +systemTime = unix . unixSystemTime -nanoSecs :: (Integral a, Num a) => Iso' Gap a -nanoSecs = iso fromGap toGap - where - fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000_000) 64) - toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000_000) -microSecs :: (Integral a, Num a) => Iso' Gap a -microSecs = iso fromGap toGap - where - fromGap (Gap x) = fromIntegral (shiftR (x * 1_000_000) 64) - toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000_000) +-------------------------------------------------------------------------------- -milliSecs :: (Integral a, Num a) => Iso' Gap a -milliSecs = iso fromGap toGap - where - fromGap (Gap x) = fromIntegral (shiftR (x * 1_000) 64) - toGap x = Gap (shiftL (fromIntegral x) 64 `div` 1_000) +toDenomSecs :: Integer -> Gap -> Integer +toDenomSecs denom (Gap g) = shiftR (g * denom) 64 -secs :: (Integral a, Num a) => Iso' Gap a -secs = iso fromGap toGap - where - fromGap (Gap x) = fromIntegral (shiftR x 64) - toGap x = Gap (shiftL (fromIntegral x) 64) +fromDenomSecs :: Integer -> Integer -> Gap +fromDenomSecs denom ds = + Gap $ (shiftL ds 64) `div` denom + +picoSecs :: Iso' Gap Integer +picoSecs = iso (toDenomSecs denom) (fromDenomSecs denom) + where denom = 1_000_000_000_000 + +nanoSecs :: Iso' Gap Integer +nanoSecs = iso (toDenomSecs denom) (fromDenomSecs denom) + where denom = 1_000_000_000 + +microSecs :: Iso' Gap Integer +microSecs = iso (toDenomSecs denom) (fromDenomSecs denom) + where denom = 1_000_000 + +milliSecs :: Iso' Gap Integer +milliSecs = iso (toDenomSecs denom) (fromDenomSecs denom) + where denom = 1_000 + +secs :: Iso' Gap Integer +secs = iso (toDenomSecs denom) (fromDenomSecs denom) + where denom = 1 -------------------------------------------------------------------------------- now :: IO Wen -now = view (from systemTime . from unix) <$> getSystemTime +now = view (from systemTime) <$> getSystemTime gap :: Wen -> Wen -> Gap -gap (Wen x) (Wen y) | x > y = Gap (x - y) - | otherwise = Gap (y - x) +gap (Wen x) (Wen y) | x > y = x - y + | otherwise = y - x addGap :: Wen -> Gap -> Wen -addGap (Wen fs) (Gap g) = Wen (fs + g) - -sleep :: Gap -> IO () -sleep gap = do threadDelay (gap ^. microSecs) - -sleepUntil :: Wen -> IO () -sleepUntil end = do - now >>= \case - start | start >= end -> pure () - | otherwise -> sleep (gap start end) +addGap (Wen x) y = Wen (x+y) diff --git a/pkg/hair/lib/Urbit/Timer.hs b/pkg/hair/lib/Urbit/Timer.hs new file mode 100644 index 000000000..1559feb8d --- /dev/null +++ b/pkg/hair/lib/Urbit/Timer.hs @@ -0,0 +1,48 @@ +module Urbit.Timer ( Timer, init, stop, start + , Sys.getSystemTime, sysTimeGapMicroSecs + ) where + +import Prelude hiding (init) +import Control.Lens +import Data.IORef + +import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar, putMVar) +import Control.Monad (void, when) + +import qualified GHC.Event as Ev +import qualified Data.Time.Clock.System as Sys + + +-- Timer Stuff ----------------------------------------------------------------- + +data Timer = Timer + { bState :: IORef (Maybe Ev.TimeoutKey) + , bManager :: Ev.TimerManager + } + +init :: IO Timer +init = do + st <- newIORef Nothing + man <- Ev.getSystemTimerManager + pure (Timer st man) + +sysTimeGapMicroSecs :: Sys.SystemTime -> Sys.SystemTime -> Int +sysTimeGapMicroSecs (Sys.MkSystemTime xSec xNs) (Sys.MkSystemTime ySec yNs) = + (+) (1_000_000 * fromIntegral (ySec - xSec)) + ((fromIntegral yNs - fromIntegral xNs) `quot` 1000) + +start :: Timer -> Sys.SystemTime -> IO () -> IO () +start timer@(Timer vSt man) time cb = do + let fire = cb >> stop timer + stop timer + now <- Sys.getSystemTime + let sleep = sysTimeGapMicroSecs now time + if (sleep <= 0) then fire else do + key <- Ev.registerTimeout man sleep fire + atomicWriteIORef vSt $! Just key + +stop :: Timer -> IO () +stop (Timer vSt man) = + atomicModifyIORef' vSt (Nothing,) >>= \case + Just key -> Ev.unregisterTimeout man key + Nothing -> pure () diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 8c7784ddc..8e41ee3b2 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -4,6 +4,9 @@ license: AGPL-3.0-only library: source-dirs: lib + ghc-options: + - -fwarn-incomplete-patterns + - -O2 executables: uterm: @@ -15,13 +18,12 @@ executables: main: Main.hs source-dirs: app/vere dependencies: ["vere"] - -ghc-options: - - -threaded - - -rtsopts - - "-with-rtsopts=-H128m" - - -fwarn-incomplete-patterns - - -O2 + ghc-options: + - -threaded + - -rtsopts + - "-with-rtsopts=-H128m" + - -fwarn-incomplete-patterns + - -O2 dependencies: - async @@ -81,3 +83,4 @@ default-extensions: - TypeFamilies - UnicodeSyntax - ViewPatterns + - NumericUnderscores diff --git a/pkg/urbit/vere/cttp.c b/pkg/urbit/vere/cttp.c index 36ff32440..537f65f07 100644 --- a/pkg/urbit/vere/cttp.c +++ b/pkg/urbit/vere/cttp.c @@ -946,6 +946,9 @@ _cttp_init_h2o() }; /* u3_cttp_ef_thus(): send %thus effect (outgoing request) to cttp. + + -- zuse will have a type for this + */ void u3_cttp_ef_thus(c3_l num_l, @@ -954,7 +957,7 @@ u3_cttp_ef_thus(c3_l num_l, u3_creq* ceq_u; if ( u3_nul == cuq ) { - ceq_u =_cttp_creq_find(num_l); + ceq_u = _cttp_creq_find(num_l); if ( ceq_u ) { _cttp_creq_quit(ceq_u); From cfe4df4a9d7a9b04020e01151a0a8ede66d9aeb1 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 9 May 2019 15:46:54 -0700 Subject: [PATCH 012/431] Basic GHC libnoun impl. --- pkg/hair/lib/Data/Noun.hs | 46 +++++++++ pkg/hair/lib/NockRTS/Noun.hs | 183 +++++++++++++++++++++++++++++++++++ 2 files changed, 229 insertions(+) create mode 100644 pkg/hair/lib/Data/Noun.hs create mode 100644 pkg/hair/lib/NockRTS/Noun.hs diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs new file mode 100644 index 000000000..d95d77201 --- /dev/null +++ b/pkg/hair/lib/Data/Noun.hs @@ -0,0 +1,46 @@ +module Data.Noun where + +import Prelude +import Numeric.Natural + +import Data.List (intercalate) + + +-------------------------------------------------------------------------------- + +type Atom = Natural + +data Cell = CCell !Noun !Noun + +data Noun + = Atom !Natural + | Cell !Noun !Noun + deriving (Eq, Ord) + + +-- Unboxed Atom Operations ----------------------------------------------------- + +cell2List :: Cell -> [Noun] +cell2List = go [] + where + go acc (CCell x (Cell l r)) = go (x:acc) (CCell l r) + go acc (CCell x y@(Atom _)) = reverse (y:x:acc) + +list2Noun :: [Noun] -> Noun +list2Noun [] = Atom 0 +list2Noun [x] = x +list2Noun (x:xs) = Cell x (list2Noun xs) + +instance Show Noun where + show (Atom a) = show a + show (Cell x y) = fmtCell (fmap show (cell2List (CCell x y))) + where + fmtCell :: [String] -> String + fmtCell xs = "[" <> intercalate " " xs <> "]" + +example :: Noun +example = list2Noun [Atom 1337, Atom 1338, Atom 0] + +exampleIO :: IO () +exampleIO = do + print example diff --git a/pkg/hair/lib/NockRTS/Noun.hs b/pkg/hair/lib/NockRTS/Noun.hs new file mode 100644 index 000000000..05328385f --- /dev/null +++ b/pkg/hair/lib/NockRTS/Noun.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, UnboxedSums #-} + +module NockRTS.Noun where + +import Data.Word +import GHC.Base hiding (C#) +import GHC.Integer.GMP.Internals +import GHC.Prim +import Prelude hiding (cons) + +import Data.List (intercalate) +import GHC.Real (underflowError) + +-------------------------------------------------------------------------------- + +type Noun# = (# Word# | BigNat | Cell #) +type Atom# = (# Word# | BigNat #) +type Cell# = (# Noun#, Noun# #) + +data Cell = C# Cell# +data Atom = A# Atom# +data Noun = N# Noun# + + +-- Unboxed Atom Operations ----------------------------------------------------- + +wordIsZero# :: Word# -> Bool +wordIsZero# w = 0 == (I# (word2Int# w)) + +words2Atom# :: (# Word#, Word# #) -> Atom# +words2Atom# (# x, y #) = + if wordIsZero# x + then (# y | #) + else (# | wordToBigNat2 x y #) + +inc# :: Atom# -> Atom# +inc# (# w | #) = words2Atom# (plusWord2# w (int2Word# 1#)) +inc# (# | n #) = (# | n #) + +plusAtom# :: Atom# -> Atom# -> Atom# +plusAtom# (# x | #) (# y | #) = words2Atom# (# x, y #) +plusAtom# (# w | #) (# | n #) = (# | plusBigNatWord n w #) +plusAtom# (# | n #) (# w | #) = (# | plusBigNatWord n w #) +plusAtom# (# | x #) (# | y #) = (# | plusBigNat x y #) + +minusAtom# :: Atom# -> Atom# -> Atom# +minusAtom# x (# 0## | #) = x + +{- +minusAtom# (NatS# x) (NatS# y) = case subWordC# x y of + (# l, 0# #) -> NatS# l + _ -> underflowError +minusAtom# (NatS# _) (NatJ# _) = underflowError +minusAtom# (NatJ# x) (NatS# y) = bigNatToAtom# (minusBigNatWord x y) +minusAtom# (NatJ# x) (NatJ# y) = bigNatToAtom# (minusBigNat x y) +-} + + +word2Atom# :: Word# -> Atom# +word2Atom# w = (# w | #) + +bigNat2Atom# :: BigNat -> Atom# +bigNat2Atom# bn = (# | bn #) + + +-- Unboxed Cell Operations ----------------------------------------------------- + +car# :: Cell# -> Noun# +car# (# x, _ #) = x + +cdr# :: Cell# -> Noun# +cdr# (# _, y #) = y + +cellCons# :: Noun# -> Noun# -> Cell# +cellCons# x y = (# x, y #) + + +-- Unboxed Noun Operations ----------------------------------------------------- + +runNoun# :: Noun# -> (Cell -> a) -> (Atom# -> a) -> a +runNoun# (# w | | #) c a = a (# w | #) +runNoun# (# | n | #) c a = a (# | n #) +runNoun# (# | | p #) c a = c p + +atom2Noun# :: Atom# -> Noun# +atom2Noun# (# w | #) = (# w | | #) +atom2Noun# (# | n #) = (# | n | #) + +word2Noun# :: Word# -> Noun# +word2Noun# w = (# w | | #) + +bigNat2Noun# :: BigNat -> Noun# +bigNat2Noun# bn = (# | bn | #) + +cell2Noun# :: Cell# -> Noun# +cell2Noun# c = (# | | C# c #) + + +-- Boxed Operations ------------------------------------------------------------ + +plusAtom :: Atom -> Atom -> Atom +plusAtom (A# x) (A# y) = A# (plusAtom# x y) + +minusAtom :: Atom -> Atom -> Atom +minusAtom (A# x) (A# y) = A# (minusAtom# x y) + +negateAtom :: Atom -> Atom +negateAtom = undefined + +timesAtom :: Atom -> Atom -> Atom +timesAtom = undefined + +atomFromInteger :: Integer -> Atom +atomFromInteger (S# i) = A# (# int2Word# i | #) +atomFromInteger (Jp# n) = A# (# | n #) +atomFromInteger _ = underflowError + +signumAtom :: Atom -> Atom +signumAtom = undefined + +atom2Noun :: Atom -> Noun +atom2Noun (A# a) = N# (atom2Noun# a) + +cell2Noun :: Cell -> Noun +cell2Noun c = N# (# | | c #) + +cons :: Noun -> Noun -> Noun +cons (N# x) (N# y) = cell2Noun (C# (cellCons# x y)) + +runNoun :: Noun -> (Cell -> a) -> (Atom -> a) -> a +runNoun (N# n) f g = runNoun# n (\c -> f c) (\a -> g (A# a)) + +toAtom :: Noun -> Maybe Atom +toAtom (N# n) = runNoun# n (\_ -> Nothing) (\a -> Just (A# a)) + +plusNoun :: Noun -> Noun -> Maybe Noun +plusNoun x y = atom2Noun <$> (plusAtom <$> toAtom x <*> toAtom y) + + +-- Random Bullshit ------------------------------------------------------------- + +cell2List :: Cell -> [Noun] +cell2List = go [] + where + go :: [Noun] -> Cell -> [Noun] + go acc (C# (# x, y #)) = runNoun# y (\c -> go (N# x : acc) c) + (\a -> reverse (N# y : N# x : acc)) + +list2Noun :: [Noun] -> Noun +list2Noun [] = atom2Noun 0 +list2Noun [x] = x +list2Noun (x:xs) = cons x (list2Noun xs) + +fmtCell :: [String] -> String +fmtCell xs = "[" <> intercalate " " xs <> "]" + +instance Num Atom where + (+) = plusAtom + (-) = minusAtom + (*) = timesAtom + negate = negateAtom + fromInteger = atomFromInteger + abs = id + signum = signumAtom + +instance Show Atom where + show (A# (# w | #)) = show (W# w) + show (A# (# | n #)) = show (Jp# n) + +instance Show Cell where + show c = fmtCell (fmap show (cell2List c)) + +instance Show Noun where + show (N# (# w | | #)) = show (W# w) + show (N# (# | n | #)) = show (Jp# n) + show (N# (# | | c #)) = show c + +example :: Noun +example = list2Noun [atom2Noun 1337, atom2Noun 1338, atom2Noun 0] + +exampleIO :: IO () +exampleIO = do + print example From 966792b7671280a63d7f6283184ad6faf4240b41 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 9 May 2019 19:02:47 -0700 Subject: [PATCH 013/431] Implemented rub+cue and started on FromNoun+ToNoun. --- pkg/hair/lib/Data/Noun.hs | 60 ++++++++--- pkg/hair/lib/Data/Noun/Jam.hs | 62 ++++++++++++ pkg/hair/lib/Data/Noun/Poet.hs | 176 +++++++++++++++++++++++++++++++++ pkg/hair/package.yaml | 3 +- 4 files changed, 284 insertions(+), 17 deletions(-) create mode 100644 pkg/hair/lib/Data/Noun/Jam.hs create mode 100644 pkg/hair/lib/Data/Noun/Poet.hs diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs index d95d77201..82084d01d 100644 --- a/pkg/hair/lib/Data/Noun.hs +++ b/pkg/hair/lib/Data/Noun.hs @@ -1,45 +1,73 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Data.Noun where import Prelude + +import Control.Applicative +import Control.Monad import Numeric.Natural +import Data.Bits -import Data.List (intercalate) +import Data.List (intercalate) +import Data.Typeable (Typeable) + +import qualified Control.Monad.Fail as Fail --------------------------------------------------------------------------------- +-- Types ----------------------------------------------------------------------- type Atom = Natural -data Cell = CCell !Noun !Noun +data Cell = ACell !Noun !Noun + deriving (Eq, Ord) data Noun - = Atom !Natural + = Atom !Atom | Cell !Noun !Noun deriving (Eq, Ord) +data CellIdx = L | R + deriving (Eq, Ord, Show) --- Unboxed Atom Operations ----------------------------------------------------- +type NounPath = [CellIdx] -cell2List :: Cell -> [Noun] -cell2List = go [] - where - go acc (CCell x (Cell l r)) = go (x:acc) (CCell l r) - go acc (CCell x y@(Atom _)) = reverse (y:x:acc) -list2Noun :: [Noun] -> Noun -list2Noun [] = Atom 0 -list2Noun [x] = x -list2Noun (x:xs) = Cell x (list2Noun xs) +-- Instances ------------------------------------------------------------------- instance Show Noun where show (Atom a) = show a - show (Cell x y) = fmtCell (fmap show (cell2List (CCell x y))) + show (Cell x y) = fmtCell (show <$> (x : toTuple y)) where fmtCell :: [String] -> String fmtCell xs = "[" <> intercalate " " xs <> "]" + +-- Tuples ---------------------------------------------------------------------- + +fromTuple :: [Noun] -> Noun +fromTuple [] = Atom 0 +fromTuple [x] = x +fromTuple (x:xs) = Cell x (fromTuple xs) + +toTuple :: Noun -> [Noun] +toTuple (Cell x xs) = x : toTuple xs +toTuple atom = [atom] + + +-- Lists ----------------------------------------------------------------------- + +fromList :: [Noun] -> Noun +fromList [] = Atom 0 +fromList (x:xs) = Cell x (fromList xs) + +toList :: Noun -> Maybe [Noun] +toList (Atom 0) = Just [] +toList (Atom _) = Nothing +toList (Cell x xs) = (x:) <$> toList xs + example :: Noun -example = list2Noun [Atom 1337, Atom 1338, Atom 0] +example = fromTuple [Atom 1337, Atom 1338, Atom 0] exampleIO :: IO () exampleIO = do diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs new file mode 100644 index 000000000..a179eb616 --- /dev/null +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -0,0 +1,62 @@ +module Data.Noun.Jam where + +import ClassyPrelude +import Data.Noun +import Data.Noun.Poet +import Data.Bits +import Control.Lens + +import Data.Map (Map) +import Control.Monad (guard) + +-------------------------------------------------------------------------------- + +jam :: Noun -> Atom +jam = undefined + +bitWidth :: Atom -> Atom +bitWidth = undefined + +bitIdx :: Atom -> Atom -> Bool +bitIdx idx buf = testBit buf (fromIntegral idx) + +bitSlice :: Atom -> Atom -> Atom -> Atom +bitSlice idx sz buf = undefined + +data Slice = Slice { off :: Atom, buf :: Atom } + +leadingZeros :: Slice -> Maybe Atom +leadingZeros (Slice idx buf) = go 0 + where wid = bitWidth buf + go n = do guard (n < wid) + if bitIdx (idx+n) buf then pure n else go (n+1) + +rub :: Slice -> Maybe (Atom, Atom) +rub slc@(Slice idx buf) = + leadingZeros slc >>= \case + 0 -> pure (1, 0) + prefix -> pure (sz, val) + where + widIdx = idx + 1 + prefix + width = bitSlice widIdx (prefix - 1) buf + datIdx = widIdx + (prefix-1) + datWid = 2^(prefix-1) + width + sz = datWid + (2*prefix) + val = bitSlice datIdx datWid buf + +cue :: Atom -> Maybe Noun +cue buf = view _2 <$> go mempty 0 + where + go :: Map Atom Noun -> Atom -> Maybe (Atom, Noun, Map Atom Noun) + go tbl i = + case (bitIdx i buf, bitIdx (i+1) buf) of + (False, _ ) -> do (wid,at) <- rub (Slice (i+1) buf) + let r = toNoun at + pure (wid+1, r, insertMap i r tbl) + (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) + (rSz,rit,tbl) <- go tbl (i+2+lSz) + let r = Cell lef rit + pure (2+lSz+rSz, r, insertMap i r tbl) + (True, True ) -> do (wid,at) <- rub (Slice (i+2) buf) + r <- lookup at tbl + pure (2+wid, r, tbl) diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hair/lib/Data/Noun/Poet.hs new file mode 100644 index 000000000..59453ce1e --- /dev/null +++ b/pkg/hair/lib/Data/Noun/Poet.hs @@ -0,0 +1,176 @@ +module Data.Noun.Poet where + +import Prelude + +import Control.Applicative +import Control.Monad +import Numeric.Natural +import Data.Noun + +import Data.Word (Word, Word32, Word64) +import Data.List (intercalate) +import Data.Typeable (Typeable) + +import qualified Control.Monad.Fail as Fail + + +-- IResult --------------------------------------------------------------------- + +data IResult a = IError NounPath String | ISuccess a + deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) + +instance Applicative IResult where + pure = ISuccess + (<*>) = ap + +instance Fail.MonadFail IResult where + fail err = IError [] err + +instance Monad IResult where + return = pure + fail = Fail.fail + ISuccess a >>= k = k a + IError path err >>= _ = IError path err + +instance MonadPlus IResult where + mzero = fail "mzero" + mplus a@(ISuccess _) _ = a + mplus _ b = b + +instance Alternative IResult where + empty = mzero + (<|>) = mplus + +instance Semigroup (IResult a) where + (<>) = mplus + +instance Monoid (IResult a) where + mempty = fail "mempty" + mappend = (<>) + + +-- Result ---------------------------------------------------------------------- + +data Result a = Error String | Success a + deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) + +instance Applicative Result where + pure = Success + (<*>) = ap + +instance Fail.MonadFail Result where + fail err = Error err + +instance Monad Result where + return = pure + fail = Fail.fail + + Success a >>= k = k a + Error err >>= _ = Error err + +instance MonadPlus Result where + mzero = fail "mzero" + mplus a@(Success _) _ = a + mplus _ b = b + +instance Alternative Result where + empty = mzero + (<|>) = mplus + +instance Semigroup (Result a) where + (<>) = mplus + {-# INLINE (<>) #-} + +instance Monoid (Result a) where + mempty = fail "mempty" + mappend = (<>) + + +-- "Parser" -------------------------------------------------------------------- + +type Failure f r = NounPath -> String -> f r +type Success a f r = a -> f r + +newtype Parser a = Parser { + runParser :: forall f r. NounPath -> Failure f r -> Success a f r -> f r +} + +instance Monad Parser where + m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks + in runParser m path kf ks' + return = pure + fail = Fail.fail + +instance Fail.MonadFail Parser where + fail msg = Parser $ \path kf _ks -> kf (reverse path) msg + +instance Functor Parser where + fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a) + in runParser m path kf ks' + +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + b <$> e + +instance Applicative Parser where + pure a = Parser $ \_path _kf ks -> ks a + (<*>) = apP + +instance Alternative Parser where + empty = fail "empty" + (<|>) = mplus + +instance MonadPlus Parser where + mzero = fail "mzero" + mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks + in runParser a path kf' ks + +instance Semigroup (Parser a) where + (<>) = mplus + +instance Monoid (Parser a) where + mempty = fail "mempty" + mappend = (<>) + + +-- Conversion ------------------------------------------------------------------ + +class FromNoun a where + parseNoun :: Noun -> Parser a + +class ToNoun a where + toNoun :: a -> Noun + + +-- Atom Conversion ------------------------------------------------------------- + +instance ToNoun Word where + toNoun = Atom . fromIntegral + +instance ToNoun Word32 where + toNoun = Atom . fromIntegral + +instance ToNoun Word64 where + toNoun = Atom . fromIntegral + +instance ToNoun Natural where + toNoun = Atom + + +-- Cell Conversion ------------------------------------------------------------- + +instance (ToNoun a, ToNoun b) => ToNoun (a, b) where + toNoun (x, y) = Cell (toNoun x) (toNoun y) + +instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where + toNoun (x, y, z) = Cell (toNoun x) + $ Cell (toNoun y) (toNoun z) + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where + toNoun (x, y, z, a) = Cell (toNoun x) + $ Cell (toNoun y) + $ Cell (toNoun z) (toNoun a) + +instance ToNoun a => ToNoun [a] where + toNoun xs = fromList (toNoun <$> xs) diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 8e41ee3b2..54a89a8e1 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -61,6 +61,7 @@ default-extensions: - DeriveFoldable - DeriveGeneric - DeriveTraversable + - DeriveDataTypeable - EmptyDataDecls - FlexibleContexts - FlexibleInstances @@ -70,6 +71,7 @@ default-extensions: - MultiParamTypeClasses - NamedFieldPuns - NoImplicitPrelude + - NumericUnderscores - OverloadedStrings - PartialTypeSignatures - QuasiQuotes @@ -83,4 +85,3 @@ default-extensions: - TypeFamilies - UnicodeSyntax - ViewPatterns - - NumericUnderscores From b4b4d2ff7b9ac38edacd091537bd496fd7363214 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 9 May 2019 19:45:28 -0700 Subject: [PATCH 014/431] Implement bitWidth (for cue/rub). --- pkg/hair/lib/Data/Noun.hs | 4 +--- pkg/hair/lib/Data/Noun/Atom.hs | 27 +++++++++++++++++++++++++++ pkg/hair/lib/Data/Noun/Jam.hs | 4 +--- pkg/hair/lib/Data/Noun/Poet.hs | 2 +- pkg/hair/stack.yaml | 3 +++ 5 files changed, 33 insertions(+), 7 deletions(-) create mode 100644 pkg/hair/lib/Data/Noun/Atom.hs diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs index 82084d01d..f40d8e6df 100644 --- a/pkg/hair/lib/Data/Noun.hs +++ b/pkg/hair/lib/Data/Noun.hs @@ -6,7 +6,7 @@ import Prelude import Control.Applicative import Control.Monad -import Numeric.Natural +import Data.Noun.Atom import Data.Bits import Data.List (intercalate) @@ -17,8 +17,6 @@ import qualified Control.Monad.Fail as Fail -- Types ----------------------------------------------------------------------- -type Atom = Natural - data Cell = ACell !Noun !Noun deriving (Eq, Ord) diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs new file mode 100644 index 000000000..4fe0e20ec --- /dev/null +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MagicHash, GeneralizedNewtypeDeriving, UnboxedTuples #-} + +module Data.Noun.Atom where + +import ClassyPrelude +import Prelude ((^)) +import GHC.Integer.GMP.Internals +import GHC.Natural +import GHC.Prim +import GHC.Word + +newtype Atom = Atom Natural + deriving (Eq, Ord, Show, Num) + +wordBitWidth :: Word# -> Word# +wordBitWidth w = minusWord# 64## (clz# w) + +bigNatBitWidth :: BigNat -> Word# +bigNatBitWidth nat = + lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##) + where + (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1# + lswBits = wordBitWidth (indexBigNat# nat lastIdx) + +bitWidth :: Atom -> Atom +bitWidth (Atom (NatS# gl)) = Atom (NatS# (wordBitWidth gl)) +bitWidth (Atom (NatJ# bn)) = Atom (NatS# (bigNatBitWidth bn)) diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index a179eb616..4e3d23f76 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -2,6 +2,7 @@ module Data.Noun.Jam where import ClassyPrelude import Data.Noun +import Data.Noun.Atom import Data.Noun.Poet import Data.Bits import Control.Lens @@ -14,9 +15,6 @@ import Control.Monad (guard) jam :: Noun -> Atom jam = undefined -bitWidth :: Atom -> Atom -bitWidth = undefined - bitIdx :: Atom -> Atom -> Bool bitIdx idx buf = testBit buf (fromIntegral idx) diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hair/lib/Data/Noun/Poet.hs index 59453ce1e..0c1f4617d 100644 --- a/pkg/hair/lib/Data/Noun/Poet.hs +++ b/pkg/hair/lib/Data/Noun/Poet.hs @@ -4,7 +4,7 @@ import Prelude import Control.Applicative import Control.Monad -import Numeric.Natural +import GHC.Natural import Data.Noun import Data.Word (Word, Word32, Word64) diff --git a/pkg/hair/stack.yaml b/pkg/hair/stack.yaml index 289b16243..fc5a0abe2 100644 --- a/pkg/hair/stack.yaml +++ b/pkg/hair/stack.yaml @@ -3,5 +3,8 @@ resolver: lts-13.10 packages: - . +ghc-options: + vere: "-fobject-code" + extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 From 4e1b4eb8f761cb4a014b9b45c7f55ab3b915bc20 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 10 May 2019 14:59:45 -0700 Subject: [PATCH 015/431] Got `cue` working. --- pkg/hair/lib/Data/Noun.hs | 2 +- pkg/hair/lib/Data/Noun/Atom.hs | 67 +++++++++++++++++++++++++++++++--- pkg/hair/lib/Data/Noun/Jam.hs | 38 +++++++++---------- pkg/hair/lib/Data/Noun/Poet.hs | 13 +++++-- 4 files changed, 90 insertions(+), 30 deletions(-) diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs index f40d8e6df..8af9386f0 100644 --- a/pkg/hair/lib/Data/Noun.hs +++ b/pkg/hair/lib/Data/Noun.hs @@ -6,7 +6,7 @@ import Prelude import Control.Applicative import Control.Monad -import Data.Noun.Atom +import Data.Noun.Atom (Atom) import Data.Bits import Data.List (intercalate) diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index 4fe0e20ec..63f39a4e8 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -3,14 +3,40 @@ module Data.Noun.Atom where import ClassyPrelude -import Prelude ((^)) +import Control.Lens +-- import Prelude ((^)) import GHC.Integer.GMP.Internals import GHC.Natural import GHC.Prim import GHC.Word +import GHC.Int +import Data.Bits + +-------------------------------------------------------------------------------- newtype Atom = Atom Natural - deriving (Eq, Ord, Show, Num) + deriving (Eq, Ord, Num, Bits, Enum, Real, Integral) + +instance Show Atom where + show (Atom a) = show a + +data Cursor = Cursor + { _cOffset :: {-# UNPACK #-} !Int + , _cBuffer :: {-# UNPACK #-} !Atom + } + deriving (Eq, Ord, Show) + +data Slice = Slice + { _sOffset :: {-# UNPACK #-} !Int + , _sWidth :: {-# UNPACK #-} !Int + , _sBuffer :: {-# UNPACK #-} !Atom + } + deriving (Eq, Ord, Show) + +makeLenses ''Cursor +makeLenses ''Slice + +-------------------------------------------------------------------------------- wordBitWidth :: Word# -> Word# wordBitWidth w = minusWord# 64## (clz# w) @@ -22,6 +48,37 @@ bigNatBitWidth nat = (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1# lswBits = wordBitWidth (indexBigNat# nat lastIdx) -bitWidth :: Atom -> Atom -bitWidth (Atom (NatS# gl)) = Atom (NatS# (wordBitWidth gl)) -bitWidth (Atom (NatJ# bn)) = Atom (NatS# (bigNatBitWidth bn)) +bitWidth :: Atom -> Int +bitWidth (Atom (NatS# gl)) = I# (word2Int# (wordBitWidth gl)) +bitWidth (Atom (NatJ# bn)) = I# (word2Int# (bigNatBitWidth bn)) + + +-------------------------------------------------------------------------------- + +cursor :: Atom -> Atom -> Cursor +cursor offset buf = Cursor (fromIntegral offset) buf + +fromCursor :: Cursor -> Atom +fromCursor (Cursor off buf) = shiftR buf off + +bumpCursor :: Word -> Cursor -> Cursor +bumpCursor off = over cOffset (+ fromIntegral off) + + +-------------------------------------------------------------------------------- + +slice :: Atom -> Atom -> Atom -> Slice +slice offset size buf = Slice (fromIntegral offset) (fromIntegral size) buf + +fromSlice :: Slice -> Atom +fromSlice (Slice off wid buf) = mask .&. (shiftR buf off) + where mask = shiftL (Atom 1) wid - 1 + +-------------------------------------------------------------------------------- + +takeBits :: Atom -> Atom -> Atom +takeBits wid buf = mask .&. buf + where mask = shiftL (Atom 1) (fromIntegral wid) - 1 + +bitIdx :: Int -> Atom -> Bool +bitIdx idx buf = testBit buf (fromIntegral idx) diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index 4e3d23f76..0c276f3f8 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -15,46 +15,44 @@ import Control.Monad (guard) jam :: Noun -> Atom jam = undefined -bitIdx :: Atom -> Atom -> Bool -bitIdx idx buf = testBit buf (fromIntegral idx) - -bitSlice :: Atom -> Atom -> Atom -> Atom -bitSlice idx sz buf = undefined - -data Slice = Slice { off :: Atom, buf :: Atom } - -leadingZeros :: Slice -> Maybe Atom -leadingZeros (Slice idx buf) = go 0 +leadingZeros :: Cursor -> Maybe Int +leadingZeros (Cursor idx buf) = go 0 where wid = bitWidth buf go n = do guard (n < wid) if bitIdx (idx+n) buf then pure n else go (n+1) -rub :: Slice -> Maybe (Atom, Atom) -rub slc@(Slice idx buf) = +rub :: Cursor -> Maybe (Int, Atom) +rub slc@(Cursor idx buf) = leadingZeros slc >>= \case 0 -> pure (1, 0) prefix -> pure (sz, val) where widIdx = idx + 1 + prefix - width = bitSlice widIdx (prefix - 1) buf + width = fromSlice (Slice widIdx (prefix - 1) buf) datIdx = widIdx + (prefix-1) - datWid = 2^(prefix-1) + width + datWid = fromIntegral $ 2^(prefix-1) + width sz = datWid + (2*prefix) - val = bitSlice datIdx datWid buf + val = fromSlice (Slice datIdx datWid buf) cue :: Atom -> Maybe Noun cue buf = view _2 <$> go mempty 0 where - go :: Map Atom Noun -> Atom -> Maybe (Atom, Noun, Map Atom Noun) + go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun) go tbl i = case (bitIdx i buf, bitIdx (i+1) buf) of - (False, _ ) -> do (wid,at) <- rub (Slice (i+1) buf) + (False, _ ) -> do (wid,at) <- rub (Cursor (i+1) buf) let r = toNoun at pure (wid+1, r, insertMap i r tbl) (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) - (rSz,rit,tbl) <- go tbl (i+2+lSz) + (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) let r = Cell lef rit pure (2+lSz+rSz, r, insertMap i r tbl) - (True, True ) -> do (wid,at) <- rub (Slice (i+2) buf) - r <- lookup at tbl + (True, True ) -> do (wid,at) <- rub (Cursor (i+2) buf) + r <- lookup (fromIntegral at) tbl pure (2+wid, r, tbl) + +cueTest :: Maybe [Noun] +cueTest = + traverse cue [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 + , 0x3170_c7c1, 0x93_c7c1, 0x1bd5_b7dd_e080 + ] diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hair/lib/Data/Noun/Poet.hs index 0c1f4617d..d180ffa42 100644 --- a/pkg/hair/lib/Data/Noun/Poet.hs +++ b/pkg/hair/lib/Data/Noun/Poet.hs @@ -7,11 +7,13 @@ import Control.Monad import GHC.Natural import Data.Noun -import Data.Word (Word, Word32, Word64) -import Data.List (intercalate) -import Data.Typeable (Typeable) +import Data.List (intercalate) +import Data.Noun.Atom (Atom) +import Data.Typeable (Typeable) +import Data.Word (Word, Word32, Word64) import qualified Control.Monad.Fail as Fail +import qualified Data.Noun.Atom as Atom -- IResult --------------------------------------------------------------------- @@ -154,9 +156,12 @@ instance ToNoun Word32 where instance ToNoun Word64 where toNoun = Atom . fromIntegral -instance ToNoun Natural where +instance ToNoun Atom where toNoun = Atom +instance ToNoun Natural where + toNoun = toNoun . Atom.Atom + -- Cell Conversion ------------------------------------------------------------- From 91b1a8be4806c14794cd790fdf3f5f6c8355c4cb Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 13 May 2019 13:46:05 -0700 Subject: [PATCH 016/431] Notes --- pkg/hair/lib/Data/Noun/Atom.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index 63f39a4e8..0450f37ce 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -20,6 +20,9 @@ newtype Atom = Atom Natural instance Show Atom where show (Atom a) = show a +{- + An Atom with a bit-offset. +-} data Cursor = Cursor { _cOffset :: {-# UNPACK #-} !Int , _cBuffer :: {-# UNPACK #-} !Atom @@ -38,6 +41,10 @@ makeLenses ''Slice -------------------------------------------------------------------------------- +{- + TODO Support 32-bit archetectures. +-} + wordBitWidth :: Word# -> Word# wordBitWidth w = minusWord# 64## (clz# w) From de227b07a0716830180f332bfa12a86014eda1bd Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 14 May 2019 15:13:18 -0700 Subject: [PATCH 017/431] Implemented jam, but the tests don't pass yet. --- pkg/hair/lib/Data/Noun.hs | 21 +++++++- pkg/hair/lib/Data/Noun/Atom.hs | 54 +++++++++++++++---- pkg/hair/lib/Data/Noun/Jam.hs | 94 ++++++++++++++++++++++++++++++++-- pkg/hair/lib/Data/Noun/Poet.hs | 7 ++- pkg/hair/package.yaml | 3 +- 5 files changed, 156 insertions(+), 23 deletions(-) diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs index 8af9386f0..dc50e32ab 100644 --- a/pkg/hair/lib/Data/Noun.hs +++ b/pkg/hair/lib/Data/Noun.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Data.Noun where import Prelude @@ -8,6 +6,8 @@ import Control.Applicative import Control.Monad import Data.Noun.Atom (Atom) import Data.Bits +import GHC.Generics +import Test.QuickCheck.Arbitrary import Data.List (intercalate) import Data.Typeable (Typeable) @@ -40,6 +40,23 @@ instance Show Noun where fmtCell :: [String] -> String fmtCell xs = "[" <> intercalate " " xs <> "]" +instance Arbitrary Noun where + arbitrary = do + arbitrary >>= \case + True -> Atom <$> arbitrary + False -> Cell <$> (Atom <$> arbitrary) <*> (Atom <$> arbitrary) + + +-- Predicates ------------------------------------------------------------------ + +isAtom :: Noun -> Bool +isAtom (Atom _) = True +isAtom (Cell _ _) = False + +isCell :: Noun -> Bool +isCell (Atom _) = False +isCell (Cell _ _) = True + -- Tuples ---------------------------------------------------------------------- diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index 0450f37ce..5934fb5c0 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -11,14 +11,16 @@ import GHC.Prim import GHC.Word import GHC.Int import Data.Bits +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen -------------------------------------------------------------------------------- -newtype Atom = Atom Natural - deriving (Eq, Ord, Num, Bits, Enum, Real, Integral) +newtype Atom = MkAtom Natural + deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral) instance Show Atom where - show (Atom a) = show a + show (MkAtom a) = show a {- An Atom with a bit-offset. @@ -39,6 +41,28 @@ data Slice = Slice makeLenses ''Cursor makeLenses ''Slice + +-- Instances ------------------------------------------------------------------- + +instance Arbitrary Atom where + arbitrary = MkAtom . fromIntegral . abs <$> (arbitrary :: Gen Integer) + + +-- Conversion ------------------------------------------------------------------ + +class IsAtom a where + toAtom :: a -> Atom + fromAtom :: Atom -> a + +instance IsAtom Int where + toAtom = fromIntegral + fromAtom = fromIntegral + +instance IsAtom Natural where + toAtom = fromIntegral + fromAtom = fromIntegral + + -------------------------------------------------------------------------------- {- @@ -56,8 +80,8 @@ bigNatBitWidth nat = lswBits = wordBitWidth (indexBigNat# nat lastIdx) bitWidth :: Atom -> Int -bitWidth (Atom (NatS# gl)) = I# (word2Int# (wordBitWidth gl)) -bitWidth (Atom (NatJ# bn)) = I# (word2Int# (bigNatBitWidth bn)) +bitWidth (MkAtom (NatS# gl)) = I# (word2Int# (wordBitWidth gl)) +bitWidth (MkAtom (NatJ# bn)) = I# (word2Int# (bigNatBitWidth bn)) -------------------------------------------------------------------------------- @@ -74,18 +98,26 @@ bumpCursor off = over cOffset (+ fromIntegral off) -------------------------------------------------------------------------------- -slice :: Atom -> Atom -> Atom -> Slice -slice offset size buf = Slice (fromIntegral offset) (fromIntegral size) buf +slice :: (Atom, Atom) -> Atom -> Atom +slice (offset, size) buf = + fromSlice (Slice (fromAtom offset) (fromAtom size) buf) fromSlice :: Slice -> Atom fromSlice (Slice off wid buf) = mask .&. (shiftR buf off) - where mask = shiftL (Atom 1) wid - 1 + where mask = shiftL (MkAtom 1) wid - 1 + -------------------------------------------------------------------------------- -takeBits :: Atom -> Atom -> Atom +takeBits :: Int -> Atom -> Atom takeBits wid buf = mask .&. buf - where mask = shiftL (Atom 1) (fromIntegral wid) - 1 + where mask = shiftL (MkAtom 1) wid - 1 bitIdx :: Int -> Atom -> Bool -bitIdx idx buf = testBit buf (fromIntegral idx) +bitIdx idx buf = testBit buf idx + +bitConcat :: Atom -> Atom -> Atom +bitConcat x y = low .|. high + where + low = y + high = shiftL y (bitWidth x) diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index 0c276f3f8..c4c0ebd4c 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -10,11 +10,45 @@ import Control.Lens import Data.Map (Map) import Control.Monad (guard) +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck as QC +import Test.QuickCheck + -------------------------------------------------------------------------------- jam :: Noun -> Atom -jam = undefined +jam = view _2 . go 0 mempty + where + go :: Int -> Map Noun Int -> Noun -> (Int, Atom, Map Noun Int) + go idx tbl noun = + over _3 (insertMap noun idx) $ + case (lookup noun tbl, noun) of + (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) -> + (1+sz, shiftL res 1, tbl) + where (sz, res) = mat atm + (Just ref, _) -> + (2+sz, xor 3 (shiftL res 2), tbl) + where (sz, res) = mat (toAtom ref) + (Nothing, Atom atm) -> + (1+sz, shiftL res 1, tbl) + where (sz, res) = mat atm + (Nothing, Cell lef rit) -> + (2+lSz+rSz, xor 1 (shiftL (bitConcat lRes rRes) 2), rTbl) + where (lSz, lRes, lTbl) = go (idx+2) tbl lef + (rSz, rRes, rTbl) = go (idx+lSz) lTbl rit +mat :: Atom -> (Int, Atom) +mat 0 = (1, 1) +mat atm = (bufWid, buffer) + where + atmWid = bitWidth atm + preWid = bitWidth (toAtom atmWid) + bufWid = preWid + preWid + atmWid + prefix = 2 ^ toAtom preWid + suffix = xor (takeBits (preWid-1) $ toAtom bufWid) + (shiftL atm (preWid-1)) + buffer = bitConcat suffix prefix leadingZeros :: Cursor -> Maybe Int leadingZeros (Cursor idx buf) = go 0 where wid = bitWidth buf @@ -51,8 +85,58 @@ cue buf = view _2 <$> go mempty 0 r <- lookup (fromIntegral at) tbl pure (2+wid, r, tbl) +pills :: [Atom] +pills = [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 + , 0x3170_c7c1, 0x93_c7c1, 0x1bd5_b7dd_e080 + ] + cueTest :: Maybe [Noun] -cueTest = - traverse cue [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 - , 0x3170_c7c1, 0x93_c7c1, 0x1bd5_b7dd_e080 - ] +cueTest = traverse cue pills + +jamTest :: Maybe [Atom] +jamTest = fmap jam <$> cueTest + +prop_jamRoundTrip :: Noun -> Bool +prop_jamRoundTrip n = Just n == cue (jam n) + +main :: IO () +main = $(defaultMainGenerator) + +-- ?: =(0 a) +-- [1 1] +-- =+ b=(met 0 a) +-- =+ c=(met 0 b) +-- :- (add (add c c) b) +-- (cat 0 (bex c) (mix (end 0 (dec c) b) (lsh 0 (dec c) a))) + +-- |= a/@ +-- ^- {p/@ q/@} +-- ?: =(0 a) +-- [1 1] +-- =+ b=(met 0 a) +-- =+ c=(met 0 b) +-- :- (add (add c c) b) +-- (cat 0 (bex c) ) + +-- ++ jam +-- |= a/* +-- ^- @ +-- =+ b=0 +-- =+ m=`(map * @)`~ +-- =< q +-- |- ^- {p/@ q/@ r/(map * @)} +-- =+ c=(~(get by m) a) +-- ?~ c +-- => .(m (~(put by m) a b)) +-- ?: ?=(@ a) +-- =+ d=(mat a) +-- [(add 1 p.d) (lsh 0 1 q.d) m] +-- => .(b (add 2 b)) +-- =+ d=$(a -.a) +-- =+ e=$(a +.a, b (add b p.d), m r.d) +-- [(add 2 (add p.d p.e)) (mix 1 (lsh 0 2 (cat 0 q.d q.e))) r.e] +-- ?: ?&(?=(@ a) (lte (met 0 a) (met 0 u.c))) +-- =+ d=(mat a) +-- [(add 1 p.d) (lsh 0 1 q.d) m] +-- =+ d=(mat u.c) +-- [(add 2 p.d) (mix 3 (lsh 0 2 q.d)) m] diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hair/lib/Data/Noun/Poet.hs index d180ffa42..5e1f80c45 100644 --- a/pkg/hair/lib/Data/Noun/Poet.hs +++ b/pkg/hair/lib/Data/Noun/Poet.hs @@ -4,16 +4,15 @@ import Prelude import Control.Applicative import Control.Monad -import GHC.Natural import Data.Noun +import Data.Noun.Atom +import GHC.Natural import Data.List (intercalate) -import Data.Noun.Atom (Atom) import Data.Typeable (Typeable) import Data.Word (Word, Word32, Word64) import qualified Control.Monad.Fail as Fail -import qualified Data.Noun.Atom as Atom -- IResult --------------------------------------------------------------------- @@ -160,7 +159,7 @@ instance ToNoun Atom where toNoun = Atom instance ToNoun Natural where - toNoun = toNoun . Atom.Atom + toNoun = toNoun . toAtom -- Cell Conversion ------------------------------------------------------------- diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 54a89a8e1..caf027e58 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -58,10 +58,11 @@ default-extensions: - ApplicativeDo - BangPatterns - BlockArguments + - DeriveDataTypeable - DeriveFoldable - DeriveGeneric - DeriveTraversable - - DeriveDataTypeable + - DerivingStrategies - EmptyDataDecls - FlexibleContexts - FlexibleInstances From 805e954980cbfbc14a85ca1b2e7002a43b741488 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 14 May 2019 18:30:44 -0700 Subject: [PATCH 018/431] Got jam/cue fully working and tested. --- pkg/hair/lib/Data/Noun.hs | 15 +++++-- pkg/hair/lib/Data/Noun/Atom.hs | 16 ++++--- pkg/hair/lib/Data/Noun/Jam.hs | 82 +++++++++++++++++++++------------- pkg/hair/lib/Data/Noun/Zip.hs | 66 +++++++++++++++++++++++++++ pkg/hair/package.yaml | 1 + 5 files changed, 139 insertions(+), 41 deletions(-) create mode 100644 pkg/hair/lib/Data/Noun/Zip.hs diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs index dc50e32ab..f26f4dfee 100644 --- a/pkg/hair/lib/Data/Noun.hs +++ b/pkg/hair/lib/Data/Noun.hs @@ -8,6 +8,8 @@ import Data.Noun.Atom (Atom) import Data.Bits import GHC.Generics import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Debug.Trace import Data.List (intercalate) import Data.Typeable (Typeable) @@ -41,10 +43,15 @@ instance Show Noun where fmtCell xs = "[" <> intercalate " " xs <> "]" instance Arbitrary Noun where - arbitrary = do - arbitrary >>= \case - True -> Atom <$> arbitrary - False -> Cell <$> (Atom <$> arbitrary) <*> (Atom <$> arbitrary) + arbitrary = resize 12 genNoun + where + genNoun = do + sz <- getSize + bit <- arbitrary + case (sz, bit) of + ( 0, _ ) -> Atom <$> arbitrary + ( _, False ) -> Atom <$> arbitrary + ( _, True ) -> scale pred (Cell <$> genNoun <*> genNoun) -- Predicates ------------------------------------------------------------------ diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index 5934fb5c0..0e7931140 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -44,8 +44,11 @@ makeLenses ''Slice -- Instances ------------------------------------------------------------------- +instance Arbitrary Natural where + arbitrary = fromInteger . abs <$> arbitrary + instance Arbitrary Atom where - arbitrary = MkAtom . fromIntegral . abs <$> (arbitrary :: Gen Integer) + arbitrary = MkAtom <$> arbitrary -- Conversion ------------------------------------------------------------------ @@ -54,11 +57,15 @@ class IsAtom a where toAtom :: a -> Atom fromAtom :: Atom -> a +instance IsAtom Natural where + toAtom = MkAtom + fromAtom (MkAtom a) = a + instance IsAtom Int where toAtom = fromIntegral fromAtom = fromIntegral -instance IsAtom Natural where +instance IsAtom Integer where toAtom = fromIntegral fromAtom = fromIntegral @@ -117,7 +124,4 @@ bitIdx :: Int -> Atom -> Bool bitIdx idx buf = testBit buf idx bitConcat :: Atom -> Atom -> Atom -bitConcat x y = low .|. high - where - low = y - high = shiftL y (bitWidth x) +bitConcat x y = x .|. shiftL y (bitWidth x) diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index c4c0ebd4c..ac6966831 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -6,6 +6,7 @@ import Data.Noun.Atom import Data.Noun.Poet import Data.Bits import Control.Lens +import Text.Printf import Data.Map (Map) import Control.Monad (guard) @@ -15,15 +16,48 @@ import Test.Tasty.TH import Test.Tasty.QuickCheck as QC import Test.QuickCheck --------------------------------------------------------------------------------- + +-- Length-Encoded Atoms -------------------------------------------------------- + +mat :: Atom -> (Int, Atom) +mat 0 = (1, 1) +mat atm = (bufWid, buffer) + where + atmWid = bitWidth atm + preWid = bitWidth (toAtom atmWid) + bufWid = preWid + preWid + atmWid + prefix = shiftL 1 preWid + extras = takeBits (preWid-1) $ toAtom atmWid + suffix = xor extras (shiftL atm (preWid-1)) + buffer = bitConcat prefix suffix + +rub :: Cursor -> Maybe (Int, Atom) +rub slc@(Cursor idx buf) = + leadingZeros slc >>= \case + 0 -> pure (1, 0) + prefix -> pure (sz, val) + where + widIdx = idx + 1 + prefix + width = fromSlice (Slice widIdx (prefix - 1) buf) + datIdx = widIdx + (prefix-1) + datWid = fromIntegral $ 2^(prefix-1) + width + sz = datWid + (2*prefix) + val = fromSlice (Slice datIdx datWid buf) + + +-- Noun Serialization ---------------------------------------------------------- jam :: Noun -> Atom jam = view _2 . go 0 mempty where + insertNoun :: Noun -> Int -> Map Noun Int -> Map Noun Int + insertNoun n i tbl = lookup n tbl + & maybe tbl (const $ insertMap n i tbl) + go :: Int -> Map Noun Int -> Noun -> (Int, Atom, Map Noun Int) - go idx tbl noun = - over _3 (insertMap noun idx) $ - case (lookup noun tbl, noun) of + go idx oldTbl noun = + let tbl = insertNoun noun idx oldTbl in + case (Nothing :: Maybe Int, noun) of (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) -> (1+sz, shiftL res 1, tbl) where (sz, res) = mat atm @@ -38,36 +72,13 @@ jam = view _2 . go 0 mempty where (lSz, lRes, lTbl) = go (idx+2) tbl lef (rSz, rRes, rTbl) = go (idx+lSz) lTbl rit -mat :: Atom -> (Int, Atom) -mat 0 = (1, 1) -mat atm = (bufWid, buffer) - where - atmWid = bitWidth atm - preWid = bitWidth (toAtom atmWid) - bufWid = preWid + preWid + atmWid - prefix = 2 ^ toAtom preWid - suffix = xor (takeBits (preWid-1) $ toAtom bufWid) - (shiftL atm (preWid-1)) - buffer = bitConcat suffix prefix + leadingZeros :: Cursor -> Maybe Int leadingZeros (Cursor idx buf) = go 0 where wid = bitWidth buf go n = do guard (n < wid) if bitIdx (idx+n) buf then pure n else go (n+1) -rub :: Cursor -> Maybe (Int, Atom) -rub slc@(Cursor idx buf) = - leadingZeros slc >>= \case - 0 -> pure (1, 0) - prefix -> pure (sz, val) - where - widIdx = idx + 1 + prefix - width = fromSlice (Slice widIdx (prefix - 1) buf) - datIdx = widIdx + (prefix-1) - datWid = fromIntegral $ 2^(prefix-1) + width - sz = datWid + (2*prefix) - val = fromSlice (Slice datIdx datWid buf) - cue :: Atom -> Maybe Noun cue buf = view _2 <$> go mempty 0 where @@ -85,9 +96,12 @@ cue buf = view _2 <$> go mempty 0 r <- lookup (fromIntegral at) tbl pure (2+wid, r, tbl) + +-- Tests ----------------------------------------------------------------------- + pills :: [Atom] pills = [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 - , 0x3170_c7c1, 0x93_c7c1, 0x1bd5_b7dd_e080 + , 0x3170_c7c1, 0x93_c7c1, 0xa_72e0, 0x1bd5_b7dd_e080 ] cueTest :: Maybe [Noun] @@ -96,8 +110,14 @@ cueTest = traverse cue pills jamTest :: Maybe [Atom] jamTest = fmap jam <$> cueTest -prop_jamRoundTrip :: Noun -> Bool -prop_jamRoundTrip n = Just n == cue (jam n) +prop_jamCue :: Noun -> Bool +prop_jamCue n = Just n == cue (jam n) + +prop_matRub :: Atom -> Bool +prop_matRub atm = matSz==rubSz && rubRes==atm + where + (matSz, matBuf) = mat atm + (rubSz, rubRes) = fromMaybe (0,0) (rub $ Cursor 0 matBuf) main :: IO () main = $(defaultMainGenerator) diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs new file mode 100644 index 000000000..9eafaede4 --- /dev/null +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -0,0 +1,66 @@ +{- + Can de-duplication be orthogonal to serialization? +-} + +module Data.Noun.Zip where + +import ClassyPrelude + +import Control.Applicative +import Control.Monad +import Data.Noun +import Data.Noun.Atom +import Data.Bits +import GHC.Generics +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Debug.Trace + +import Data.List (intercalate) +import Data.Typeable (Typeable) + +import Control.Monad.State.Strict + + +-- External Types -------------------------------------------------------------- + +newtype Zip = Zip [ZipNode] + deriving newtype (Eq, Ord, Show) + + +-- Internal Types -------------------------------------------------------------- + +data ZipNode + = ZipAtom !Atom + | ZipCell !Word !Word + deriving (Eq, Ord, Show) + +type ZipM a = State ([ZipNode], Word, Map Noun Word) a + + +-------------------------------------------------------------------------------- + +zip :: Noun -> Zip +zip = \n -> evalState (go n >> end) ([], 0, mempty) + where + end :: ZipM Zip + end = do + (acc, _, _) <- get + pure (Zip $ reverse acc) + + ins :: Noun -> ZipNode -> ZipM Word + ins noun node = do + (acc, nex, tbl) <- get + put (node:acc, nex+1, insertMap noun nex tbl) + pure nex + + go :: Noun -> ZipM Word + go noun = do + (acc, nex, tbl) <- get + case (lookup noun tbl, noun) of + (Just w, _) -> pure w + (Nothing, Atom atm) -> ins noun (ZipAtom atm) + (Nothing, Cell l r) -> (ZipCell <$> go l <*> go r) >>= ins noun + +unzip :: Zip -> Maybe Noun +unzip = undefined diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index caf027e58..0c9dd119b 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -56,6 +56,7 @@ dependencies: default-extensions: - ApplicativeDo + - GeneralizedNewtypeDeriving - BangPatterns - BlockArguments - DeriveDataTypeable From 90470dc67d30c0198546891b2611b43d27e6fa74 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 14 May 2019 22:09:53 -0700 Subject: [PATCH 019/431] Various fixes and improvements. --- pkg/hair/lib/Data/Noun/Atom.hs | 25 +++++++++ pkg/hair/lib/Data/Noun/Jam.hs | 95 ++++++++++------------------------ pkg/hair/lib/Data/Noun/Zip.hs | 88 +++++++++++++++++++++++++++---- pkg/hair/package.yaml | 1 + 4 files changed, 133 insertions(+), 76 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index 0e7931140..0b88a1073 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -13,6 +13,7 @@ import GHC.Int import Data.Bits import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen +import Text.Printf -------------------------------------------------------------------------------- @@ -61,6 +62,10 @@ instance IsAtom Natural where toAtom = MkAtom fromAtom (MkAtom a) = a +instance IsAtom Word where + toAtom = fromIntegral + fromAtom = fromIntegral + instance IsAtom Int where toAtom = fromIntegral fromAtom = fromIntegral @@ -125,3 +130,23 @@ bitIdx idx buf = testBit buf idx bitConcat :: Atom -> Atom -> Atom bitConcat x y = x .|. shiftL y (bitWidth x) + + +-- Bit Buffers ----------------------------------------------------------------- + +data Buf = Buf !Int !Atom + +instance Show Buf where + show (Buf sz bits) = "0b" + <> replicate (sz - bitWidth bits) '0' + <> printf "%b (%d bits)" (toInteger bits) sz + +instance Semigroup Buf where + Buf xSz xBuf <> Buf ySz yBuf = Buf (xSz+ySz) (xBuf .|. shiftL yBuf xSz) + +instance Monoid Buf where + mempty = Buf 0 0 + +instance IsAtom Buf where + toAtom (Buf _ bits) = bits + fromAtom bits = Buf (bitWidth bits) bits diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index ac6966831..cf6e2205b 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -19,23 +19,23 @@ import Test.QuickCheck -- Length-Encoded Atoms -------------------------------------------------------- -mat :: Atom -> (Int, Atom) -mat 0 = (1, 1) -mat atm = (bufWid, buffer) +mat :: Atom -> Buf +mat 0 = Buf 1 1 +mat atm = Buf bufWid buffer where atmWid = bitWidth atm preWid = bitWidth (toAtom atmWid) bufWid = preWid + preWid + atmWid prefix = shiftL 1 preWid - extras = takeBits (preWid-1) $ toAtom atmWid + extras = takeBits (preWid-1) (toAtom atmWid) suffix = xor extras (shiftL atm (preWid-1)) buffer = bitConcat prefix suffix -rub :: Cursor -> Maybe (Int, Atom) +rub :: Cursor -> Maybe Buf rub slc@(Cursor idx buf) = leadingZeros slc >>= \case - 0 -> pure (1, 0) - prefix -> pure (sz, val) + 0 -> pure (Buf 1 0) + prefix -> pure (Buf sz val) where widIdx = idx + 1 + prefix width = fromSlice (Slice widIdx (prefix - 1) buf) @@ -48,29 +48,29 @@ rub slc@(Cursor idx buf) = -- Noun Serialization ---------------------------------------------------------- jam :: Noun -> Atom -jam = view _2 . go 0 mempty +jam = toAtom . fst . go 0 mempty where insertNoun :: Noun -> Int -> Map Noun Int -> Map Noun Int insertNoun n i tbl = lookup n tbl & maybe tbl (const $ insertMap n i tbl) - go :: Int -> Map Noun Int -> Noun -> (Int, Atom, Map Noun Int) - go idx oldTbl noun = - let tbl = insertNoun noun idx oldTbl in + go :: Int -> Map Noun Int -> Noun -> (Buf, Map Noun Int) + go off oldTbl noun = + let tbl = insertNoun noun off oldTbl in case (Nothing :: Maybe Int, noun) of - (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) -> - (1+sz, shiftL res 1, tbl) - where (sz, res) = mat atm - (Just ref, _) -> - (2+sz, xor 3 (shiftL res 2), tbl) - where (sz, res) = mat (toAtom ref) - (Nothing, Atom atm) -> - (1+sz, shiftL res 1, tbl) - where (sz, res) = mat atm - (Nothing, Cell lef rit) -> - (2+lSz+rSz, xor 1 (shiftL (bitConcat lRes rRes) 2), rTbl) - where (lSz, lRes, lTbl) = go (idx+2) tbl lef - (rSz, rRes, rTbl) = go (idx+lSz) lTbl rit + (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) -> + (Buf (1+sz) (shiftL res 1), tbl) + where Buf sz res = mat atm + (Just ref, _) -> + (Buf (2+sz) (xor 3 (shiftL res 2)), tbl) + where Buf sz res = mat (toAtom ref) + (Nothing, Atom atm) -> + (Buf (1+sz) (shiftL res 1), tbl) + where Buf sz res = mat atm + (Nothing, Cell lef rit) -> + (Buf (2+lSz+rSz) (xor 1 (shiftL (bitConcat lRes rRes) 2)), rTbl) + where (Buf lSz lRes, lTbl) = go (off+2) tbl lef + (Buf rSz rRes, rTbl) = go (off+lSz) lTbl rit leadingZeros :: Cursor -> Maybe Int @@ -85,14 +85,14 @@ cue buf = view _2 <$> go mempty 0 go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun) go tbl i = case (bitIdx i buf, bitIdx (i+1) buf) of - (False, _ ) -> do (wid,at) <- rub (Cursor (i+1) buf) + (False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf) let r = toNoun at pure (wid+1, r, insertMap i r tbl) (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) let r = Cell lef rit pure (2+lSz+rSz, r, insertMap i r tbl) - (True, True ) -> do (wid,at) <- rub (Cursor (i+2) buf) + (True, True ) -> do Buf wid at <- rub (Cursor (i+2) buf) r <- lookup (fromIntegral at) tbl pure (2+wid, r, tbl) @@ -116,47 +116,8 @@ prop_jamCue n = Just n == cue (jam n) prop_matRub :: Atom -> Bool prop_matRub atm = matSz==rubSz && rubRes==atm where - (matSz, matBuf) = mat atm - (rubSz, rubRes) = fromMaybe (0,0) (rub $ Cursor 0 matBuf) + Buf matSz matBuf = mat atm + Buf rubSz rubRes = fromMaybe mempty (rub $ Cursor 0 matBuf) main :: IO () main = $(defaultMainGenerator) - --- ?: =(0 a) --- [1 1] --- =+ b=(met 0 a) --- =+ c=(met 0 b) --- :- (add (add c c) b) --- (cat 0 (bex c) (mix (end 0 (dec c) b) (lsh 0 (dec c) a))) - --- |= a/@ --- ^- {p/@ q/@} --- ?: =(0 a) --- [1 1] --- =+ b=(met 0 a) --- =+ c=(met 0 b) --- :- (add (add c c) b) --- (cat 0 (bex c) ) - --- ++ jam --- |= a/* --- ^- @ --- =+ b=0 --- =+ m=`(map * @)`~ --- =< q --- |- ^- {p/@ q/@ r/(map * @)} --- =+ c=(~(get by m) a) --- ?~ c --- => .(m (~(put by m) a b)) --- ?: ?=(@ a) --- =+ d=(mat a) --- [(add 1 p.d) (lsh 0 1 q.d) m] --- => .(b (add 2 b)) --- =+ d=$(a -.a) --- =+ e=$(a +.a, b (add b p.d), m r.d) --- [(add 2 (add p.d p.e)) (mix 1 (lsh 0 2 (cat 0 q.d q.e))) r.e] --- ?: ?&(?=(@ a) (lte (met 0 a) (met 0 u.c))) --- =+ d=(mat a) --- [(add 1 p.d) (lsh 0 1 q.d) m] --- =+ d=(mat u.c) --- [(add 2 p.d) (mix 3 (lsh 0 2 q.d)) m] diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs index 9eafaede4..8ddaca3f1 100644 --- a/pkg/hair/lib/Data/Noun/Zip.hs +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -4,27 +4,37 @@ module Data.Noun.Zip where -import ClassyPrelude +import ClassyPrelude hiding (zip, unzip) +import Control.Lens +import Text.Printf import Control.Applicative -import Control.Monad import Data.Noun import Data.Noun.Atom +import Data.Noun.Jam import Data.Bits import GHC.Generics import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen -import Debug.Trace import Data.List (intercalate) import Data.Typeable (Typeable) -import Control.Monad.State.Strict +import Control.Monad.State.Strict hiding (forM_) +import Control.Monad.Trans.Maybe + +import qualified Data.Vector as V +import qualified Data.List as L + +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck as QC +import Test.QuickCheck -- External Types -------------------------------------------------------------- -newtype Zip = Zip [ZipNode] +newtype Zip = Zip (Vector ZipNode) deriving newtype (Eq, Ord, Show) @@ -35,18 +45,37 @@ data ZipNode | ZipCell !Word !Word deriving (Eq, Ord, Show) -type ZipM a = State ([ZipNode], Word, Map Noun Word) a - -------------------------------------------------------------------------------- +tag :: Bool -> Buf -> Buf +tag bit buf = (if bit then Buf 1 1 else Buf 1 0) <> buf + +jamZipNode :: ZipNode -> Buf +jamZipNode (ZipAtom a) = tag False (mat a) +jamZipNode (ZipCell l r) = tag True (mat (toAtom l) <> mat (toAtom r)) + +jamZip :: Zip -> Buf +jamZip (Zip vec) = fold (length : nodes) + where + length = mat (toAtom (V.length vec)) + nodes = jamZipNode <$> V.toList vec + +cueZip :: Buf -> Maybe Zip +cueZip = undefined + + +-- Zip ------------------------------------------------------------------------- + +type ZipM a = State ([ZipNode], Word, Map Noun Word) a + zip :: Noun -> Zip zip = \n -> evalState (go n >> end) ([], 0, mempty) where end :: ZipM Zip end = do (acc, _, _) <- get - pure (Zip $ reverse acc) + pure (Zip $ V.fromList $ reverse acc) ins :: Noun -> ZipNode -> ZipM Word ins noun node = do @@ -62,5 +91,46 @@ zip = \n -> evalState (go n >> end) ([], 0, mempty) (Nothing, Atom atm) -> ins noun (ZipAtom atm) (Nothing, Cell l r) -> (ZipCell <$> go l <*> go r) >>= ins noun + +-- Unzip ----------------------------------------------------------------------- + +type UnZipM a = MaybeT (State (Word, Map Word Noun)) a + unzip :: Zip -> Maybe Noun -unzip = undefined +unzip (Zip vec) | V.length vec == 0 = Nothing +unzip (Zip vec) = + L.last <$> cvt (V.toList vec) + where + cvt :: [ZipNode] -> Maybe [Noun] + cvt nodes = evalState (runMaybeT $ go nodes) (0, mempty) + + ins :: Noun -> UnZipM Noun + ins noun = do + modify $ \(nex, tbl) -> (nex+1, insertMap nex noun tbl) + pure noun + + find :: Word -> UnZipM Noun + find idx = do + (nex, tbl) <- get + lookup idx tbl & \case + Nothing -> error "bad zip" + Just res -> pure res + + go :: [ZipNode] -> UnZipM [Noun] + go = mapM $ \case ZipAtom a -> ins (Atom a) + ZipCell l r -> ins =<< Cell <$> find l <*> find r + + +-- Tests ----------------------------------------------------------------------- + +compareSize :: Noun -> (Int, Int) +compareSize n = (jamSz, zipSz) + where + Buf jamSz _ = fromAtom (jam n) + Buf zipSz _ = jamZip (zip n) + +prop_zipUnzip :: Noun -> Bool +prop_zipUnzip n = Just n == unzip (zip n) + +main :: IO () +main = $(defaultMainGenerator) diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 0c9dd119b..ea9deca09 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -51,6 +51,7 @@ dependencies: - text - these - time + - transformers - unordered-containers - vector From 7dfc6b9c19b5a8de069deaeef9700e2d0f8b47fc Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Wed, 15 May 2019 17:00:10 -0700 Subject: [PATCH 020/431] Working out the datatypes. --- pkg/hair/lib/Vere.hs | 26 ++++++++++++++++++++++ pkg/hair/lib/Vere/Http.hs | 37 ++++++++++++++++++++++++++++++++ pkg/hair/lib/Vere/Http/Client.hs | 12 +++++++++++ pkg/hair/lib/Vere/Http/Server.hs | 35 ++++++++++++++++++++++++++++++ 4 files changed, 110 insertions(+) create mode 100644 pkg/hair/lib/Vere.hs create mode 100644 pkg/hair/lib/Vere/Http.hs create mode 100644 pkg/hair/lib/Vere/Http/Client.hs create mode 100644 pkg/hair/lib/Vere/Http/Server.hs diff --git a/pkg/hair/lib/Vere.hs b/pkg/hair/lib/Vere.hs new file mode 100644 index 000000000..9d5ba5a9f --- /dev/null +++ b/pkg/hair/lib/Vere.hs @@ -0,0 +1,26 @@ +module Vere where + +import ClassyPrelude +import Data.Void +import qualified Vere.Http.Server as Server +import qualified Vere.Http.Client as Client + +-- +vere ----------------------------------------------------------------------- + +data WTFIsThis + = WTFIsThis (Maybe Varience) TheActualFuckingThing + +data Varience = Gold | Iron | Lead + +data TheActualFuckingThing + = HttpServer Server.Eff + | HttpClient Client.Eff + | Behn Void + | Clay Void + | Boat Void + | Sync Void + | Newt Void + | Ames Void + | Init Void + | Term Void + diff --git a/pkg/hair/lib/Vere/Http.hs b/pkg/hair/lib/Vere/Http.hs new file mode 100644 index 000000000..7862152ca --- /dev/null +++ b/pkg/hair/lib/Vere/Http.hs @@ -0,0 +1,37 @@ +-- zuse: +http ----------------------------------------------------------------- + +module Vere.Http where + +import ClassyPrelude +import Data.Noun + +data Header = Header Text Text + +data Method = CONNECT + | DELETE + | GET + | HEAD + | OPTIONS + | POST + | PUT + | TRACE + deriving (Eq,Ord,Show) + +data Request = Request + { method :: Method + , url :: Text + , headerList :: [Header] + , body :: Maybe ByteString + } + +data ResponseHeader = ResponseHeader + { statusCode :: Integer + , headers :: [Header] + } + +data Event = Start ResponseHeader (Maybe ByteString) Bool + | Continue (Maybe ByteString) Bool + | Cancel + +--instance FromNoun Event where +-- fromNoun = undefined diff --git a/pkg/hair/lib/Vere/Http/Client.hs b/pkg/hair/lib/Vere/Http/Client.hs new file mode 100644 index 000000000..a36040aa3 --- /dev/null +++ b/pkg/hair/lib/Vere/Http/Client.hs @@ -0,0 +1,12 @@ +-- +http-client ---------------------------------------------------------------- + +module Vere.Http.Client where + +import ClassyPrelude +import Vere.Http + +-- | An http client effect is either requesting outbound, or canceling an old +-- outbound connection. +data Eff + = Request Word Request + | CancelRequest Word diff --git a/pkg/hair/lib/Vere/Http/Server.hs b/pkg/hair/lib/Vere/Http/Server.hs new file mode 100644 index 000000000..0978672f8 --- /dev/null +++ b/pkg/hair/lib/Vere/Http/Server.hs @@ -0,0 +1,35 @@ +-- +http-server ---------------------------------------------------------------- + +module Vere.Http.Server where + +import ClassyPrelude +import Vere.Http + +type ServerId = Word +type ConnectionId = Word +type RequestId = Word + +data Eff = Eff ServerId ConnectionId RequestId ServerRequest + +-- | An http server effect is configuration, or it sends an outbound response +data ServerRequest + = SetConfig Config + | Response Event + +data Config = Config + { secure :: Maybe (Key, Cert) + , proxy :: Bool + , log :: Bool + , redirect :: Bool + } + +newtype Key = Key Wain +newtype Cert = Cert Wain +data Wain = Wain [Text] + +data ClientResponse + = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString) + | Finished ResponseHeader (Maybe MimeData) + | Cancel + +data MimeData = MimeData Text ByteString From f1d8dda6ca32c2998d8ef70a0e5a491795e04eae Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Wed, 15 May 2019 17:04:21 -0700 Subject: [PATCH 021/431] Note about certificates. --- pkg/hair/lib/Vere/Http/Server.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/pkg/hair/lib/Vere/Http/Server.hs b/pkg/hair/lib/Vere/Http/Server.hs index 0978672f8..fc2c89a57 100644 --- a/pkg/hair/lib/Vere/Http/Server.hs +++ b/pkg/hair/lib/Vere/Http/Server.hs @@ -23,10 +23,14 @@ data Config = Config , redirect :: Bool } -newtype Key = Key Wain -newtype Cert = Cert Wain +-- Note: We need to parse PEM-encoded RSA private keys and cert or cert chain +-- from Wain +newtype Key = Key PEM +newtype Cert = Cert PEM data Wain = Wain [Text] +data PEM + data ClientResponse = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString) | Finished ResponseHeader (Maybe MimeData) From 971f21d6349480365c21dd2dc7cc9f0fa9447036 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Thu, 16 May 2019 17:05:34 -0700 Subject: [PATCH 022/431] Skeleton of http client operations. --- pkg/hair/lib/Vere/Http/Client.hs | 72 +++++++++++++++++++++++++++++++- pkg/hair/package.yaml | 1 + 2 files changed, 71 insertions(+), 2 deletions(-) diff --git a/pkg/hair/lib/Vere/Http/Client.hs b/pkg/hair/lib/Vere/Http/Client.hs index a36040aa3..196e20d60 100644 --- a/pkg/hair/lib/Vere/Http/Client.hs +++ b/pkg/hair/lib/Vere/Http/Client.hs @@ -3,10 +3,78 @@ module Vere.Http.Client where import ClassyPrelude -import Vere.Http +import Data.Void +import qualified Vere.Http as Http +import Control.Concurrent hiding (newEmptyMVar, putMVar) + +import Network.HTTP.Client as H -- | An http client effect is either requesting outbound, or canceling an old -- outbound connection. data Eff - = Request Word Request + = Request Word Http.Request | CancelRequest Word + +data Ev + = Receive Word Http.Event + +-- | All live requests +data State = State H.Manager (TVar (Map Word ThreadId)) (MVar Ev) + +initState :: IO State +initState = do + manager <- H.newManager defaultManagerSettings + liveReqs <- newTVarIO mempty + channels <- newEmptyMVar + pure (State manager liveReqs channels) + + +emitEvent :: State -> Ev -> IO () +emitEvent (State _ _ chan) event = + putMVar chan event + +run :: State -> Eff -> IO () +run st@(State manager s _) (Request id request) = do + -- TODO: Handle case where id is already live + x <- startHTTP st id request + atomically $ modifyTVar s (insertMap id x) + +run st@(State manager s _) (CancelRequest id) = + join $ atomically $ do + m <- readTVar s + case lookup id m of + Nothing -> pure (pure ()) + Just r -> do + m <- writeTVar s (deleteMap id m) + pure (cancelHTTP st id r) + + +startHTTP :: State -> Word -> Http.Request -> IO ThreadId +startHTTP st@(State manager _ chan) id request = forkIO $ do + withResponse (convertRequest request) manager $ \response -> do + let headers = convertResponseHeaders response + emitEvent st (Receive id (Http.Start headers Nothing False)) + readChunks (H.responseBody response) + where + readChunks :: H.BodyReader -> IO () + readChunks reader = do + chunk <- H.brRead reader + if null chunk + then emitEvent st (Receive id (Http.Continue Nothing True)) + else do + emitEvent st (Receive id (Http.Continue (Just chunk) False)) + readChunks reader + + +convertRequest :: Http.Request -> H.Request +convertRequest = undefined + +convertResponseHeaders :: H.Response a -> Http.ResponseHeader +convertResponseHeaders response = undefined + +cancelHTTP :: State -> Word -> ThreadId -> IO () +cancelHTTP st requestId threadId = do + -- There's a race condition here because threadId could have already + -- finished. + killThread threadId + emitEvent st (Receive requestId (Http.Cancel)) diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index ea9deca09..a1d5ceae7 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -32,6 +32,7 @@ dependencies: - containers - data-fix - ghc-prim + - http-client - integer-gmp - largeword - lens From fc6f3028e25e7232f849dbec970cf1b1573ee755 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 16 May 2019 18:25:58 -0700 Subject: [PATCH 023/431] Vere.Http.Client golfing. --- pkg/hair/lib/Vere/Http.hs | 21 ++---- pkg/hair/lib/Vere/Http/Client.hs | 126 ++++++++++++++++--------------- pkg/hair/package.yaml | 3 +- 3 files changed, 74 insertions(+), 76 deletions(-) diff --git a/pkg/hair/lib/Vere/Http.hs b/pkg/hair/lib/Vere/Http.hs index 7862152ca..df56a62f5 100644 --- a/pkg/hair/lib/Vere/Http.hs +++ b/pkg/hair/lib/Vere/Http.hs @@ -7,15 +7,8 @@ import Data.Noun data Header = Header Text Text -data Method = CONNECT - | DELETE - | GET - | HEAD - | OPTIONS - | POST - | PUT - | TRACE - deriving (Eq,Ord,Show) +data Method = CONNECT | DELETE | GET | HEAD | OPTIONS | POST | PUT | TRACE + deriving (Eq,Ord,Show) data Request = Request { method :: Method @@ -29,9 +22,7 @@ data ResponseHeader = ResponseHeader , headers :: [Header] } -data Event = Start ResponseHeader (Maybe ByteString) Bool - | Continue (Maybe ByteString) Bool - | Cancel - ---instance FromNoun Event where --- fromNoun = undefined +data Event = Started ResponseHeader -- [%start hdr (unit octs) ?] + | Received ByteString -- [%continue [~ octs] %.n] + | Done -- [%continue ~ %.y] + | Canceled -- %cancel diff --git a/pkg/hair/lib/Vere/Http/Client.hs b/pkg/hair/lib/Vere/Http/Client.hs index 196e20d60..589c4ad86 100644 --- a/pkg/hair/lib/Vere/Http/Client.hs +++ b/pkg/hair/lib/Vere/Http/Client.hs @@ -1,80 +1,86 @@ --- +http-client ---------------------------------------------------------------- +{- + - TODO When making a request, handle the case where the request id is + already in use. + - TODO When canceling a request, don't send Http.Canceled if the + request already finished. +-} module Vere.Http.Client where import ClassyPrelude import Data.Void -import qualified Vere.Http as Http +import Vere.Http as Http import Control.Concurrent hiding (newEmptyMVar, putMVar) -import Network.HTTP.Client as H +import qualified Network.HTTP.Client as H + +-------------------------------------------------------------------------------- + + +type ReqId = Word + +data Ev = Receive ReqId Http.Event -- %receive --- | An http client effect is either requesting outbound, or canceling an old --- outbound connection. data Eff - = Request Word Http.Request - | CancelRequest Word + = NewReq ReqId Request -- %request + | CancelReq ReqId -- %cancel-request -data Ev - = Receive Word Http.Event +data State = State + { sManager :: H.Manager + , sLive :: TVar (Map ReqId ThreadId) + , sChan :: MVar Ev + } --- | All live requests -data State = State H.Manager (TVar (Map Word ThreadId)) (MVar Ev) + +-------------------------------------------------------------------------------- + +cvtReq :: Request -> H.Request +cvtReq = undefined + +cvtRespHeaders :: H.Response a -> ResponseHeader +cvtRespHeaders resp = undefined + + +-------------------------------------------------------------------------------- initState :: IO State -initState = do - manager <- H.newManager defaultManagerSettings - liveReqs <- newTVarIO mempty - channels <- newEmptyMVar - pure (State manager liveReqs channels) +initState = State <$> H.newManager H.defaultManagerSettings + <*> newTVarIO mempty + <*> newEmptyMVar +emit :: State -> Ev -> IO () +emit (State _ _ chan) event = putMVar chan event -emitEvent :: State -> Ev -> IO () -emitEvent (State _ _ chan) event = - putMVar chan event +runEff :: State -> Eff -> IO () +runEff st@(State _ s _) = \case CancelReq id -> cancelReq st id + NewReq id req -> newReq st id req -run :: State -> Eff -> IO () -run st@(State manager s _) (Request id request) = do - -- TODO: Handle case where id is already live - x <- startHTTP st id request - atomically $ modifyTVar s (insertMap id x) +newReq :: State -> ReqId -> Request -> IO () +newReq st id req = do tid <- runReq st id req + atomically $ modifyTVar (sLive st) (insertMap id tid) -run st@(State manager s _) (CancelRequest id) = +cancelReq :: State -> ReqId -> IO () +cancelReq st id = join $ atomically $ do - m <- readTVar s - case lookup id m of - Nothing -> pure (pure ()) - Just r -> do - m <- writeTVar s (deleteMap id m) - pure (cancelHTTP st id r) + tbl <- readTVar (sLive st) + case lookup id tbl of + Nothing -> pure (pure ()) + Just tid -> do + writeTVar (sLive st) (deleteMap id tbl) + pure $ do killThread tid + emit st (Receive id Canceled) - -startHTTP :: State -> Word -> Http.Request -> IO ThreadId -startHTTP st@(State manager _ chan) id request = forkIO $ do - withResponse (convertRequest request) manager $ \response -> do - let headers = convertResponseHeaders response - emitEvent st (Receive id (Http.Start headers Nothing False)) - readChunks (H.responseBody response) +runReq :: State -> ReqId -> Request -> IO ThreadId +runReq st id request = + forkIO $ H.withResponse (cvtReq request) (sManager st) $ \resp -> do + let headers = cvtRespHeaders resp + let getChunk = recv (H.responseBody resp) + let loop = getChunk >>= \case + Just bs -> emit st (Receive id $ Received bs) >> loop + Nothing -> emit st (Receive id Done) + emit st (Receive id $ Started headers) + loop where - readChunks :: H.BodyReader -> IO () - readChunks reader = do - chunk <- H.brRead reader - if null chunk - then emitEvent st (Receive id (Http.Continue Nothing True)) - else do - emitEvent st (Receive id (Http.Continue (Just chunk) False)) - readChunks reader - - -convertRequest :: Http.Request -> H.Request -convertRequest = undefined - -convertResponseHeaders :: H.Response a -> Http.ResponseHeader -convertResponseHeaders response = undefined - -cancelHTTP :: State -> Word -> ThreadId -> IO () -cancelHTTP st requestId threadId = do - -- There's a race condition here because threadId could have already - -- finished. - killThread threadId - emitEvent st (Receive requestId (Http.Cancel)) + recv :: H.BodyReader -> IO (Maybe ByteString) + recv read = read <&> \case chunk | null chunk -> Nothing + | otherwise -> Just chunk diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index a1d5ceae7..43d63bf80 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -58,9 +58,9 @@ dependencies: default-extensions: - ApplicativeDo - - GeneralizedNewtypeDeriving - BangPatterns - BlockArguments + - DeriveAnyClass - DeriveDataTypeable - DeriveFoldable - DeriveGeneric @@ -71,6 +71,7 @@ default-extensions: - FlexibleInstances - FunctionalDependencies - GADTs + - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - NamedFieldPuns From 2374ed3ce87ba6ef118aecb0219fd8278741e92a Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 16 May 2019 18:45:03 -0700 Subject: [PATCH 024/431] Don't send a Canceled event if the request already finished. --- pkg/hair/lib/Vere/Http/Client.hs | 65 ++++++++++++++++---------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/pkg/hair/lib/Vere/Http/Client.hs b/pkg/hair/lib/Vere/Http/Client.hs index 589c4ad86..15218bca2 100644 --- a/pkg/hair/lib/Vere/Http/Client.hs +++ b/pkg/hair/lib/Vere/Http/Client.hs @@ -1,37 +1,31 @@ {- - TODO When making a request, handle the case where the request id is already in use. - - TODO When canceling a request, don't send Http.Canceled if the - request already finished. -} module Vere.Http.Client where import ClassyPrelude -import Data.Void -import Vere.Http as Http -import Control.Concurrent hiding (newEmptyMVar, putMVar) +import Vere.Http import qualified Network.HTTP.Client as H -------------------------------------------------------------------------------- - type ReqId = Word -data Ev = Receive ReqId Http.Event -- %receive +data Ev = Receive ReqId Event -- [%receive @ todo] data Eff - = NewReq ReqId Request -- %request - | CancelReq ReqId -- %cancel-request + = NewReq ReqId Request -- [%request @ todo] + | CancelReq ReqId -- [%cancel-request @] data State = State { sManager :: H.Manager - , sLive :: TVar (Map ReqId ThreadId) + , sLive :: TVar (Map ReqId (Async ())) , sChan :: MVar Ev } - -------------------------------------------------------------------------------- cvtReq :: Request -> H.Request @@ -40,7 +34,6 @@ cvtReq = undefined cvtRespHeaders :: H.Response a -> ResponseHeader cvtRespHeaders resp = undefined - -------------------------------------------------------------------------------- initState :: IO State @@ -49,38 +42,46 @@ initState = State <$> H.newManager H.defaultManagerSettings <*> newEmptyMVar emit :: State -> Ev -> IO () -emit (State _ _ chan) event = putMVar chan event +emit st event = putMVar (sChan st) event runEff :: State -> Eff -> IO () -runEff st@(State _ s _) = \case CancelReq id -> cancelReq st id - NewReq id req -> newReq st id req +runEff st = \case CancelReq id -> cancelReq st id + NewReq id req -> newReq st id req newReq :: State -> ReqId -> Request -> IO () -newReq st id req = do tid <- runReq st id req - atomically $ modifyTVar (sLive st) (insertMap id tid) +newReq st id req = do async <- runReq st id req + atomically $ modifyTVar (sLive st) (insertMap id async) + +waitCancel :: Async a -> IO (Either SomeException a) +waitCancel async = cancel async >> waitCatch async + +cancelThread :: State -> ReqId -> Async a -> IO () +cancelThread st id = + waitCancel >=> \case Left _ -> emit st (Receive id Canceled) + Right _ -> pure () cancelReq :: State -> ReqId -> IO () cancelReq st id = join $ atomically $ do tbl <- readTVar (sLive st) case lookup id tbl of - Nothing -> pure (pure ()) - Just tid -> do - writeTVar (sLive st) (deleteMap id tbl) - pure $ do killThread tid - emit st (Receive id Canceled) + Nothing -> pure (pure ()) + Just async -> do writeTVar (sLive st) (deleteMap id tbl) + pure (cancelThread st id async) -runReq :: State -> ReqId -> Request -> IO ThreadId -runReq st id request = - forkIO $ H.withResponse (cvtReq request) (sManager st) $ \resp -> do - let headers = cvtRespHeaders resp - let getChunk = recv (H.responseBody resp) - let loop = getChunk >>= \case - Just bs -> emit st (Receive id $ Received bs) >> loop - Nothing -> emit st (Receive id Done) - emit st (Receive id $ Started headers) - loop +runReq :: State -> ReqId -> Request -> IO (Async ()) +runReq st id req = async (H.withResponse (cvtReq req) (sManager st) exec) where recv :: H.BodyReader -> IO (Maybe ByteString) recv read = read <&> \case chunk | null chunk -> Nothing | otherwise -> Just chunk + + exec :: H.Response H.BodyReader -> IO () + exec resp = do + let headers = cvtRespHeaders resp + getChunk = recv (H.responseBody resp) + loop = getChunk >>= \case + Just bs -> emit st (Receive id $ Received bs) >> loop + Nothing -> emit st (Receive id Done) + emit st (Receive id $ Started headers) + loop From 18098beaacbc711ebfadb5efe0165b96ff28a2f5 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 16 May 2019 19:56:06 -0700 Subject: [PATCH 025/431] zipFlat is now typically smaller and faster than jam. --- pkg/hair/lib/Data/Noun.hs | 4 +- pkg/hair/lib/Data/Noun/Atom.hs | 29 ++++++- pkg/hair/lib/Data/Noun/Zip.hs | 140 +++++++++++++++++++++------------ pkg/hair/package.yaml | 1 + pkg/hair/stack.yaml | 1 + 5 files changed, 121 insertions(+), 54 deletions(-) diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs index f26f4dfee..4a7dd3485 100644 --- a/pkg/hair/lib/Data/Noun.hs +++ b/pkg/hair/lib/Data/Noun.hs @@ -43,7 +43,7 @@ instance Show Noun where fmtCell xs = "[" <> intercalate " " xs <> "]" instance Arbitrary Noun where - arbitrary = resize 12 genNoun + arbitrary = resize 120 genNoun where genNoun = do sz <- getSize @@ -51,7 +51,7 @@ instance Arbitrary Noun where case (sz, bit) of ( 0, _ ) -> Atom <$> arbitrary ( _, False ) -> Atom <$> arbitrary - ( _, True ) -> scale pred (Cell <$> genNoun <*> genNoun) + ( _, True ) -> scale (\x -> x-10) (Cell <$> genNoun <*> genNoun) -- Predicates ------------------------------------------------------------------ diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index 0b88a1073..42c20aa0d 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -14,11 +14,12 @@ import Data.Bits import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen import Text.Printf +import Data.Flat -------------------------------------------------------------------------------- newtype Atom = MkAtom Natural - deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral) + deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral, Flat) instance Show Atom where show (MkAtom a) = show a @@ -49,7 +50,11 @@ instance Arbitrary Natural where arbitrary = fromInteger . abs <$> arbitrary instance Arbitrary Atom where - arbitrary = MkAtom <$> arbitrary + arbitrary = do + arbitrary >>= \case + False -> MkAtom <$> arbitrary + True -> do n <- MkAtom <$> arbitrary + pure (n + 2 ^ (n `mod` 64)) -- Conversion ------------------------------------------------------------------ @@ -58,10 +63,30 @@ class IsAtom a where toAtom :: a -> Atom fromAtom :: Atom -> a +instance IsAtom Atom where + toAtom = id + fromAtom = id + instance IsAtom Natural where toAtom = MkAtom fromAtom (MkAtom a) = a +instance IsAtom Word8 where + toAtom = fromIntegral + fromAtom = fromIntegral + +instance IsAtom Word16 where + toAtom = fromIntegral + fromAtom = fromIntegral + +instance IsAtom Word32 where + toAtom = fromIntegral + fromAtom = fromIntegral + +instance IsAtom Word64 where + toAtom = fromIntegral + fromAtom = fromIntegral + instance IsAtom Word where toAtom = fromIntegral fromAtom = fromIntegral diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs index 8ddaca3f1..d3d684fb3 100644 --- a/pkg/hair/lib/Data/Noun/Zip.hs +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -16,15 +16,19 @@ import Data.Bits import GHC.Generics import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen +import Data.Flat +import Data.Flat.Bits import Data.List (intercalate) import Data.Typeable (Typeable) +import Data.Word import Control.Monad.State.Strict hiding (forM_) import Control.Monad.Trans.Maybe -import qualified Data.Vector as V -import qualified Data.List as L +import qualified Data.Vector as V +import qualified Data.List as L +import qualified Data.Vector.Unboxed as UV import Test.Tasty import Test.Tasty.TH @@ -34,72 +38,98 @@ import Test.QuickCheck -- External Types -------------------------------------------------------------- -newtype Zip = Zip (Vector ZipNode) - deriving newtype (Eq, Ord, Show) - - --- Internal Types -------------------------------------------------------------- - data ZipNode = ZipAtom !Atom - | ZipCell !Word !Word - deriving (Eq, Ord, Show) + | ZipCell !ZipRef !ZipRef + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass Flat +data ZipRef + = ZRInline !ZipNode + | ZRIndex !Word + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass Flat --------------------------------------------------------------------------------- - -tag :: Bool -> Buf -> Buf -tag bit buf = (if bit then Buf 1 1 else Buf 1 0) <> buf - -jamZipNode :: ZipNode -> Buf -jamZipNode (ZipAtom a) = tag False (mat a) -jamZipNode (ZipCell l r) = tag True (mat (toAtom l) <> mat (toAtom r)) - -jamZip :: Zip -> Buf -jamZip (Zip vec) = fold (length : nodes) - where - length = mat (toAtom (V.length vec)) - nodes = jamZipNode <$> V.toList vec - -cueZip :: Buf -> Maybe Zip -cueZip = undefined - +-- TODO NonEmpty +newtype Zip = Zip [ZipNode] + deriving stock Generic + deriving newtype (Eq, Ord, Show, Flat) -- Zip ------------------------------------------------------------------------- type ZipM a = State ([ZipNode], Word, Map Noun Word) a -zip :: Noun -> Zip -zip = \n -> evalState (go n >> end) ([], 0, mempty) +findDups :: Noun -> Set Noun +findDups = done . go mempty where + done :: Map Noun Word -> Set Noun + done = keysSet . filterMap (> 1) + + ins :: Noun -> Map Noun Word -> Map Noun Word + ins = alterMap $ \case Nothing -> Just 1 + Just n -> Just (n+1) + + go :: Map Noun Word -> Noun -> Map Noun Word + go acc a@(Atom _) = ins a acc + go acc c@(Cell l r) = go (go (ins c acc) l) r + +zzip :: Noun -> Zip +zzip = zip + +zip :: Noun -> Zip +zip top = evalState (go top >> end) ([], 0, mempty) + where + dups :: Set Noun + dups = findDups top + end :: ZipM Zip end = do (acc, _, _) <- get - pure (Zip $ V.fromList $ reverse acc) + pure (Zip $ reverse acc) - ins :: Noun -> ZipNode -> ZipM Word + ins :: Noun -> ZipNode -> ZipM ZipRef ins noun node = do (acc, nex, tbl) <- get put (node:acc, nex+1, insertMap noun nex tbl) - pure nex + pure (ZRIndex nex) - go :: Noun -> ZipM Word - go noun = do + doAtom :: Atom -> ZipM ZipRef + doAtom a = do + if a >= 128 && member (Atom a) dups + then ins (Atom a) (ZipAtom a) + else pure (ZRInline (ZipAtom a)) + + doCell :: (Noun, Noun) -> ZipM ZipRef + doCell (l,r) = do + lRef <- loop l + rRef <- loop r + let res = ZipCell lRef rRef + if member (Cell l r) dups + then ins (Cell l r) res + else pure (ZRInline res) + + loop :: Noun -> ZipM ZipRef + loop noun = do (acc, nex, tbl) <- get case (lookup noun tbl, noun) of - (Just w, _) -> pure w - (Nothing, Atom atm) -> ins noun (ZipAtom atm) - (Nothing, Cell l r) -> (ZipCell <$> go l <*> go r) >>= ins noun + (Just w, _) -> pure (ZRIndex w) + (Nothing, Atom atm) -> doAtom atm + (Nothing, Cell l r) -> doCell (l,r) + go :: Noun -> ZipM ZipRef + go noun = do + loop noun >>= \case + ZRInline x -> ins noun x + ZRIndex _ -> error "Impossible -- duplicate top-level node" -- Unzip ----------------------------------------------------------------------- type UnZipM a = MaybeT (State (Word, Map Word Noun)) a unzip :: Zip -> Maybe Noun -unzip (Zip vec) | V.length vec == 0 = Nothing +unzip (Zip []) = Nothing unzip (Zip vec) = - L.last <$> cvt (V.toList vec) + L.last <$> cvt vec where cvt :: [ZipNode] -> Maybe [Noun] cvt nodes = evalState (runMaybeT $ go nodes) (0, mempty) @@ -109,12 +139,13 @@ unzip (Zip vec) = modify $ \(nex, tbl) -> (nex+1, insertMap nex noun tbl) pure noun - find :: Word -> UnZipM Noun - find idx = do - (nex, tbl) <- get - lookup idx tbl & \case - Nothing -> error "bad zip" - Just res -> pure res + find :: ZipRef -> UnZipM Noun + find (ZRInline (ZipAtom a)) = pure (Atom a) + find (ZRInline (ZipCell l r)) = Cell <$> find l <*> find r + find (ZRIndex idx) = do (nex, tbl) <- get + lookup idx tbl & \case + Nothing -> error "bad zip" + Just res -> pure res go :: [ZipNode] -> UnZipM [Noun] go = mapM $ \case ZipAtom a -> ins (Atom a) @@ -123,14 +154,23 @@ unzip (Zip vec) = -- Tests ----------------------------------------------------------------------- -compareSize :: Noun -> (Int, Int) -compareSize n = (jamSz, zipSz) +compareSize :: Noun -> Int +compareSize n = flatSz - jamSz where - Buf jamSz _ = fromAtom (jam n) - Buf zipSz _ = jamZip (zip n) + Buf jamSz _ = fromAtom (jam n) + flatSz = UV.length (bits (zip n)) prop_zipUnzip :: Noun -> Bool prop_zipUnzip n = Just n == unzip (zip n) main :: IO () main = $(defaultMainGenerator) + +dub :: Noun -> Noun +dub x = Cell x x + +testSizes :: IO () +testSizes = do + nouns <- sample' (arbitrary :: Gen Noun) + traverse_ (print . compareSize) nouns + -- traverse_ print nouns diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 43d63bf80..c5614b6c3 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -31,6 +31,7 @@ dependencies: - classy-prelude - containers - data-fix + - flat - ghc-prim - http-client - integer-gmp diff --git a/pkg/hair/stack.yaml b/pkg/hair/stack.yaml index fc5a0abe2..2140ef2f3 100644 --- a/pkg/hair/stack.yaml +++ b/pkg/hair/stack.yaml @@ -8,3 +8,4 @@ ghc-options: extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 + - flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38 From 0008ca0bc9752976efdc522b2d3d9d5393117064 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 16 May 2019 23:39:07 -0700 Subject: [PATCH 026/431] Various fixes and improvements. --- pkg/hair/lib/Data/Noun.hs | 16 +++++++----- pkg/hair/lib/Data/Noun/Zip.hs | 49 ++++++++++++++++++----------------- pkg/hair/package.yaml | 1 + 3 files changed, 35 insertions(+), 31 deletions(-) diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs index 4a7dd3485..37b04168e 100644 --- a/pkg/hair/lib/Data/Noun.hs +++ b/pkg/hair/lib/Data/Noun.hs @@ -43,15 +43,17 @@ instance Show Noun where fmtCell xs = "[" <> intercalate " " xs <> "]" instance Arbitrary Noun where - arbitrary = resize 120 genNoun + arbitrary = resize 1000 go where - genNoun = do + dub x = Cell x x + go = do sz <- getSize - bit <- arbitrary - case (sz, bit) of - ( 0, _ ) -> Atom <$> arbitrary - ( _, False ) -> Atom <$> arbitrary - ( _, True ) -> scale (\x -> x-10) (Cell <$> genNoun <*> genNoun) + (bit, bat) <- arbitrary + case (sz, bit, bat) of + ( 0, _, _ ) -> Atom <$> arbitrary + ( _, False, _ ) -> Atom <$> arbitrary + ( _, True, True ) -> dub <$> arbitrary + ( _, True, _ ) -> scale (\x -> x-10) (Cell <$> go <*> go) -- Predicates ------------------------------------------------------------------ diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs index d3d684fb3..8b0dbfaed 100644 --- a/pkg/hair/lib/Data/Noun/Zip.hs +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -18,12 +18,13 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen import Data.Flat import Data.Flat.Bits +import Data.Either.Extra import Data.List (intercalate) import Data.Typeable (Typeable) import Data.Word -import Control.Monad.State.Strict hiding (forM_) +import Control.Monad.State.Strict hiding (forM_, replicateM) import Control.Monad.Trans.Maybe import qualified Data.Vector as V @@ -50,32 +51,22 @@ data ZipRef deriving stock (Eq, Ord, Show, Generic) deriving anyclass Flat --- TODO NonEmpty -newtype Zip = Zip [ZipNode] - deriving stock Generic - deriving newtype (Eq, Ord, Show, Flat) +type Zip = [ZipNode] -- Zip ------------------------------------------------------------------------- type ZipM a = State ([ZipNode], Word, Map Noun Word) a findDups :: Noun -> Set Noun -findDups = done . go mempty +findDups = keysSet . filterMap (> 1) . go mempty where - done :: Map Noun Word -> Set Noun - done = keysSet . filterMap (> 1) - ins :: Noun -> Map Noun Word -> Map Noun Word - ins = alterMap $ \case Nothing -> Just 1 - Just n -> Just (n+1) + ins = alterMap (Just . maybe 1 (+1)) go :: Map Noun Word -> Noun -> Map Noun Word go acc a@(Atom _) = ins a acc go acc c@(Cell l r) = go (go (ins c acc) l) r -zzip :: Noun -> Zip -zzip = zip - zip :: Noun -> Zip zip top = evalState (go top >> end) ([], 0, mempty) where @@ -85,7 +76,7 @@ zip top = evalState (go top >> end) ([], 0, mempty) end :: ZipM Zip end = do (acc, _, _) <- get - pure (Zip $ reverse acc) + pure (reverse acc) ins :: Noun -> ZipNode -> ZipM ZipRef ins noun node = do @@ -127,9 +118,8 @@ zip top = evalState (go top >> end) ([], 0, mempty) type UnZipM a = MaybeT (State (Word, Map Word Noun)) a unzip :: Zip -> Maybe Noun -unzip (Zip []) = Nothing -unzip (Zip vec) = - L.last <$> cvt vec +unzip = \case [] -> Nothing + zs -> L.last <$> cvt zs where cvt :: [ZipNode] -> Maybe [Noun] cvt nodes = evalState (runMaybeT $ go nodes) (0, mempty) @@ -143,9 +133,7 @@ unzip (Zip vec) = find (ZRInline (ZipAtom a)) = pure (Atom a) find (ZRInline (ZipCell l r)) = Cell <$> find l <*> find r find (ZRIndex idx) = do (nex, tbl) <- get - lookup idx tbl & \case - Nothing -> error "bad zip" - Just res -> pure res + (MaybeT . pure) $ lookup idx tbl go :: [ZipNode] -> UnZipM [Noun] go = mapM $ \case ZipAtom a -> ins (Atom a) @@ -163,6 +151,15 @@ compareSize n = flatSz - jamSz prop_zipUnzip :: Noun -> Bool prop_zipUnzip n = Just n == unzip (zip n) +zipFlat :: Noun -> ByteString +zipFlat = flat . zip + +unZipFlat :: ByteString -> Maybe Noun +unZipFlat = (>>= unzip) . eitherToMaybe . unflat + +prop_zipFlatRoundTrip :: Noun -> Bool +prop_zipFlatRoundTrip n = Just n == (unZipFlat . zipFlat) n + main :: IO () main = $(defaultMainGenerator) @@ -171,6 +168,10 @@ dub x = Cell x x testSizes :: IO () testSizes = do - nouns <- sample' (arbitrary :: Gen Noun) - traverse_ (print . compareSize) nouns - -- traverse_ print nouns + nouns <- join <$> (replicateM 50 (sample' (arbitrary :: Gen Noun)) :: IO [[Noun]]) + traverse_ print $ reverse + $ ordNub + $ sort + $ fmap ((`div` 64) . compareSize) + $ nouns + -- traverse_ print $ filter ((> 1000) . abs . compareSize) nouns diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index c5614b6c3..8ce1e9238 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -31,6 +31,7 @@ dependencies: - classy-prelude - containers - data-fix + - extra - flat - ghc-prim - http-client From 7b7510b859fce6d9f5ca8a19ba5e0b3efdf15b6e Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Fri, 17 May 2019 14:52:12 -0700 Subject: [PATCH 027/431] Fleshed out Client.hs. --- pkg/hair/lib/Vere/Http.hs | 3 ++- pkg/hair/lib/Vere/Http/Client.hs | 32 ++++++++++++++++++++++++++------ pkg/hair/package.yaml | 2 ++ 3 files changed, 30 insertions(+), 7 deletions(-) diff --git a/pkg/hair/lib/Vere/Http.hs b/pkg/hair/lib/Vere/Http.hs index df56a62f5..00553d8ea 100644 --- a/pkg/hair/lib/Vere/Http.hs +++ b/pkg/hair/lib/Vere/Http.hs @@ -18,7 +18,7 @@ data Request = Request } data ResponseHeader = ResponseHeader - { statusCode :: Integer + { statusCode :: Int , headers :: [Header] } @@ -26,3 +26,4 @@ data Event = Started ResponseHeader -- [%start hdr (unit octs) ?] | Received ByteString -- [%continue [~ octs] %.n] | Done -- [%continue ~ %.y] | Canceled -- %cancel + | Failed Text -- %cancel diff --git a/pkg/hair/lib/Vere/Http/Client.hs b/pkg/hair/lib/Vere/Http/Client.hs index 15218bca2..d3833f5f8 100644 --- a/pkg/hair/lib/Vere/Http/Client.hs +++ b/pkg/hair/lib/Vere/Http/Client.hs @@ -8,6 +8,8 @@ module Vere.Http.Client where import ClassyPrelude import Vere.Http +import qualified Data.CaseInsensitive as CI +import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Client as H -------------------------------------------------------------------------------- @@ -28,11 +30,26 @@ data State = State -------------------------------------------------------------------------------- -cvtReq :: Request -> H.Request -cvtReq = undefined +cvtReq :: Request -> Maybe H.Request +cvtReq r = + H.parseRequest (unpack (url r)) <&> \init -> init + { H.method = encodeUtf8 $ tshow (method r), + H.requestHeaders = + headerList r <&> \(Header k v) -> (CI.mk (encodeUtf8 k), + encodeUtf8 v), + H.requestBody = + H.RequestBodyBS $ case body r of + Nothing -> "" + Just b -> b + } cvtRespHeaders :: H.Response a -> ResponseHeader -cvtRespHeaders resp = undefined +cvtRespHeaders resp = + ResponseHeader (HT.statusCode (H.responseStatus resp)) heads + where + heads = H.responseHeaders resp <&> \(k, v) -> + Header (decodeUtf8 (CI.original k)) (decodeUtf8 v) + -------------------------------------------------------------------------------- @@ -45,8 +62,8 @@ emit :: State -> Ev -> IO () emit st event = putMVar (sChan st) event runEff :: State -> Eff -> IO () -runEff st = \case CancelReq id -> cancelReq st id - NewReq id req -> newReq st id req +runEff st = \case NewReq id req -> newReq st id req + CancelReq id -> cancelReq st id newReq :: State -> ReqId -> Request -> IO () newReq st id req = do async <- runReq st id req @@ -70,7 +87,10 @@ cancelReq st id = pure (cancelThread st id async) runReq :: State -> ReqId -> Request -> IO (Async ()) -runReq st id req = async (H.withResponse (cvtReq req) (sManager st) exec) +runReq st id req = async $ + case cvtReq req of + Nothing -> emit st (Receive id (Failed "bad-request-e")) + Just r -> H.withResponse r (sManager st) exec where recv :: H.BodyReader -> IO (Maybe ByteString) recv read = read <&> \case chunk | null chunk -> Nothing diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 8ce1e9238..69e8b10b8 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -28,6 +28,7 @@ executables: dependencies: - async - base + - case-insensitive - classy-prelude - containers - data-fix @@ -35,6 +36,7 @@ dependencies: - flat - ghc-prim - http-client + - http-types - integer-gmp - largeword - lens From fd1190faba36c5f0c3eb130545492810bd8570b7 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 17 May 2019 16:02:39 -0700 Subject: [PATCH 028/431] Optimize zip for small atom sizes. --- pkg/hair/lib/Data/Noun.hs | 7 +- pkg/hair/lib/Data/Noun/Atom.hs | 4 +- pkg/hair/lib/Data/Noun/Zip.hs | 157 +++++++++++++++++++++++++-------- 3 files changed, 127 insertions(+), 41 deletions(-) diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hair/lib/Data/Noun.hs index 37b04168e..f0926d6f0 100644 --- a/pkg/hair/lib/Data/Noun.hs +++ b/pkg/hair/lib/Data/Noun.hs @@ -9,7 +9,7 @@ import Data.Bits import GHC.Generics import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen -import Debug.Trace +import Data.Flat hiding (getSize) import Data.List (intercalate) import Data.Typeable (Typeable) @@ -25,7 +25,8 @@ data Cell = ACell !Noun !Noun data Noun = Atom !Atom | Cell !Noun !Noun - deriving (Eq, Ord) + deriving stock (Eq, Ord, Generic) + deriving anyclass Flat data CellIdx = L | R deriving (Eq, Ord, Show) @@ -48,7 +49,7 @@ instance Arbitrary Noun where dub x = Cell x x go = do sz <- getSize - (bit, bat) <- arbitrary + (bit, bat :: Bool) <- arbitrary case (sz, bit, bat) of ( 0, _, _ ) -> Atom <$> arbitrary ( _, False, _ ) -> Atom <$> arbitrary diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index 42c20aa0d..b35ff44b9 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -53,9 +53,7 @@ instance Arbitrary Atom where arbitrary = do arbitrary >>= \case False -> MkAtom <$> arbitrary - True -> do n <- MkAtom <$> arbitrary - pure (n + 2 ^ (n `mod` 64)) - + True -> arbitrary <&> ((`mod` 16) . MkAtom) -- Conversion ------------------------------------------------------------------ diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs index 8b0dbfaed..9107a94f4 100644 --- a/pkg/hair/lib/Data/Noun/Zip.hs +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -19,6 +19,8 @@ import Test.QuickCheck.Gen import Data.Flat import Data.Flat.Bits import Data.Either.Extra +import GHC.Natural +import Data.Flat import Data.List (intercalate) import Data.Typeable (Typeable) @@ -36,59 +38,81 @@ import Test.Tasty.TH import Test.Tasty.QuickCheck as QC import Test.QuickCheck +-- Atoms Optimized For Small Values -------------------------------------------- + +data Unary = Z | O Unary + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass Flat + +instance IsAtom Unary where + toAtom Z = 0 + toAtom (O u) = 1+toAtom u + fromAtom 0 = Z + fromAtom n = O (fromAtom (pred n)) + +data ZipAtom + = ZATiny Unary + | ZAWide Natural + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass Flat + +instance IsAtom ZipAtom where + toAtom (ZATiny u) = toAtom u + toAtom (ZAWide n) = toAtom n + 8 + fromAtom a | a <= 7 = ZATiny (fromAtom a) + fromAtom (MkAtom n) = ZAWide (n-8) + -- External Types -------------------------------------------------------------- data ZipNode - = ZipAtom !Atom + = ZipAtom !ZipAtom | ZipCell !ZipRef !ZipRef deriving stock (Eq, Ord, Show, Generic) deriving anyclass Flat data ZipRef = ZRInline !ZipNode - | ZRIndex !Word + | ZRIndex !ZipAtom deriving stock (Eq, Ord, Show, Generic) deriving anyclass Flat -type Zip = [ZipNode] +type Zip = ([ZipNode], ZipNode) -- Zip ------------------------------------------------------------------------- -type ZipM a = State ([ZipNode], Word, Map Noun Word) a +type ZipM a = State ([ZipNode], ZipAtom, Map Noun ZipAtom) a findDups :: Noun -> Set Noun -findDups = keysSet . filterMap (> 1) . go mempty +findDups = keysSet . filterMap ((> 1) . toAtom) . go mempty where - ins :: Noun -> Map Noun Word -> Map Noun Word - ins = alterMap (Just . maybe 1 (+1)) + ins :: Noun -> Map Noun ZipAtom -> Map Noun ZipAtom + ins = alterMap (Just . maybe (fromAtom 1) (fromAtom . (+1) . toAtom)) - go :: Map Noun Word -> Noun -> Map Noun Word + go :: Map Noun ZipAtom -> Noun -> Map Noun ZipAtom go acc a@(Atom _) = ins a acc go acc c@(Cell l r) = go (go (ins c acc) l) r +zzip :: Noun -> Zip +zzip = zip + zip :: Noun -> Zip -zip top = evalState (go top >> end) ([], 0, mempty) +zip top = evalState exec ([], fromAtom 0, mempty) where dups :: Set Noun dups = findDups top - end :: ZipM Zip - end = do - (acc, _, _) <- get - pure (reverse acc) - ins :: Noun -> ZipNode -> ZipM ZipRef ins noun node = do (acc, nex, tbl) <- get - put (node:acc, nex+1, insertMap noun nex tbl) + put (node:acc, (fromAtom (toAtom nex + 1)), insertMap noun nex tbl) pure (ZRIndex nex) doAtom :: Atom -> ZipM ZipRef doAtom a = do if a >= 128 && member (Atom a) dups - then ins (Atom a) (ZipAtom a) - else pure (ZRInline (ZipAtom a)) + then ins (Atom a) (ZipAtom (fromAtom a)) + else pure (ZRInline (ZipAtom (fromAtom a))) doCell :: (Noun, Noun) -> ZipM ZipRef doCell (l,r) = do @@ -107,36 +131,37 @@ zip top = evalState (go top >> end) ([], 0, mempty) (Nothing, Atom atm) -> doAtom atm (Nothing, Cell l r) -> doCell (l,r) - go :: Noun -> ZipM ZipRef - go noun = do - loop noun >>= \case - ZRInline x -> ins noun x - ZRIndex _ -> error "Impossible -- duplicate top-level node" + exec :: ZipM Zip + exec = loop top >>= \case + ZRIndex _ -> error "Impossible -- duplicate top-level node" + ZRInline x -> do (acc, _, _) <- get + pure (reverse acc, x) -- Unzip ----------------------------------------------------------------------- -type UnZipM a = MaybeT (State (Word, Map Word Noun)) a +type UnZipM a = MaybeT (State (ZipAtom, Map ZipAtom Noun)) a unzip :: Zip -> Maybe Noun -unzip = \case [] -> Nothing - zs -> L.last <$> cvt zs +unzip (dups, top) = + evalState (runMaybeT (go dups >> root top)) (fromAtom 0, mempty) where - cvt :: [ZipNode] -> Maybe [Noun] - cvt nodes = evalState (runMaybeT $ go nodes) (0, mempty) + root :: ZipNode -> UnZipM Noun + root (ZipAtom a) = pure (Atom (toAtom a)) + root (ZipCell l r) = Cell <$> find l <*> find r ins :: Noun -> UnZipM Noun ins noun = do - modify $ \(nex, tbl) -> (nex+1, insertMap nex noun tbl) + modify $ \(nex, tbl) -> (fromAtom (toAtom nex+1), insertMap nex noun tbl) pure noun find :: ZipRef -> UnZipM Noun - find (ZRInline (ZipAtom a)) = pure (Atom a) + find (ZRInline (ZipAtom a)) = pure (Atom (toAtom a)) find (ZRInline (ZipCell l r)) = Cell <$> find l <*> find r find (ZRIndex idx) = do (nex, tbl) <- get (MaybeT . pure) $ lookup idx tbl go :: [ZipNode] -> UnZipM [Noun] - go = mapM $ \case ZipAtom a -> ins (Atom a) + go = mapM $ \case ZipAtom a -> ins (Atom (toAtom a)) ZipCell l r -> ins =<< Cell <$> find l <*> find r @@ -146,7 +171,19 @@ compareSize :: Noun -> Int compareSize n = flatSz - jamSz where Buf jamSz _ = fromAtom (jam n) - flatSz = UV.length (bits (zip n)) + flatSz = length (bits (zip n)) + +compareZipCompression :: Noun -> Int +compareZipCompression n = zipSz - rawSz + where + rawSz = length (bits n) + zipSz = length (bits (zip n)) + +compareRawToJam :: Noun -> Int +compareRawToJam n = rawSz - jamSz + where + rawSz = length (bits n) + Buf jamSz _ = fromAtom (jam n) prop_zipUnzip :: Noun -> Bool prop_zipUnzip n = Just n == unzip (zip n) @@ -166,12 +203,62 @@ main = $(defaultMainGenerator) dub :: Noun -> Noun dub x = Cell x x -testSizes :: IO () -testSizes = do +allAtoms :: Int -> [Noun] +allAtoms n = Atom <$> [0..toAtom n] + +allCells :: Int -> [Noun] +allCells 0 = allAtoms 1 +allCells n = do + a <- allAtoms (n*2 - 1) + c <- allCells (n-1) + [Cell c a, Cell a c, Cell c c] + +allNouns :: Int -> [Noun] +allNouns sz = ordNub (allCells sz <> allAtoms (sz*2)) + +nounSizes :: (Noun -> Int) -> Int -> [(Int, Noun)] +nounSizes f sz = sort (allNouns sz <&> \n -> (f n, n)) + +jamSz :: Noun -> Int +jamSz = (\(Buf sz _) -> sz) . fromAtom . jam + +showFlatZipSizes :: Int -> IO () +showFlatZipSizes dep = traverse_ print (nounSizes (length . bits . zip) dep) + +showJamSizes :: Int -> IO () +showJamSizes dep = traverse_ print (nounSizes jamSz dep) + +sumFlatZipSizes :: Int -> Int +sumFlatZipSizes dep = sum $ map fst (nounSizes (length . bits . zip) dep) + +sumJamSizes :: Int -> Int +sumJamSizes dep = sum $ map fst (nounSizes jamSz dep) + + +compareSizes :: (Noun -> Int) -> IO () +compareSizes f = do nouns <- join <$> (replicateM 50 (sample' (arbitrary :: Gen Noun)) :: IO [[Noun]]) traverse_ print $ reverse $ ordNub $ sort - $ fmap ((`div` 64) . compareSize) + $ fmap ((`div` 64) . f) $ nouns - -- traverse_ print $ filter ((> 1000) . abs . compareSize) nouns + -- traverse_ print $ filter ((> 1000) . abs . f) nouns + +testSizes :: IO () +testSizes = compareSizes compareSize + +testZipCompression :: IO () +testZipCompression = compareSizes compareZipCompression + +testRawToJamSizes :: IO () +testRawToJamSizes = compareSizes compareRawToJam + +allSizeTests :: IO () +allSizeTests = do + putStrLn "zipFlat - jam" + testSizes + putStrLn "\nzipFlat - flat" + testZipCompression + putStrLn "\nflat - jam" + testRawToJamSizes From 64e4d11427c2bc7a8224a5d08d83acd71de1f6a1 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 17 May 2019 20:44:13 -0700 Subject: [PATCH 029/431] Optimized Zip compression table and dramatically simplified it's code --- pkg/hair/lib/Data/Noun/Poet.hs | 3 + pkg/hair/lib/Data/Noun/Zip.hs | 117 +++++++++++---------------------- 2 files changed, 43 insertions(+), 77 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hair/lib/Data/Noun/Poet.hs index 5e1f80c45..2b685cdd6 100644 --- a/pkg/hair/lib/Data/Noun/Poet.hs +++ b/pkg/hair/lib/Data/Noun/Poet.hs @@ -146,6 +146,9 @@ class ToNoun a where -- Atom Conversion ------------------------------------------------------------- +instance ToNoun Noun where + toNoun = id + instance ToNoun Word where toNoun = Atom . fromIntegral diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs index 9107a94f4..d7af7a452 100644 --- a/pkg/hair/lib/Data/Noun/Zip.hs +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -22,9 +22,9 @@ import Data.Either.Extra import GHC.Natural import Data.Flat +import Data.Maybe (fromJust) import Data.List (intercalate) import Data.Typeable (Typeable) -import Data.Word import Control.Monad.State.Strict hiding (forM_, replicateM) import Control.Monad.Trans.Maybe @@ -53,9 +53,12 @@ instance IsAtom Unary where data ZipAtom = ZATiny Unary | ZAWide Natural - deriving stock (Eq, Ord, Show, Generic) + deriving stock (Eq, Ord, Generic) deriving anyclass Flat +instance Show ZipAtom where + show = show . toAtom + instance IsAtom ZipAtom where toAtom (ZATiny u) = toAtom u toAtom (ZAWide n) = toAtom n + 8 @@ -79,90 +82,51 @@ data ZipRef type Zip = ([ZipNode], ZipNode) --- Zip ------------------------------------------------------------------------- +-- Zip and UnZip --------------------------------------------------------------- -type ZipM a = State ([ZipNode], ZipAtom, Map Noun ZipAtom) a - -findDups :: Noun -> Set Noun -findDups = keysSet . filterMap ((> 1) . toAtom) . go mempty +refCount :: Noun -> Map Noun Word +refCount = go mempty where - ins :: Noun -> Map Noun ZipAtom -> Map Noun ZipAtom - ins = alterMap (Just . maybe (fromAtom 1) (fromAtom . (+1) . toAtom)) + ins :: Noun -> Map Noun Word -> Map Noun Word + ins = alterMap (Just . maybe 1 (+1)) - go :: Map Noun ZipAtom -> Noun -> Map Noun ZipAtom + go :: Map Noun Word -> Noun -> Map Noun Word go acc a@(Atom _) = ins a acc go acc c@(Cell l r) = go (go (ins c acc) l) r -zzip :: Noun -> Zip -zzip = zip +zipTable :: Noun -> (Vector Noun, Map Noun Int) +zipTable top = (tbl, keys tbl) + where + keys = mapFromList . V.toList . fmap swap . V.indexed + big = \case { Atom a -> a >= 128; _ -> True } + tbl = filter big + $ fmap fst + $ V.fromList + $ sortBy (comparing snd) + $ mapToList + $ filterMap (> 1) + $ refCount top zip :: Noun -> Zip -zip top = evalState exec ([], fromAtom 0, mempty) +zip top = (V.toList dups, cvtNode top) where - dups :: Set Noun - dups = findDups top - - ins :: Noun -> ZipNode -> ZipM ZipRef - ins noun node = do - (acc, nex, tbl) <- get - put (node:acc, (fromAtom (toAtom nex + 1)), insertMap noun nex tbl) - pure (ZRIndex nex) - - doAtom :: Atom -> ZipM ZipRef - doAtom a = do - if a >= 128 && member (Atom a) dups - then ins (Atom a) (ZipAtom (fromAtom a)) - else pure (ZRInline (ZipAtom (fromAtom a))) - - doCell :: (Noun, Noun) -> ZipM ZipRef - doCell (l,r) = do - lRef <- loop l - rRef <- loop r - let res = ZipCell lRef rRef - if member (Cell l r) dups - then ins (Cell l r) res - else pure (ZRInline res) - - loop :: Noun -> ZipM ZipRef - loop noun = do - (acc, nex, tbl) <- get - case (lookup noun tbl, noun) of - (Just w, _) -> pure (ZRIndex w) - (Nothing, Atom atm) -> doAtom atm - (Nothing, Cell l r) -> doCell (l,r) - - exec :: ZipM Zip - exec = loop top >>= \case - ZRIndex _ -> error "Impossible -- duplicate top-level node" - ZRInline x -> do (acc, _, _) <- get - pure (reverse acc, x) - --- Unzip ----------------------------------------------------------------------- - -type UnZipM a = MaybeT (State (ZipAtom, Map ZipAtom Noun)) a + (tbl, keys) = zipTable top + dups = cvtNode <$> tbl + cvtRef n = lookup n keys & \case Nothing -> ZRInline (cvtNode n) + Just a -> ZRIndex (fromAtom $ toAtom a) + cvtNode = \case Atom a -> ZipAtom (fromAtom a) + Cell l r -> ZipCell (cvtRef l) (cvtRef r) unzip :: Zip -> Maybe Noun -unzip (dups, top) = - evalState (runMaybeT (go dups >> root top)) (fromAtom 0, mempty) +unzip (V.fromList -> dups, top) = recover top where - root :: ZipNode -> UnZipM Noun - root (ZipAtom a) = pure (Atom (toAtom a)) - root (ZipCell l r) = Cell <$> find l <*> find r + recover :: ZipNode -> Maybe Noun + recover (ZipAtom a) = pure (Atom $ toAtom a) + recover (ZipCell l r) = Cell <$> getRef l <*> getRef r - ins :: Noun -> UnZipM Noun - ins noun = do - modify $ \(nex, tbl) -> (fromAtom (toAtom nex+1), insertMap nex noun tbl) - pure noun - - find :: ZipRef -> UnZipM Noun - find (ZRInline (ZipAtom a)) = pure (Atom (toAtom a)) - find (ZRInline (ZipCell l r)) = Cell <$> find l <*> find r - find (ZRIndex idx) = do (nex, tbl) <- get - (MaybeT . pure) $ lookup idx tbl - - go :: [ZipNode] -> UnZipM [Noun] - go = mapM $ \case ZipAtom a -> ins (Atom (toAtom a)) - ZipCell l r -> ins =<< Cell <$> find l <*> find r + getRef :: ZipRef -> Maybe Noun + getRef (ZRInline n) = recover n + getRef (ZRIndex ix) = dups V.!? fromAtom (toAtom ix) >>= recover -- Tests ----------------------------------------------------------------------- @@ -204,17 +168,17 @@ dub :: Noun -> Noun dub x = Cell x x allAtoms :: Int -> [Noun] -allAtoms n = Atom <$> [0..toAtom n] +allAtoms n = Atom . (\n -> 2^n - 1) <$> [0..toAtom n] allCells :: Int -> [Noun] allCells 0 = allAtoms 1 allCells n = do - a <- allAtoms (n*2 - 1) + a <- Atom <$> [0, (2 ^ toAtom n) - 1] c <- allCells (n-1) [Cell c a, Cell a c, Cell c c] allNouns :: Int -> [Noun] -allNouns sz = ordNub (allCells sz <> allAtoms (sz*2)) +allNouns sz = ordNub (allCells sz) nounSizes :: (Noun -> Int) -> Int -> [(Int, Noun)] nounSizes f sz = sort (allNouns sz <&> \n -> (f n, n)) @@ -234,7 +198,6 @@ sumFlatZipSizes dep = sum $ map fst (nounSizes (length . bits . zip) dep) sumJamSizes :: Int -> Int sumJamSizes dep = sum $ map fst (nounSizes jamSz dep) - compareSizes :: (Noun -> Int) -> IO () compareSizes f = do nouns <- join <$> (replicateM 50 (sample' (arbitrary :: Gen Noun)) :: IO [[Noun]]) From 99191276209bc4cb0fa2a3cbe68817fa50f87927 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 19 May 2019 18:53:32 -0700 Subject: [PATCH 030/431] Wrote code to load a pill file, but it doesn't work yet. --- .gitignore | 1 + pkg/hair/lib/Data/Noun/Pill.hs | 154 ++++++++++++++++++ pkg/hair/lib/Data/Noun/Zip.hs | 14 +- pkg/hair/package.yaml | 2 + pkg/hoon/.gitignore | 2 + .../lib/Language/Hoon/AST/Parser.hs | 0 .../lib/Language/Hoon/AST/Types.hs | 0 .../lib/Language/Hoon/Desugar.hs | 0 .../lib/Language/Hoon/IR/Desugar.hs | 0 .../lib/Language/Hoon/IR/Infer.hs | 0 pkg/{hair => hoon}/lib/Language/Hoon/IR/Ty.hs | 0 .../lib/Language/Hoon/IR/Wing.hs | 0 .../lib/Language/Hoon/LL/Gen.hs | 0 .../lib/Language/Hoon/LL/Run.hs | 0 .../lib/Language/Hoon/LL/Types.hs | 0 .../lib/Language/Hoon/Nock/Types.hs | 0 .../lib/Language/Hoon/SpecToBunt.hs | 0 .../lib/Language/Hoon/SpecToMold.hs | 0 pkg/{hair => hoon}/lib/Language/Hoon/Types.hs | 0 pkg/hoon/package.yaml | 79 +++++++++ pkg/hair/stack.yaml => stack.yaml | 3 +- 21 files changed, 247 insertions(+), 8 deletions(-) create mode 100644 pkg/hair/lib/Data/Noun/Pill.hs create mode 100644 pkg/hoon/.gitignore rename pkg/{hair => hoon}/lib/Language/Hoon/AST/Parser.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/AST/Types.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/Desugar.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/IR/Desugar.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/IR/Infer.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/IR/Ty.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/IR/Wing.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/LL/Gen.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/LL/Run.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/LL/Types.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/Nock/Types.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/SpecToBunt.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/SpecToMold.hs (100%) rename pkg/{hair => hoon}/lib/Language/Hoon/Types.hs (100%) create mode 100644 pkg/hoon/package.yaml rename pkg/hair/stack.yaml => stack.yaml (90%) diff --git a/.gitignore b/.gitignore index a3f70edda..d7c0f17a5 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ tags TAGS cross/ release/ +.stack-work diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs new file mode 100644 index 000000000..1b6eea589 --- /dev/null +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE MagicHash #-} + +module Data.Noun.Pill where + +import ClassyPrelude +import Data.Noun +import Data.Noun.Atom +import Data.Noun.Jam +import Data.Flat +import Control.Monad.Except +import Control.Lens +import Data.Either.Extra (mapLeft) +import GHC.Natural +import Data.Bits +import GHC.Integer.GMP.Internals + +import qualified Data.Primitive.ByteArray as Prim +import qualified Data.Vector.Primitive as VP +import qualified Data.ByteString as BS + +-------------------------------------------------------------------------------- + +stripTrailingZeros :: ByteString -> ByteString +stripTrailingZeros buf = BS.take (len - go 0 (len - 1)) buf + where + len = length buf + go n i | i < 0 = n + | 0 == BS.index buf i = go (n+1) (i-1) + | otherwise = n + +unpackWord :: ByteString -> Word +unpackWord buf = + case length buf of + 0 -> 0 + 1 -> i 0 0 + 2 -> i 0 0 .|. i 1 8 + 3 -> i 0 0 .|. i 1 8 .|. i 2 16 + n -> i 0 0 .|. i 1 8 .|. i 2 16 .|. i 3 24 + where + i :: Int -> Int -> Word + i idx off = shiftL (fromIntegral $ BS.index buf idx) off + +words2Nat :: [Word] -> Natural +words2Nat [] = 0 +words2Nat [w] = fromIntegral w +words2Nat ws = + if off /= 0 then error "words2Nat bad vec" else + NatJ# (BN# buf) + where + VP.Vector off len (Prim.ByteArray buf) = VP.fromList ws + +unpackWords :: ByteString -> [Word] +unpackWords = + \case buf | length buf <= 4 -> [unpackWord buf] + | otherwise -> go [] buf + where + go :: [Word] -> ByteString -> [Word] + go acc buf | null buf = reverse acc + go acc buf | otherwise = go (unpackWord buf : acc) (BS.drop 4 buf) + +unpackAtom :: ByteString -> Atom +unpackAtom = MkAtom . words2Nat . unpackWords . stripTrailingZeros + +loadFile :: FilePath -> IO Atom +loadFile = fmap unpackAtom . readFile + +loadJam :: FilePath -> IO (Maybe Noun) +loadJam = fmap cue . loadFile + +-- dumpJam :: FilePath -> Noun -> IO () +-- dumpJam pat = writeFile pat . packAtom . jam + +-- packWord :: Word -> ByteString +-- packWord buf = undefined + +-- packAtom :: Atom -> ByteString +-- packAtom = undefined + +dumpFlat :: Flat a => FilePath -> a -> IO () +dumpFlat pat = writeFile pat . flat + +loadFlat :: Flat a => FilePath -> IO (Either Text a) +loadFlat pat = do + bs <- readFile pat + pure $ mapLeft tshow $ unflat bs + +{- +/* u3i_bytes(): +** +** Copy `a` bytes from `b` to an LSB first atom. +*/ +u3_noun +u3i_bytes(c3_w a_w, + const c3_y* b_y) +{ + /* Strip trailing zeroes. + */ + while ( a_w && !b_y[a_w - 1] ) { + a_w--; + } + + /* Check for cat. + */ + if ( a_w <= 4 ) { + if ( !a_w ) { + return 0; + } + else if ( a_w == 1 ) { + return b_y[0]; + } + else if ( a_w == 2 ) { + return (b_y[0] | (b_y[1] << 8)); + } + else if ( a_w == 3 ) { + return (b_y[0] | (b_y[1] << 8) | (b_y[2] << 16)); + } + else if ( (b_y[3] <= 0x7f) ) { + return (b_y[0] | (b_y[1] << 8) | (b_y[2] << 16) | (b_y[3] << 24)); + } + } + + /* Allocate, fill, return. + */ + { + c3_w len_w = (a_w + 3) >> 2; + c3_w* nov_w = u3a_walloc((len_w + c3_wiseof(u3a_atom))); + u3a_atom* nov_u = (void*)nov_w; + + nov_u->mug_w = 0; + nov_u->len_w = len_w; + + /* Clear the words. + */ + { + c3_w i_w; + + for ( i_w=0; i_w < len_w; i_w++ ) { + nov_u->buf_w[i_w] = 0; + } + } + + /* Fill the bytes. + */ + { + c3_w i_w; + + for ( i_w=0; i_w < a_w; i_w++ ) { + nov_u->buf_w[i_w >> 2] |= (b_y[i_w] << ((i_w & 3) * 8)); + } + } + return u3a_to_pug(u3a_outa(nov_w)); + } +} +-} diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs index d7af7a452..a61830612 100644 --- a/pkg/hair/lib/Data/Noun/Zip.hs +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -29,6 +29,7 @@ import Data.Typeable (Typeable) import Control.Monad.State.Strict hiding (forM_, replicateM) import Control.Monad.Trans.Maybe +import qualified ClassyPrelude import qualified Data.Vector as V import qualified Data.List as L import qualified Data.Vector.Unboxed as UV @@ -95,16 +96,15 @@ refCount = go mempty go acc c@(Cell l r) = go (go (ins c acc) l) r zipTable :: Noun -> (Vector Noun, Map Noun Int) -zipTable top = (tbl, keys tbl) +zipTable top = (V.fromList tbl, keys) where - keys = mapFromList . V.toList . fmap swap . V.indexed - big = \case { Atom a -> a >= 128; _ -> True } - tbl = filter big - $ fmap fst - $ V.fromList + keys = mapFromList (ClassyPrelude.zip tbl [0..]) + big = \case Atom a -> a >= 127+8 + _ -> True + tbl = fmap fst $ sortBy (comparing snd) + $ filter (\(k,v) -> big k && v>1) $ mapToList - $ filterMap (> 1) $ refCount top zip :: Noun -> Zip diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 69e8b10b8..120009b7d 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -28,6 +28,7 @@ executables: dependencies: - async - base + - bytestring - case-insensitive - classy-prelude - containers @@ -45,6 +46,7 @@ dependencies: - multimap - para - pretty-show + - primitive - QuickCheck - semigroups - smallcheck diff --git a/pkg/hoon/.gitignore b/pkg/hoon/.gitignore new file mode 100644 index 000000000..c99ca9e13 --- /dev/null +++ b/pkg/hoon/.gitignore @@ -0,0 +1,2 @@ +.stack-work +*.cabal diff --git a/pkg/hair/lib/Language/Hoon/AST/Parser.hs b/pkg/hoon/lib/Language/Hoon/AST/Parser.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/AST/Parser.hs rename to pkg/hoon/lib/Language/Hoon/AST/Parser.hs diff --git a/pkg/hair/lib/Language/Hoon/AST/Types.hs b/pkg/hoon/lib/Language/Hoon/AST/Types.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/AST/Types.hs rename to pkg/hoon/lib/Language/Hoon/AST/Types.hs diff --git a/pkg/hair/lib/Language/Hoon/Desugar.hs b/pkg/hoon/lib/Language/Hoon/Desugar.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/Desugar.hs rename to pkg/hoon/lib/Language/Hoon/Desugar.hs diff --git a/pkg/hair/lib/Language/Hoon/IR/Desugar.hs b/pkg/hoon/lib/Language/Hoon/IR/Desugar.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/IR/Desugar.hs rename to pkg/hoon/lib/Language/Hoon/IR/Desugar.hs diff --git a/pkg/hair/lib/Language/Hoon/IR/Infer.hs b/pkg/hoon/lib/Language/Hoon/IR/Infer.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/IR/Infer.hs rename to pkg/hoon/lib/Language/Hoon/IR/Infer.hs diff --git a/pkg/hair/lib/Language/Hoon/IR/Ty.hs b/pkg/hoon/lib/Language/Hoon/IR/Ty.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/IR/Ty.hs rename to pkg/hoon/lib/Language/Hoon/IR/Ty.hs diff --git a/pkg/hair/lib/Language/Hoon/IR/Wing.hs b/pkg/hoon/lib/Language/Hoon/IR/Wing.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/IR/Wing.hs rename to pkg/hoon/lib/Language/Hoon/IR/Wing.hs diff --git a/pkg/hair/lib/Language/Hoon/LL/Gen.hs b/pkg/hoon/lib/Language/Hoon/LL/Gen.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/LL/Gen.hs rename to pkg/hoon/lib/Language/Hoon/LL/Gen.hs diff --git a/pkg/hair/lib/Language/Hoon/LL/Run.hs b/pkg/hoon/lib/Language/Hoon/LL/Run.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/LL/Run.hs rename to pkg/hoon/lib/Language/Hoon/LL/Run.hs diff --git a/pkg/hair/lib/Language/Hoon/LL/Types.hs b/pkg/hoon/lib/Language/Hoon/LL/Types.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/LL/Types.hs rename to pkg/hoon/lib/Language/Hoon/LL/Types.hs diff --git a/pkg/hair/lib/Language/Hoon/Nock/Types.hs b/pkg/hoon/lib/Language/Hoon/Nock/Types.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/Nock/Types.hs rename to pkg/hoon/lib/Language/Hoon/Nock/Types.hs diff --git a/pkg/hair/lib/Language/Hoon/SpecToBunt.hs b/pkg/hoon/lib/Language/Hoon/SpecToBunt.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/SpecToBunt.hs rename to pkg/hoon/lib/Language/Hoon/SpecToBunt.hs diff --git a/pkg/hair/lib/Language/Hoon/SpecToMold.hs b/pkg/hoon/lib/Language/Hoon/SpecToMold.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/SpecToMold.hs rename to pkg/hoon/lib/Language/Hoon/SpecToMold.hs diff --git a/pkg/hair/lib/Language/Hoon/Types.hs b/pkg/hoon/lib/Language/Hoon/Types.hs similarity index 100% rename from pkg/hair/lib/Language/Hoon/Types.hs rename to pkg/hoon/lib/Language/Hoon/Types.hs diff --git a/pkg/hoon/package.yaml b/pkg/hoon/package.yaml new file mode 100644 index 000000000..9cc4e550d --- /dev/null +++ b/pkg/hoon/package.yaml @@ -0,0 +1,79 @@ +name: language-hoon +version: 0.1.0 +license: AGPL-3.0-only + +library: + source-dirs: lib + ghc-options: + - -fwarn-incomplete-patterns + - -O2 + +dependencies: + - async + - base + - case-insensitive + - classy-prelude + - containers + - data-fix + - extra + - flat + - ghc-prim + - http-client + - http-types + - integer-gmp + - largeword + - lens + - megaparsec + - mtl + - multimap + - para + - pretty-show + - QuickCheck + - semigroups + - smallcheck + - stm + - stm-chans + - tasty + - tasty-quickcheck + - tasty-th + - text + - these + - time + - transformers + - unordered-containers + - vector + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveDataTypeable + - DeriveFoldable + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - EmptyDataDecls + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - NoImplicitPrelude + - NumericUnderscores + - OverloadedStrings + - PartialTypeSignatures + - QuasiQuotes + - Rank2Types + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - UnicodeSyntax + - ViewPatterns diff --git a/pkg/hair/stack.yaml b/stack.yaml similarity index 90% rename from pkg/hair/stack.yaml rename to stack.yaml index 2140ef2f3..e15320c3f 100644 --- a/pkg/hair/stack.yaml +++ b/stack.yaml @@ -1,7 +1,8 @@ resolver: lts-13.10 packages: - - . + - pkg/hair + - pkg/hoon ghc-options: vere: "-fobject-code" From a755880d464e30b93afc69051b9418877b29d4f2 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 19 May 2019 20:20:03 -0700 Subject: [PATCH 031/431] Debugging and Optimizing jam/cue --- pkg/hair/lib/Data/Noun/Jam.hs | 95 +++++++++++++++++++++++++++++++++-- pkg/hair/lib/Data/Noun/Zip.hs | 19 ++++--- 2 files changed, 104 insertions(+), 10 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index cf6e2205b..797716884 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -19,6 +19,80 @@ import Test.QuickCheck -- Length-Encoded Atoms -------------------------------------------------------- +bex :: (Num a, Bits a) => Int -> a +bex = shiftL 1 + +mat' :: Atom -> Buf +mat' 0 = Buf 1 1 +mat' atm = Buf bufWid buffer + where + atmWid = bitWidth atm + preWid = bitWidth (toAtom atmWid) + bufWid = preWid + preWid + atmWid - 1 + prefix = bex preWid + extras = takeBits (preWid-1) (toAtom atmWid) + suffix = xor extras (shiftL (takeBits (atmWid-1) atm) (preWid-1)) + buffer = bitConcat prefix suffix + +rub' :: Cursor -> Maybe Buf +rub' slc@(Cursor idx buf) = + leadingZeros slc >>= \case + 0 -> pure (Buf 1 0) + prefix -> pure (Buf sz val) + where + widIdx = idx + 1 + prefix + width = fromSlice (Slice widIdx (prefix - 1) buf) + datIdx = widIdx + (prefix-1) + datWid = fromIntegral (2^(prefix-1) + width) - 1 + sz = datWid + (2*prefix) + val = bex datWid .|. fromSlice (Slice datIdx datWid buf) + +jam' :: Noun -> Atom +jam' = toAtom . fst . go 0 mempty + where + insertNoun :: Noun -> Int -> Map Noun Int -> Map Noun Int + insertNoun n i tbl = lookup n tbl + & maybe tbl (const $ insertMap n i tbl) + + go :: Int -> Map Noun Int -> Noun -> (Buf, Map Noun Int) + go off oldTbl noun = + let tbl = insertNoun noun off oldTbl in + case (lookup noun oldTbl, noun) of + (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) -> + (Buf (1+sz) (shiftL res 1), tbl) + where Buf sz res = mat' atm + (Just ref, _) -> + (Buf (2+sz) (xor 3 (shiftL res 2)), tbl) + where Buf sz res = mat' (toAtom ref) + (Nothing, Atom atm) -> + (Buf (1+sz) (shiftL res 1), tbl) + where Buf sz res = mat' atm + (Nothing, Cell lef rit) -> + (Buf (2+lSz+rSz) (xor 1 (shiftL (lRes .|. shiftL rRes lSz) 2)), rTbl) + where (Buf lSz lRes, lTbl) = go (off+2) tbl lef + (Buf rSz rRes, rTbl) = go (off+lSz) lTbl rit + +cue' :: Atom -> Maybe Noun +cue' buf = view _2 <$> go mempty 0 + where + go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun) + go tbl i = + case (bitIdx i buf, bitIdx (i+1) buf) of + (False, _ ) -> do Buf wid at <- rub' (Cursor (i+1) buf) + let r = toNoun at + pure (wid+1, r, insertMap i r tbl) + (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) + (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) + let r = Cell lef rit + pure (2+lSz+rSz, r, insertMap i r tbl) + (True, True ) -> do Buf wid at <- rub' (Cursor (i+2) buf) + r <- lookup (fromIntegral at) tbl & \case + Nothing -> error ("bad-ref-" <> show at) + Just ix -> Just ix + pure (2+wid, r, tbl) + +-------------------------------------------------------------------------------- + mat :: Atom -> Buf mat 0 = Buf 1 1 mat atm = Buf bufWid buffer @@ -44,7 +118,6 @@ rub slc@(Cursor idx buf) = sz = datWid + (2*prefix) val = fromSlice (Slice datIdx datWid buf) - -- Noun Serialization ---------------------------------------------------------- jam :: Noun -> Atom @@ -57,7 +130,7 @@ jam = toAtom . fst . go 0 mempty go :: Int -> Map Noun Int -> Noun -> (Buf, Map Noun Int) go off oldTbl noun = let tbl = insertNoun noun off oldTbl in - case (Nothing :: Maybe Int, noun) of + case (lookup noun oldTbl, noun) of (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) -> (Buf (1+sz) (shiftL res 1), tbl) where Buf sz res = mat atm @@ -73,10 +146,13 @@ jam = toAtom . fst . go 0 mempty (Buf rSz rRes, rTbl) = go (off+lSz) lTbl rit + leadingZeros :: Cursor -> Maybe Int leadingZeros (Cursor idx buf) = go 0 where wid = bitWidth buf - go n = do guard (n < wid) + go n = do () <- if (n < wid) then pure () + else error "infinite-atom" + guard (n < wid) if bitIdx (idx+n) buf then pure n else go (n+1) cue :: Atom -> Maybe Noun @@ -93,7 +169,9 @@ cue buf = view _2 <$> go mempty 0 let r = Cell lef rit pure (2+lSz+rSz, r, insertMap i r tbl) (True, True ) -> do Buf wid at <- rub (Cursor (i+2) buf) - r <- lookup (fromIntegral at) tbl + r <- lookup (fromIntegral at) tbl & \case + Nothing -> error ("bad-ref-" <> show at) + Just ix -> Just ix pure (2+wid, r, tbl) @@ -119,5 +197,14 @@ prop_matRub atm = matSz==rubSz && rubRes==atm Buf matSz matBuf = mat atm Buf rubSz rubRes = fromMaybe mempty (rub $ Cursor 0 matBuf) +prop_jamCue' :: Noun -> Bool +prop_jamCue' n = Just n == cue' (jam' n) + +prop_matRub' :: Atom -> Bool +prop_matRub' atm = matSz==rubSz && rubRes==atm + where + Buf matSz matBuf = mat' atm + Buf rubSz rubRes = fromMaybe mempty (rub' $ Cursor 0 matBuf) + main :: IO () main = $(defaultMainGenerator) diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hair/lib/Data/Noun/Zip.hs index a61830612..6a548f92b 100644 --- a/pkg/hair/lib/Data/Noun/Zip.hs +++ b/pkg/hair/lib/Data/Noun/Zip.hs @@ -134,7 +134,7 @@ unzip (V.fromList -> dups, top) = recover top compareSize :: Noun -> Int compareSize n = flatSz - jamSz where - Buf jamSz _ = fromAtom (jam n) + Buf jamSz _ = fromAtom (jam' n) flatSz = length (bits (zip n)) compareZipCompression :: Noun -> Int @@ -147,7 +147,7 @@ compareRawToJam :: Noun -> Int compareRawToJam n = rawSz - jamSz where rawSz = length (bits n) - Buf jamSz _ = fromAtom (jam n) + Buf jamSz _ = fromAtom (jam' n) prop_zipUnzip :: Noun -> Bool prop_zipUnzip n = Just n == unzip (zip n) @@ -184,7 +184,7 @@ nounSizes :: (Noun -> Int) -> Int -> [(Int, Noun)] nounSizes f sz = sort (allNouns sz <&> \n -> (f n, n)) jamSz :: Noun -> Int -jamSz = (\(Buf sz _) -> sz) . fromAtom . jam +jamSz = (\(Buf sz _) -> sz) . fromAtom . jam' showFlatZipSizes :: Int -> IO () showFlatZipSizes dep = traverse_ print (nounSizes (length . bits . zip) dep) @@ -192,15 +192,22 @@ showFlatZipSizes dep = traverse_ print (nounSizes (length . bits . zip) dep) showJamSizes :: Int -> IO () showJamSizes dep = traverse_ print (nounSizes jamSz dep) -sumFlatZipSizes :: Int -> Int -sumFlatZipSizes dep = sum $ map fst (nounSizes (length . bits . zip) dep) +-------------------------------------------------------------------------------- sumJamSizes :: Int -> Int sumJamSizes dep = sum $ map fst (nounSizes jamSz dep) +sumFlatSizes :: Int -> Int +sumFlatSizes dep = sum $ map fst (nounSizes (length . bits) dep) + +sumFlatZipSizes :: Int -> Int +sumFlatZipSizes dep = sum $ map fst (nounSizes (length . bits . zip) dep) + +-------------------------------------------------------------------------------- + compareSizes :: (Noun -> Int) -> IO () compareSizes f = do - nouns <- join <$> (replicateM 50 (sample' (arbitrary :: Gen Noun)) :: IO [[Noun]]) + nouns <- join <$> (replicateM 100 (sample' (arbitrary :: Gen Noun)) :: IO [[Noun]]) traverse_ print $ reverse $ ordNub $ sort From 83db727920af49caf1690df4ece443d49766d239 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 19 May 2019 23:14:07 -0700 Subject: [PATCH 032/431] Tested the shit out of my pill loading code. --- pkg/hair/lib/Data/Noun/Atom.hs | 4 + pkg/hair/lib/Data/Noun/Jam.hs | 30 +++--- pkg/hair/lib/Data/Noun/Pill.hs | 162 ++++++++++++++++++++++++++------- 3 files changed, 153 insertions(+), 43 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index b35ff44b9..0ce80bc29 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -130,6 +130,10 @@ fromCursor (Cursor off buf) = shiftR buf off bumpCursor :: Word -> Cursor -> Cursor bumpCursor off = over cOffset (+ fromIntegral off) +instance IsAtom Cursor where + toAtom (Cursor off bits) = shiftR bits off + fromAtom = Cursor 0 + -------------------------------------------------------------------------------- diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index 797716884..82ea33f28 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -105,18 +105,24 @@ mat atm = Buf bufWid buffer suffix = xor extras (shiftL atm (preWid-1)) buffer = bitConcat prefix suffix +bufVal Nothing = "" +bufVal (Just (Buf sz v)) = show v <> " [" <> show sz <> "]" + rub :: Cursor -> Maybe Buf -rub slc@(Cursor idx buf) = - leadingZeros slc >>= \case - 0 -> pure (Buf 1 0) - prefix -> pure (Buf sz val) - where - widIdx = idx + 1 + prefix - width = fromSlice (Slice widIdx (prefix - 1) buf) - datIdx = widIdx + (prefix-1) - datWid = fromIntegral $ 2^(prefix-1) + width - sz = datWid + (2*prefix) - val = fromSlice (Slice datIdx datWid buf) +rub slc@(Cursor idx buf) = trace (bufVal res) res + where + res = + trace ("rub-" <> show idx) $ + leadingZeros slc >>= \case + 0 -> pure (Buf 1 0) + prefix -> pure (Buf sz val) + where + widIdx = idx + 1 + prefix + width = fromSlice (Slice widIdx (prefix - 1) buf) + datIdx = widIdx + (prefix-1) + datWid = fromIntegral $ 2^(prefix-1) + width + sz = datWid + (2*prefix) + val = fromSlice (Slice datIdx datWid buf) -- Noun Serialization ---------------------------------------------------------- @@ -160,6 +166,7 @@ cue buf = view _2 <$> go mempty 0 where go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun) go tbl i = + trace ("go-" <> show i) case (bitIdx i buf, bitIdx (i+1) buf) of (False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf) let r = toNoun at @@ -169,6 +176,7 @@ cue buf = view _2 <$> go mempty 0 let r = Cell lef rit pure (2+lSz+rSz, r, insertMap i r tbl) (True, True ) -> do Buf wid at <- rub (Cursor (i+2) buf) + traceM ("ref-" <> show at) r <- lookup (fromIntegral at) tbl & \case Nothing -> error ("bad-ref-" <> show at) Just ix -> Just ix diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs index 1b6eea589..6659d6d70 100644 --- a/pkg/hair/lib/Data/Noun/Pill.hs +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -1,65 +1,127 @@ {-# LANGUAGE MagicHash #-} +-- TODO Handle 32-bit architectures + module Data.Noun.Pill where import ClassyPrelude -import Data.Noun +import Data.Noun hiding (toList, fromList) import Data.Noun.Atom -import Data.Noun.Jam +import Data.Noun.Jam hiding (main) import Data.Flat import Control.Monad.Except -import Control.Lens +import Control.Lens hiding (index, Index) import Data.Either.Extra (mapLeft) import GHC.Natural import Data.Bits import GHC.Integer.GMP.Internals +import GHC.Int +import GHC.Word +import GHC.Exts (sizeofByteArray#) import qualified Data.Primitive.ByteArray as Prim import qualified Data.Vector.Primitive as VP import qualified Data.ByteString as BS +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck as QC +import Test.QuickCheck + -------------------------------------------------------------------------------- -stripTrailingZeros :: ByteString -> ByteString -stripTrailingZeros buf = BS.take (len - go 0 (len - 1)) buf +stripTrailingZeros :: IsSequence seq + => Int ~ Index seq + => (Eq (Element seq), Num (Element seq)) + => seq -> seq +stripTrailingZeros buf = take (len - go 0 (len - 1)) buf where len = length buf - go n i | i < 0 = n - | 0 == BS.index buf i = go (n+1) (i-1) - | otherwise = n + go n i | i < 0 = n + | 0 == unsafeIndex buf i = go (n+1) (i-1) + | otherwise = n -unpackWord :: ByteString -> Word -unpackWord buf = - case length buf of - 0 -> 0 - 1 -> i 0 0 - 2 -> i 0 0 .|. i 1 8 - 3 -> i 0 0 .|. i 1 8 .|. i 2 16 - n -> i 0 0 .|. i 1 8 .|. i 2 16 .|. i 3 24 +-------------------------------------------------------------------------------- + +wordArrToBigNat :: VP.Vector Word -> BigNat +wordArrToBigNat v@(VP.Vector off (I# len) (Prim.ByteArray buf)) = + case VP.length v of + 0 -> zeroBigNat + 1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w) + n -> if off /= 0 then error "words2Nat: bad-vec" else + byteArrayToBigNat# buf len + +wordsToBigNat :: [Word] -> BigNat +wordsToBigNat = wordArrToBigNat . VP.fromList + +bigNatToWords :: BigNat -> [Word] +bigNatToWords (BN# bArr) = + stripTrailingZeros + $ VP.toList + $ VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8) + $ Prim.ByteArray bArr + +-------------------------------------------------------------------------------- + +naturalToBigNat :: Natural -> BigNat +naturalToBigNat (NatS# w) = wordToBigNat w +naturalToBigNat (NatJ# bn) = bn + +wordsToNatural :: [Word] -> Natural +wordsToNatural [] = 0 +wordsToNatural [w] = fromIntegral w +wordsToNatural ws = NatJ# (wordsToBigNat ws) + +naturalToWords :: Natural -> [Word] +naturalToWords = bigNatToWords . naturalToBigNat + +-------------------------------------------------------------------------------- + +dumbPackWord :: ByteString -> Word +dumbPackWord bs = go 0 0 (toList bs) where + go acc i [] = acc + go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs + +-- TODO This assumes 64-bit words +packWord :: ByteString -> Word +packWord buf = go 0 0 (toList buf) + where + go acc idx [] = acc + go acc idx (x:xs) = go (acc .|. i idx (8*idx)) (idx+1) xs + i :: Int -> Int -> Word i idx off = shiftL (fromIntegral $ BS.index buf idx) off -words2Nat :: [Word] -> Natural -words2Nat [] = 0 -words2Nat [w] = fromIntegral w -words2Nat ws = - if off /= 0 then error "words2Nat bad vec" else - NatJ# (BN# buf) +-- TODO This assumes 64-bit words +unpackWord :: Word -> ByteString +unpackWord wor = reverse $ fromList $ go 0 [] where - VP.Vector off len (Prim.ByteArray buf) = VP.fromList ws + go i acc | i >= 8 = acc + go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc) -unpackWords :: ByteString -> [Word] -unpackWords = - \case buf | length buf <= 4 -> [unpackWord buf] - | otherwise -> go [] buf +-------------------------------------------------------------------------------- + +bytesToWords :: ByteString -> [Word] +bytesToWords = go [] where go :: [Word] -> ByteString -> [Word] go acc buf | null buf = reverse acc - go acc buf | otherwise = go (unpackWord buf : acc) (BS.drop 4 buf) + go acc buf | otherwise = go (packWord buf : acc) (drop 8 buf) + +wordsToBytes :: [Word] -> ByteString +wordsToBytes = concat . fmap unpackWord + +-------------------------------------------------------------------------------- + +dumbUnpackAtom :: ByteString -> Atom +dumbUnpackAtom bs = go 0 0 (toList bs) + where + go acc i [] = acc + go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs unpackAtom :: ByteString -> Atom -unpackAtom = MkAtom . words2Nat . unpackWords . stripTrailingZeros +unpackAtom = MkAtom . wordsToNatural . bytesToWords . stripTrailingZeros loadFile :: FilePath -> IO Atom loadFile = fmap unpackAtom . readFile @@ -70,9 +132,6 @@ loadJam = fmap cue . loadFile -- dumpJam :: FilePath -> Noun -> IO () -- dumpJam pat = writeFile pat . packAtom . jam --- packWord :: Word -> ByteString --- packWord buf = undefined - -- packAtom :: Atom -> ByteString -- packAtom = undefined @@ -84,6 +143,45 @@ loadFlat pat = do bs <- readFile pat pure $ mapLeft tshow $ unflat bs +data Pill = Brass | Ivory | Solid + +tryPill :: Pill -> IO String +tryPill pill = + loadJam pat <&> \case Nothing -> "nil"; Just (Atom _) -> "atom"; _ -> "cell" + where + pat = case pill of Brass -> "./bin/brass.pill" + Solid -> "./bin/solid.pill" + Ivory -> "./bin/ivory.pill" + +-- Tests ----------------------------------------------------------------------- + +instance Arbitrary BigNat where + arbitrary = naturalToBigNat <$> arbitrary + +instance Show BigNat where + show = show . NatJ# + +roundTrip :: Eq a => (a -> b) -> (b -> a) -> (a -> Bool) +roundTrip f g x = x == g (f x) + +equiv :: Eq b => (a -> b) -> (a -> b) -> (a -> Bool) +equiv f g x = f x == g x + +check :: Atom -> Atom +check = toAtom . (id :: Integer -> Integer) . fromAtom + +prop_packWord = equiv packWord dumbPackWord . fromList +prop_unpackBigNat = roundTrip bigNatToWords wordsToBigNat +prop_packBigNat = roundTrip wordsToBigNat bigNatToWords . stripTrailingZeros +prop_unpackDumb = equiv unpackAtom dumbUnpackAtom . fromList +prop_packUnpackWord = roundTrip unpackWord packWord +prop_explodeBytes = roundTrip wordsToBytes bytesToWords + +-------------------------------------------------------------------------------- + +main :: IO () +main = $(defaultMainGenerator) + {- /* u3i_bytes(): ** From dc5db9f3d1c7c7645dacc239f0122fa711a8a57f Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 20 May 2019 16:04:28 -0700 Subject: [PATCH 033/431] Loading pills works; initial work on jets for jam/cue. --- pkg/hair/app/uterm/Main.hs | 20 ++- pkg/hair/lib/Data/Noun/Atom.hs | 18 +-- pkg/hair/lib/Data/Noun/Jam.hs | 32 ++--- pkg/hair/lib/Data/Noun/Jam/Fast.hs | 68 +++++++++ pkg/hair/lib/Data/Noun/Pill.hs | 221 +++++++++++++---------------- pkg/hair/package.yaml | 6 + 6 files changed, 219 insertions(+), 146 deletions(-) create mode 100644 pkg/hair/lib/Data/Noun/Jam/Fast.hs diff --git a/pkg/hair/app/uterm/Main.hs b/pkg/hair/app/uterm/Main.hs index 2e7443e3e..01ca5e0f9 100644 --- a/pkg/hair/app/uterm/Main.hs +++ b/pkg/hair/app/uterm/Main.hs @@ -2,8 +2,26 @@ module Main where import ClassyPrelude import Control.Lens +import Data.Noun.Pill hiding (main) -------------------------------------------------------------------------------- main :: IO () -main = "Hello World" & putStrLn +main = do + print "load brass" >> void getLine + tryLoadPill Brass + + print "load ivory" >> void getLine + tryLoadPill Ivory + + print "load solid" >> void getLine + tryLoadPill Solid + + print "cue brass" >> void getLine + tryCuePill Brass + + print "cue ivory" >> void getLine + tryCuePill Ivory + + print "cue solid" >> void getLine + tryCuePill Solid diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index 0ce80bc29..c3a83ce1b 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -104,20 +104,22 @@ instance IsAtom Integer where TODO Support 32-bit archetectures. -} -wordBitWidth :: Word# -> Word# -wordBitWidth w = minusWord# 64## (clz# w) +wordBitWidth# :: Word# -> Word# +wordBitWidth# w = minusWord# 64## (clz# w) -bigNatBitWidth :: BigNat -> Word# -bigNatBitWidth nat = +bigNatBitWidth# :: BigNat -> Word# +bigNatBitWidth# nat = lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##) where (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1# - lswBits = wordBitWidth (indexBigNat# nat lastIdx) + lswBits = wordBitWidth# (indexBigNat# nat lastIdx) -bitWidth :: Atom -> Int -bitWidth (MkAtom (NatS# gl)) = I# (word2Int# (wordBitWidth gl)) -bitWidth (MkAtom (NatJ# bn)) = I# (word2Int# (bigNatBitWidth bn)) +atomBitWidth# :: Atom -> Word# +atomBitWidth# (MkAtom (NatS# gl)) = wordBitWidth# gl +atomBitWidth# (MkAtom (NatJ# bn)) = bigNatBitWidth# bn +bitWidth :: Num a => Atom -> a +bitWidth a = fromIntegral (W# (atomBitWidth# a)) -------------------------------------------------------------------------------- diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index 82ea33f28..d55244f72 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -109,23 +109,23 @@ bufVal Nothing = "" bufVal (Just (Buf sz v)) = show v <> " [" <> show sz <> "]" rub :: Cursor -> Maybe Buf -rub slc@(Cursor idx buf) = trace (bufVal res) res - where - res = - trace ("rub-" <> show idx) $ - leadingZeros slc >>= \case - 0 -> pure (Buf 1 0) - prefix -> pure (Buf sz val) - where - widIdx = idx + 1 + prefix - width = fromSlice (Slice widIdx (prefix - 1) buf) - datIdx = widIdx + (prefix-1) - datWid = fromIntegral $ 2^(prefix-1) + width - sz = datWid + (2*prefix) - val = fromSlice (Slice datIdx datWid buf) +rub slc@(Cursor idx buf) = + leadingZeros slc >>= \case + 0 -> pure (Buf 1 0) + prefix -> pure (Buf sz val) + where + widIdx = idx + 1 + prefix + width = fromSlice (Slice widIdx (prefix - 1) buf) + datIdx = widIdx + (prefix-1) + datWid = fromIntegral $ 2^(prefix-1) + width + sz = datWid + (2*prefix) + val = fromSlice (Slice datIdx datWid buf) -- Noun Serialization ---------------------------------------------------------- +-- bex can be implemented using +-- `mpz_mul_2exp(a_mp, a_mp, a); + jam :: Noun -> Atom jam = toAtom . fst . go 0 mempty where @@ -166,7 +166,7 @@ cue buf = view _2 <$> go mempty 0 where go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun) go tbl i = - trace ("go-" <> show i) + -- trace ("go-" <> show i) case (bitIdx i buf, bitIdx (i+1) buf) of (False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf) let r = toNoun at @@ -176,7 +176,7 @@ cue buf = view _2 <$> go mempty 0 let r = Cell lef rit pure (2+lSz+rSz, r, insertMap i r tbl) (True, True ) -> do Buf wid at <- rub (Cursor (i+2) buf) - traceM ("ref-" <> show at) + -- traceM ("ref-" <> show at) r <- lookup (fromIntegral at) tbl & \case Nothing -> error ("bad-ref-" <> show at) Just ix -> Just ix diff --git a/pkg/hair/lib/Data/Noun/Jam/Fast.hs b/pkg/hair/lib/Data/Noun/Jam/Fast.hs new file mode 100644 index 000000000..8413de790 --- /dev/null +++ b/pkg/hair/lib/Data/Noun/Jam/Fast.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE MagicHash #-} + +module Data.Noun.Jam.Fast where + +import ClassyPrelude +import Data.Noun +import Data.Noun.Atom +import Data.Noun.Poet +import Data.Bits +import Control.Lens +import Text.Printf +import GHC.Prim +import GHC.Word +import GHC.Natural + +import Data.Map (Map) +import Control.Monad (guard) + +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck as QC +import Test.QuickCheck + +-- High-Performance Jam -------------------------------------------------------- + +matSz# :: Atom -> Word# +matSz# 0 = 1## +matSz# a = preW `plusWord#` preW `plusWord#` atmW + where + atmW = atomBitWidth# a + preW = wordBitWidth# atmW + +refSz# :: Word# -> Word# +refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) + +nounSz# :: Noun -> Word# +nounSz# (Atom a) = 1## `plusWord#` (matSz# a) +nounSz# (Cell l r) = 2## `plusWord#` (nounSz# l) `plusWord#` (nounSz# r) + +jamSz :: Noun -> Word +jamSz = fst . go 0 mempty + where + insertNoun :: Noun -> Word -> Map Noun Word -> Map Noun Word + insertNoun n i tbl = lookup n tbl + & maybe tbl (const $ insertMap n i tbl) + + go :: Word -> Map Noun Word -> Noun -> (Word, Map Noun Word) + go off oldTbl noun = + let tbl = insertNoun noun off oldTbl in + case lookup noun oldTbl of + Nothing -> + case noun of + Atom atm -> + (1 + W# (matSz# atm), tbl) + Cell l r -> + let (lSz, tbl) = go (2+off) tbl l in + let (rSz, tbl) = go (2+off+lSz) tbl r in + (2 + lSz + rSz, tbl) + Just (W# ref) -> + let refSz = W# (wordBitWidth# ref) in + case noun of + Atom atm -> + let worSz = W# (matSz# atm) in + if worSz > refSz + then (refSz, oldTbl) + else (1 + worSz, tbl) + Cell _ _ -> + (refSz, oldTbl) diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs index 6659d6d70..003a75623 100644 --- a/pkg/hair/lib/Data/Noun/Pill.hs +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -19,8 +19,10 @@ import GHC.Int import GHC.Word import GHC.Exts (sizeofByteArray#) +import qualified Data.Vector as V import qualified Data.Primitive.ByteArray as Prim import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Unboxed as VU import qualified Data.ByteString as BS import Test.Tasty @@ -43,23 +45,25 @@ stripTrailingZeros buf = take (len - go 0 (len - 1)) buf -------------------------------------------------------------------------------- -wordArrToBigNat :: VP.Vector Word -> BigNat -wordArrToBigNat v@(VP.Vector off (I# len) (Prim.ByteArray buf)) = +wordsToBigNat :: VP.Vector Word -> BigNat +wordsToBigNat v@(VP.Vector off (I# len) (Prim.ByteArray buf)) = case VP.length v of 0 -> zeroBigNat 1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w) n -> if off /= 0 then error "words2Nat: bad-vec" else byteArrayToBigNat# buf len -wordsToBigNat :: [Word] -> BigNat -wordsToBigNat = wordArrToBigNat . VP.fromList +bigNatToWords :: BigNat -> VP.Vector Word +bigNatToWords (BN# bArr) = VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8) + $ Prim.ByteArray bArr -bigNatToWords :: BigNat -> [Word] -bigNatToWords (BN# bArr) = - stripTrailingZeros - $ VP.toList - $ VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8) - $ Prim.ByteArray bArr +-------------------------------------------------------------------------------- + +bigNatToBits :: BigNat -> VU.Vector Bool +bigNatToBits = undefined + +bitsToBigNat :: BigNat -> VU.Vector Bool +bitsToBigNat = undefined -------------------------------------------------------------------------------- @@ -67,12 +71,19 @@ naturalToBigNat :: Natural -> BigNat naturalToBigNat (NatS# w) = wordToBigNat w naturalToBigNat (NatJ# bn) = bn -wordsToNatural :: [Word] -> Natural -wordsToNatural [] = 0 -wordsToNatural [w] = fromIntegral w -wordsToNatural ws = NatJ# (wordsToBigNat ws) +bigNatToNatural :: BigNat -> Natural +bigNatToNatural bn = + case sizeofBigNat# bn of + 0# -> 0 + 1# -> NatS# (bigNatToWord bn) + _ -> NatJ# bn -naturalToWords :: Natural -> [Word] +-------------------------------------------------------------------------------- + +wordsToNatural :: VP.Vector Word -> Natural +wordsToNatural = bigNatToNatural . wordsToBigNat + +naturalToWords :: Natural -> VP.Vector Word naturalToWords = bigNatToWords . naturalToBigNat -------------------------------------------------------------------------------- @@ -85,13 +96,13 @@ dumbPackWord bs = go 0 0 (toList bs) -- TODO This assumes 64-bit words packWord :: ByteString -> Word -packWord buf = go 0 0 (toList buf) +packWord buf = go 0 0 where - go acc idx [] = acc - go acc idx (x:xs) = go (acc .|. i idx (8*idx)) (idx+1) xs + top = min 8 (length buf) + i idx off = shiftL (fromIntegral $ BS.index buf idx) off + go acc idx = if idx >= top then acc else + go (acc .|. i idx (8*idx)) (idx+1) - i :: Int -> Int -> Word - i idx off = shiftL (fromIntegral $ BS.index buf idx) off -- TODO This assumes 64-bit words unpackWord :: Word -> ByteString @@ -102,38 +113,41 @@ unpackWord wor = reverse $ fromList $ go 0 [] -------------------------------------------------------------------------------- -bytesToWords :: ByteString -> [Word] -bytesToWords = go [] - where - go :: [Word] -> ByteString -> [Word] - go acc buf | null buf = reverse acc - go acc buf | otherwise = go (packWord buf : acc) (drop 8 buf) +bytesToWords :: ByteString -> VP.Vector Word +bytesToWords bytes = + VP.generate (1 + length bytes `div` 8) $ \i -> + packWord (BS.drop (i*8) bytes) -wordsToBytes :: [Word] -> ByteString -wordsToBytes = concat . fmap unpackWord +fromPrimVec :: Prim a => VP.Vector a -> V.Vector a +fromPrimVec vp = V.generate (VP.length vp) (VP.unsafeIndex vp) + +wordsToBytes :: VP.Vector Word -> ByteString +wordsToBytes = stripTrailingZeros . concat . fmap unpackWord . fromPrimVec -------------------------------------------------------------------------------- -dumbUnpackAtom :: ByteString -> Atom -dumbUnpackAtom bs = go 0 0 (toList bs) +dumbPackAtom :: ByteString -> Atom +dumbPackAtom bs = go 0 0 (toList bs) where go acc i [] = acc go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs -unpackAtom :: ByteString -> Atom -unpackAtom = MkAtom . wordsToNatural . bytesToWords . stripTrailingZeros +packAtom :: ByteString -> Atom +packAtom = MkAtom . wordsToNatural . bytesToWords . stripTrailingZeros + +unpackAtom :: Atom -> ByteString +unpackAtom (MkAtom a) = wordsToBytes (naturalToWords a) + +-------------------------------------------------------------------------------- loadFile :: FilePath -> IO Atom -loadFile = fmap unpackAtom . readFile +loadFile = fmap packAtom . readFile loadJam :: FilePath -> IO (Maybe Noun) loadJam = fmap cue . loadFile --- dumpJam :: FilePath -> Noun -> IO () --- dumpJam pat = writeFile pat . packAtom . jam - --- packAtom :: Atom -> ByteString --- packAtom = undefined +dumpJam :: FilePath -> Noun -> IO () +dumpJam pat = writeFile pat . unpackAtom . jam dumpFlat :: Flat a => FilePath -> a -> IO () dumpFlat pat = writeFile pat . flat @@ -145,16 +159,31 @@ loadFlat pat = do data Pill = Brass | Ivory | Solid -tryPill :: Pill -> IO String -tryPill pill = - loadJam pat <&> \case Nothing -> "nil"; Just (Atom _) -> "atom"; _ -> "cell" - where - pat = case pill of Brass -> "./bin/brass.pill" - Solid -> "./bin/solid.pill" - Ivory -> "./bin/ivory.pill" +instance Show Pill where + show = \case + Brass -> "./bin/brass.pill" + Solid -> "./bin/solid.pill" + Ivory -> "./bin/ivory.pill" + +tryLoadPill :: Pill -> IO () +tryLoadPill pill = do + a@(MkAtom nat) <- loadFile (show pill) + putStrLn "loaded" + print (a > 0) + putStrLn "evaled" + print (take 10 $ VP.toList $ naturalToWords nat) + +tryCuePill :: Pill -> IO () +tryCuePill pill = + loadJam (show pill) >>= \case Nothing -> print "nil" + Just (Atom _) -> print "atom" + _ -> print "cell" -- Tests ----------------------------------------------------------------------- +instance Arbitrary ByteString where + arbitrary = fromList <$> arbitrary + instance Arbitrary BigNat where arbitrary = naturalToBigNat <$> arbitrary @@ -162,7 +191,7 @@ instance Show BigNat where show = show . NatJ# roundTrip :: Eq a => (a -> b) -> (b -> a) -> (a -> Bool) -roundTrip f g x = x == g (f x) +roundTrip dump load x = x == load (dump x) equiv :: Eq b => (a -> b) -> (a -> b) -> (a -> Bool) equiv f g x = f x == g x @@ -170,83 +199,33 @@ equiv f g x = f x == g x check :: Atom -> Atom check = toAtom . (id :: Integer -> Integer) . fromAtom -prop_packWord = equiv packWord dumbPackWord . fromList -prop_unpackBigNat = roundTrip bigNatToWords wordsToBigNat -prop_packBigNat = roundTrip wordsToBigNat bigNatToWords . stripTrailingZeros -prop_unpackDumb = equiv unpackAtom dumbUnpackAtom . fromList -prop_packUnpackWord = roundTrip unpackWord packWord -prop_explodeBytes = roundTrip wordsToBytes bytesToWords +clean :: IsSequence seq + => Int ~ Index seq + => (Eq (Element seq), Num (Element seq)) + => seq -> seq +clean = stripTrailingZeros + +prop_packWordSane = equiv packWord dumbPackWord . fromList +prop_packWord = roundTrip unpackWord packWord +prop_unpackWord = roundTrip packWord (clean . unpackWord) . clean . take 8 + +prop_unpackBigNat = roundTrip bigNatToWords wordsToBigNat + +prop_packBigNat = roundTrip (wordsToBigNat . VP.fromList) + (clean . VP.toList . bigNatToWords) + . clean + +prop_implodeBytes = roundTrip bytesToWords wordsToBytes . clean + +prop_explodeBytes = roundTrip (wordsToBytes . VP.fromList) + (clean . VP.toList . bytesToWords) + . clean + +prop_packAtomSane = equiv packAtom dumbPackAtom . fromList +prop_unpackAtom = roundTrip unpackAtom packAtom +prop_packAtom = roundTrip packAtom unpackAtom . clean -------------------------------------------------------------------------------- main :: IO () main = $(defaultMainGenerator) - -{- -/* u3i_bytes(): -** -** Copy `a` bytes from `b` to an LSB first atom. -*/ -u3_noun -u3i_bytes(c3_w a_w, - const c3_y* b_y) -{ - /* Strip trailing zeroes. - */ - while ( a_w && !b_y[a_w - 1] ) { - a_w--; - } - - /* Check for cat. - */ - if ( a_w <= 4 ) { - if ( !a_w ) { - return 0; - } - else if ( a_w == 1 ) { - return b_y[0]; - } - else if ( a_w == 2 ) { - return (b_y[0] | (b_y[1] << 8)); - } - else if ( a_w == 3 ) { - return (b_y[0] | (b_y[1] << 8) | (b_y[2] << 16)); - } - else if ( (b_y[3] <= 0x7f) ) { - return (b_y[0] | (b_y[1] << 8) | (b_y[2] << 16) | (b_y[3] << 24)); - } - } - - /* Allocate, fill, return. - */ - { - c3_w len_w = (a_w + 3) >> 2; - c3_w* nov_w = u3a_walloc((len_w + c3_wiseof(u3a_atom))); - u3a_atom* nov_u = (void*)nov_w; - - nov_u->mug_w = 0; - nov_u->len_w = len_w; - - /* Clear the words. - */ - { - c3_w i_w; - - for ( i_w=0; i_w < len_w; i_w++ ) { - nov_u->buf_w[i_w] = 0; - } - } - - /* Fill the bytes. - */ - { - c3_w i_w; - - for ( i_w=0; i_w < a_w; i_w++ ) { - nov_u->buf_w[i_w >> 2] |= (b_y[i_w] << ((i_w & 3) * 8)); - } - } - return u3a_to_pug(u3a_outa(nov_w)); - } -} --} diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 120009b7d..2bbbb4df5 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -13,6 +13,12 @@ executables: main: Main.hs source-dirs: app/uterm dependencies: ["vere"] + ghc-options: + - -threaded + - -rtsopts + - "-with-rtsopts=-H128m" + - -fwarn-incomplete-patterns + - -O2 vere: main: Main.hs From a66aeb398a5543318b2ee70d45404ff1c9beac9d Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 20 May 2019 16:40:02 -0700 Subject: [PATCH 034/431] Language.Attilla --- pkg/hoon/lib/Language/Attila/AST/Parser.hs | 345 +++++++++++++++++++++ pkg/hoon/lib/Language/Attila/AST/Types.hs | 66 ++++ 2 files changed, 411 insertions(+) create mode 100644 pkg/hoon/lib/Language/Attila/AST/Parser.hs create mode 100644 pkg/hoon/lib/Language/Attila/AST/Types.hs diff --git a/pkg/hoon/lib/Language/Attila/AST/Parser.hs b/pkg/hoon/lib/Language/Attila/AST/Parser.hs new file mode 100644 index 000000000..f13bd7eee --- /dev/null +++ b/pkg/hoon/lib/Language/Attila/AST/Parser.hs @@ -0,0 +1,345 @@ +-- TODO Handle comments + +module Language.Attila.AST.Parser where + +import Language.Hoon.AST.Types +import ClassyPrelude hiding (head, many, some, try) +import Control.Lens +import Text.Megaparsec +import Text.Megaparsec.Char +import Control.Monad.State.Lazy +import Data.List.NonEmpty (NonEmpty(..)) + +import Data.Void (Void) +import Prelude (head) +import Text.Format.Para (formatParas) + +import qualified Data.MultiMap as MM +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.IO as LT +import qualified Prelude + + +-- Parser Monad ---------------------------------------------------------------- + +data Mode = Wide | Tall + deriving (Eq, Ord, Show) + +type Parser = StateT Mode (Parsec Void Text) + +withLocalState :: Monad m => s -> StateT s m a -> StateT s m a +withLocalState val x = do { old <- get; put val; x <* put old } + +inWideMode :: Parser a -> Parser a +inWideMode = withLocalState Wide + + +-- Simple Lexers --------------------------------------------------------------- + +ace, pal, par ∷ Parser () +ace = void (char ' ') +pal = void (char '(') +par = void (char ')') + +gap ∷ Parser () +gap = choice [ char ' ' >> void (some spaceChar) + , newline >> void (many spaceChar) + ] + +whitespace ∷ Parser () +whitespace = ace <|> void gap + + +-- Literals -------------------------------------------------------------------- + +alpha ∷ Parser Char +alpha = oneOf (['a'..'z'] ++ ['A'..'Z']) + +sym ∷ Parser Sym +sym = bucSym <|> some alpha + where bucSym = char '$' *> pure "" + +atom ∷ Parser Nat +atom = do + init ← some digitChar + rest ← many (char '.' *> some digitChar) + guard True -- TODO Validate '.'s + pure (Prelude.read $ concat $ init:rest) + +nat ∷ Parser Nat +nat = Prelude.read <$> some digitChar + +limb ∷ Parser (Either Nat Sym) +limb = (Right <$> sym) <|> (char '+' >> Left <$> nat) + +wing ∷ Parser Wing +wing = + subjt <|> limbs + where + subjt ∷ Parser Wing + subjt = pure [] <* char '.' + limbs ∷ Parser Wing + limbs = do s ← limb + ss ← many (char '.' >> limb) + pure (s:ss) + +tape ∷ Parser Text +tape = do + between (char '"') (char '"') $ + pack <$> many (label "tape char" (anySingleBut '"')) + +cord ∷ Parser Text +cord = do + between (char '\'') (char '\'') $ + pack <$> many (label "cord char" (anySingleBut '\'')) + +literal ∷ Parser Hoon +literal = choice + [ Atom <$> atom + , Wing <$> wing + , pure Yes <* string "%.y" + , pure No <* string "%.n" + , pure Pam <* char '&' + , pure Bar <* char '|' + , pure Sig <* char '~' + , pure Lus <* char '+' + , pure Hep <* char '-' + , Cord <$> cord + , Tape <$> tape + ] + +-- Rune Helpers ---------------------------------------------------------------- + +{- + - If the parser is in `Wide` mode, only accept the `wide` form. + - If the parser is in `Tall` mode, either + - accept the `tall` form or: + - swich to `Wide` mode and then accept the wide form. +-} +parseRune ∷ Parser a → Parser a → Parser a +parseRune tall wide = get >>= \case + Wide → wide + Tall → tall <|> inWideMode wide + +rune1 ∷ (a→b) → Parser a → Parser b +rune1 node x = parseRune tall wide + where tall = do gap; p←x; pure (node p) + wide = do pal; p←x; par; pure (node p) + +rune2 ∷ (a→b→c) → Parser a → Parser b → Parser c +rune2 node x y = parseRune tall wide + where tall = do gap; p←x; gap; q←y; pure (node p q) + wide = do pal; p←x; ace; q←y; par; pure (node p q) + +rune3 ∷ (a→b→c→d) → Parser a → Parser b → Parser c → Parser d +rune3 node x y z = parseRune tall wide + where tall = do gap; p←x; gap; q←y; gap; r←z; pure (node p q r) + wide = do pal; p←x; ace; q←y; ace; r←z; par; pure (node p q r) + +rune4 ∷ (a→b→c→d→e) → Parser a → Parser b → Parser c → Parser d → Parser e +rune4 node x y z g = parseRune tall wide + where tall = do gap; p←x; gap; q←y; gap; r←z; gap; s←g; pure (node p q r s) + wide = do pal; p←x; ace; q←y; ace; r←z; ace; s←g; pure (node p q r s) + +runeN ∷ ([a]→b) → Parser a → Parser b +runeN node elem = node <$> parseRune tall wide + where tall = gap >> elems + where elems = term <|> elemAnd + elemAnd = do x ← elem; gap; xs ← elems; pure (x:xs) + term = string "==" *> pure [] + wide = pal *> option [] elems <* par + where elems = (:) <$> elem <*> many (ace >> elem) + +runeNE ∷ (NonEmpty a → b) → Parser a → Parser b +runeNE node elem = node <$> parseRune tall wide + where tall = do + let elems = term <|> elemAnd + elemAnd = do x ← elem; gap; xs ← elems; pure (x:xs) + term = string "==" *> pure [] + fst <- gap *> elem + rst <- gap *> elems + pure (fst :| rst) + wide = mzero -- No wide form for cores + +-- Irregular Syntax ------------------------------------------------------------ + +inc ∷ Parser Hoon -- +(3) +inc = do + string "+(" + h ← hoon + char ')' + pure h + +equals ∷ Parser (Hoon, Hoon) -- =(3 4) +equals = do + string "=(" + x ← hoon + ace + y ← hoon + char ')' + pure (x, y) + +tuple ∷ ∀a. Parser a → Parser [a] +tuple p = char '[' >> elems + where + xs ∷ Parser [a] + xs = do { x ← p; (x:) <$> tail } + + tail ∷ Parser [a] + tail = (pure [] <* char ']') + <|> (ace >> elems) + + elems ∷ Parser [a] + elems = (pure [] <* char ']') <|> xs + +irregular ∷ Parser Hoon +irregular = + inWideMode $ + choice [ Tupl <$> tuple hoon + , IncrIrr <$> inc + , uncurry IsEqIrr <$> equals + ] + +-- Runes ----------------------------------------------------------------------- + +cRune ∷ (Map Sym Hoon → a) → Parser a +cRune f = do + mode ← get + guard (mode == Tall) + gap + f . mapFromList <$> arms -- TODO Complain about duplicated arms + where + arms :: Parser [(Sym, Hoon)] + arms = many arm <* string "--" + + arm :: Parser (Sym, Hoon) + arm = do + string "++" + gap + s ← sym + gap + h ← hoon + gap + pure (s, h) + +data Skin + +rune ∷ Parser Hoon +rune = runeSwitch [ ("|=", rune2 BarTis hoon hoon) + , ("|-", rune1 BarHep hoon) + , (":-", rune2 ColHep hoon hoon) + , (":+", rune3 ColLus hoon hoon hoon) + , (":^", rune4 ColKet hoon hoon hoon hoon) + , (":*", runeN ColTar hoon) + , (":~", runeN ColSig hoon) + , ("^-", rune2 KetHep spec hoon) + , ("=<", rune2 TisGal hoon hoon) + , ("=>", rune2 TisGar hoon hoon) + , ("?:", rune3 WutCol hoon hoon hoon) + , ("?=", rune2 WutTis spec hoon) + , ("?@", rune3 WutPat hoon hoon hoon) + , ("?^", rune3 WutKet hoon hoon hoon) + , (".+", rune1 Incr hoon) + , (".=", rune2 IsEq hoon hoon) + , ("^=", rune2 KetTis sym hoon) + , ("=.", rune3 TisDot wing hoon hoon) + , ("|%", cRune BarCen) + ] + +runeSwitch ∷ [(Text, Parser a)] → Parser a +runeSwitch = choice . fmap (\(s, p) → string s *> p) + +-- runeSwitch ∷ [(String, Parser a)] → Parser a +-- runeSwitch = parseBasedOnRune +-- . fmap (\([x,y], p) → (x, (y,p))) +-- where +-- parseBasedOnRune ∷ [(Char, (Char, Parser a))] → Parser a +-- parseBasedOnRune = combine . restructure +-- where combine = lexThen . overSnd lexThen +-- overSnd f = fmap (\(x,y) → (x,f y)) +-- lexThen = choice . fmap (\(x,y) → char x *> y) +-- restructure = MM.assocs +-- . MM.fromList + +-- Infix Syntax ---------------------------------------------------------------- + +colInfix ∷ Parser Hoon +colInfix = do + x ← try (hoonNoInfix <* char ':') + y ← hoon + pure (ColOp x y) + +faceOp ∷ Parser Hoon +faceOp = FaceOp <$> try (sym <* char '=') + <*> hoon + +infixOp ∷ Parser Hoon +infixOp = do + inWideMode (colInfix <|> faceOp) + +-- Hoon Parser ----------------------------------------------------------------- + +hoonNoInfix ∷ Parser Hoon +hoonNoInfix = irregular <|> rune <|> literal + +hoon ∷ Parser Hoon +hoon = infixOp <|> hoonNoInfix + +-- Entry Point ----------------------------------------------------------------- + +hoonFile = do + option () whitespace + h ← hoon + option () whitespace + eof + pure h + +parse :: Text -> Either Text Hoon +parse txt = + runParser (evalStateT hoonFile Tall) "stdin" txt & \case + Left e -> Left (pack $ errorBundlePretty e) + Right x -> pure x + +parseHoonTest ∷ Text → IO () +parseHoonTest = parseTest (evalStateT hoonFile Tall) + +main ∷ IO () +main = (head <$> getArgs) >>= parseHoonTest + + +-- Parse Spec ------------------------------------------------------------------ + +base :: Parser Base +base = choice [ BVoid <$ char '!' + , BNull <$ char '~' + , BFlag <$ char '?' + , BNoun <$ char '*' + , BCell <$ char '^' + , BAtom <$ char '@' + ] + +specTuple ∷ Parser Spec +specTuple = tuple spec >>= \case + [] -> mzero + x:xs -> pure (STuple (x :| xs)) + +specFace ∷ Parser Spec +specFace = SFaceOp <$> try (sym <* char '=') <*> spec + +specIrregular ∷ Parser Spec +specIrregular = inWideMode (specTuple <|> specFace) + +spec :: Parser Spec +spec = specIrregular <|> specRune <|> fmap SBase base + +specRune ∷ Parser Spec +specRune = choice + [ string "$:" >> runeNE SBucCol spec + , string "$-" >> rune2 SBucHep spec spec + , string "$=" >> rune2 SBucTis sym spec + , string "$?" >> runeNE SBucWut spec + , string "$@" >> rune2 SBucPat spec spec + , string "$^" >> rune2 SBucKet spec spec + , string "$%" >> runeNE SBucCen spec + ] diff --git a/pkg/hoon/lib/Language/Attila/AST/Types.hs b/pkg/hoon/lib/Language/Attila/AST/Types.hs new file mode 100644 index 000000000..f11279069 --- /dev/null +++ b/pkg/hoon/lib/Language/Attila/AST/Types.hs @@ -0,0 +1,66 @@ +-- TODO Handle comments + +module Language.Attila.AST.Types where + +import ClassyPrelude +import Data.List.NonEmpty (NonEmpty) + +-- AST Types ------------------------------------------------------------------- + +type Nat = Int +type Sym = String +type Wing = [Either Nat Sym] + +data Base = BVoid | BNull | BFlag | BNoun | BCell | BAtom + deriving (Eq, Ord, Show) + +data Spec + = SBase Base -- ^, ? + | SFaceOp Sym Spec -- x=@ + | SBucCol (NonEmpty Spec) -- $: + | SBucHep Spec Spec -- $-, function core + | SBucTis Sym Spec -- $=, name + | SBucWut (NonEmpty Spec) -- $?, full pick + | SBucPat Spec Spec -- $@, atom pick + | SBucKet Spec Spec -- $^, cons pick + | SBucCen (NonEmpty Spec) -- $%, head pick + | STuple (NonEmpty Spec) -- [@ @] + deriving (Eq, Ord, Show) + +data Hoon + = WutCol Hoon Hoon Hoon -- ?:(c t f) + | WutTis Spec Hoon -- ?=(@ 0) + | WutPat Hoon Hoon Hoon -- ?@(c t f) + | WutKet Hoon Hoon Hoon -- ?^(c t f) + | KetTis Sym Hoon -- ^=(x 3) + | ColHep Hoon Hoon -- :-(a b) + | ColLus Hoon Hoon Hoon -- :+(a b c) + | ColKet Hoon Hoon Hoon Hoon -- :^(a b c d) + | ColTar [Hoon] -- :*(a as ...) + | ColSig [Hoon] -- :~(a as ...) + | KetHep Spec Hoon -- ^-(s h) + | TisGal Hoon Hoon -- =<(a b) + | TisGar Hoon Hoon -- =>(a b) + | BarTis Hoon Hoon -- |=(s h) + | BarHep Hoon -- |-(a) + | TisDot Wing Hoon Hoon -- =.(a 3 a) + | BarCen (Map Sym Hoon) -- |% ++ a 3 -- + | ColOp Hoon Hoon -- [+ -]:[3 4] + | Tupl [Hoon] -- [a b] + | FaceOp Sym Hoon -- x=y + | Wing Wing -- ., a, a.b + | Atom Nat -- 3 + | Cord Text -- 'cord' + | Tape Text -- "tape" + | Incr Hoon -- .+(3) + | IncrIrr Hoon -- +(3) + | IsEq Hoon Hoon -- .=(3 4) + | IsEqIrr Hoon Hoon -- =(3 4) + | Lus -- + + | Hep -- - + | Pam -- & + | Bar -- | + | Yes -- %.y + | No -- %.n + | Sig -- ~ + deriving (Eq, Ord, Show) From 3fa12dcec4976b1e77748fbb3c1624d9d79ce3f7 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 21 May 2019 00:25:58 -0700 Subject: [PATCH 035/431] Wrote most of the code for a high-perf cue. --- pkg/hair/lib/Data/Noun/Atom.hs | 4 +- pkg/hair/lib/Data/Noun/Jam/Fast.hs | 299 ++++++++++++++++++++++++++++- pkg/hair/lib/Data/Noun/Pill.hs | 19 +- pkg/hair/package.yaml | 1 + stack.yaml | 5 + 5 files changed, 321 insertions(+), 7 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index c3a83ce1b..d73067d9b 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -29,14 +29,14 @@ instance Show Atom where -} data Cursor = Cursor { _cOffset :: {-# UNPACK #-} !Int - , _cBuffer :: {-# UNPACK #-} !Atom + , _cBuffer :: !Atom } deriving (Eq, Ord, Show) data Slice = Slice { _sOffset :: {-# UNPACK #-} !Int , _sWidth :: {-# UNPACK #-} !Int - , _sBuffer :: {-# UNPACK #-} !Atom + , _sBuffer :: !Atom } deriving (Eq, Ord, Show) diff --git a/pkg/hair/lib/Data/Noun/Jam/Fast.hs b/pkg/hair/lib/Data/Noun/Jam/Fast.hs index 8413de790..97f6763d6 100644 --- a/pkg/hair/lib/Data/Noun/Jam/Fast.hs +++ b/pkg/hair/lib/Data/Noun/Jam/Fast.hs @@ -6,22 +6,26 @@ import ClassyPrelude import Data.Noun import Data.Noun.Atom import Data.Noun.Poet -import Data.Bits +import Data.Bits hiding (Bits) import Control.Lens import Text.Printf import GHC.Prim import GHC.Word import GHC.Natural +import Foreign.Ptr +import Foreign.Storable (peek) import Data.Map (Map) import Control.Monad (guard) import Test.Tasty import Test.Tasty.TH -import Test.Tasty.QuickCheck as QC -import Test.QuickCheck +import qualified Test.Tasty.QuickCheck as QC +import Test.QuickCheck hiding ((.&.)) --- High-Performance Jam -------------------------------------------------------- +import qualified Data.HashTable.IO as H + +-- Pre-Calculate the bit-width of `jam` ---------------------------------------- matSz# :: Atom -> Word# matSz# 0 = 1## @@ -66,3 +70,290 @@ jamSz = fst . go 0 mempty else (1 + worSz, tbl) Cell _ _ -> (refSz, oldTbl) + +-- How to write a faster `cue`? ------------------------------------------------ + +{-| + The decoder state. + + - An array of words (internal structure of our atoms). + - A pointer to the word *after* the last word in the array. + - A pointer into the current word of that array. + - A bit-offset into that word. +-} +data S = S + { currPtr :: {-# UNPACK #-} !(Ptr Word) + , usedBits :: {-# UNPACK #-} !Word + , pos :: {-# UNPACK #-} !Word + } deriving (Show,Eq,Ord) + +-------------------------------------------------------------------------------- + +type Env = (Ptr Word, S) + +data DecodeException = NotEnoughSpace Env + | TooMuchSpace Env + | BadEncoding Env String + deriving (Show, Eq, Ord) + +instance Exception DecodeException + +badEncoding :: Ptr Word -> S -> String -> IO a +badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg + +-- The Get Monad --------------------------------------------------------------- + +data GetResult a = GetResult {-# UNPACK #-} !S !a + deriving Functor + +newtype Get a = Get + { runGet :: Ptr Word + -> H.LinearHashTable Word Noun + -> S + -> IO (GetResult a) + } + +instance Functor Get where + fmap f g = Get $ \end tbl s -> do + GetResult s' a <- runGet g end tbl s + return $ GetResult s' (f a) + {-# INLINE fmap #-} + +instance Applicative Get where + pure x = Get (\_ _ s -> return $ GetResult s x) + {-# INLINE pure #-} + + Get f <*> Get g = Get $ \end tbl s1 -> do + GetResult s2 f' <- f end tbl s1 + GetResult s3 g' <- g end tbl s2 + return $ GetResult s3 (f' g') + {-# INLINE (<*>) #-} + + Get f *> Get g = Get $ \end tbl s1 -> do + GetResult s2 _ <- f end tbl s1 + g end tbl s2 + {-# INLINE (*>) #-} + +instance Monad Get where + return = pure + {-# INLINE return #-} + + (>>) = (*>) + {-# INLINE (>>) #-} + + Get x >>= f = Get $ \end tbl s -> do + GetResult s' x' <- x end tbl s + runGet (f x') end tbl s' + {-# INLINE (>>=) #-} + + fail msg = Get $ \end tbl s -> + badEncoding end s msg + {-# INLINE fail #-} + +-------------------------------------------------------------------------------- + +type Bits = Vector Bool + +getPos :: Get Word +getPos = Get $ \_ _ s -> + pure (GetResult s (pos s)) + +insRef :: Word -> Noun -> Get () +insRef pos now = Get \_ tbl s -> do + H.insert tbl pos now + pure $ GetResult s () + +getRef :: Word -> Get Noun +getRef ref = Get \_ tbl s -> do + H.lookup tbl ref >>= \case + Nothing -> fail "Invalid Reference" + Just no -> pure (GetResult s no) + +advance :: Word -> Get () +advance n = Get \_ _ s -> do + let newUsed = n + usedBits s + newS = s { pos = pos s + n + , usedBits = newUsed `mod` 64 + , currPtr = plusPtr (currPtr s) + (fromIntegral $ newUsed `div` 64) + } + + pure (GetResult newS ()) + +-------------------------------------------------------------------------------- + +-- TODO Should this be (>= end) or (> end)? +peekCurWord :: Get Word +peekCurWord = Get \end _ s -> + if ptrToWordPtr (currPtr s) >= ptrToWordPtr end + then pure (GetResult s 0) + else GetResult s <$> peek (currPtr s) + +-- TODO Same question as above. +peekNextWord :: Get Word +peekNextWord = Get \end _ s -> + if ptrToWordPtr (currPtr s) > ptrToWordPtr end + then pure (GetResult s 0) + else GetResult s <$> peek (currPtr s `plusPtr` 1) + +peekUsedBits :: Get Word +peekUsedBits = Get \_ _ s -> pure (GetResult s (usedBits s)) + +{-| + Get a bit. + + - Peek the current word. + - Right-shift by the bit-offset. + - Mask the high bits. +-} +dBit :: Get Bool +dBit = do + wor <- peekCurWord + use <- fromIntegral <$> peekUsedBits + advance 1 + pure (0 /= shiftR wor use .&. 1) + +{-| + Get n bits, where n > 64: + + - Get (n/64) words. + - Advance by n bits. + - Calculate an offset (equal to the current bit-offset) + - Calculate the length (equal to n) + - Construct a bit-vector using the buffer*length*offset. +-} +dBits :: Word -> Get Bits +dBits = undefined + +{-| + In order to peek at the next Word64: + + - If we are past the end of the buffer: + - Return zero. + - If the bit-offset is zero: + - Just peek. + - If we are pointing to the last word: + - Peek and right-shift by the bit offset. + - Otherwise, + - Peek the current word *and* the next word. + - Right-shift the current word by the bit-offset. + - Left-shift the next word by the bit-offset. + - Binary or the resulting two words. +-} +peekWord :: Get Word +peekWord = do + off <- peekUsedBits + cur <- peekCurWord + if off == 0 then pure cur else do + nex <- peekNextWord + advance 64 + pure (dropLowBits off cur .|. dropHighBits off nex) + +dropLowBits :: Word -> Word -> Word +dropLowBits bits wor = shiftR wor (fromIntegral bits :: Int) + +takeLowBits :: Word -> Word -> Word +takeLowBits 64 wor = wor +takeLowBits wid wor = (2^wid - 1) .&. wor + +takeHighBits :: Word -> Word -> Word +takeHighBits off wor = dropLowBits (64-off) wor + +dropHighBits :: Word -> Word -> Word +dropHighBits off wor = takeLowBits (64-off) wor + +{-| + Make a word from the next n bits (where n <= 64). + + - Peek at the next word. + - Mask the n lowest bits from the word. + - Advance by that number of bits. + - Return the word. +-} +dWordBits :: Word -> Get Word +dWordBits n = do + w <- peekWord + advance n + pure (takeLowBits n w) + +-------------------------------------------------------------------------------- + +bitsToAtom :: Bits -> Atom +bitsToAtom = undefined + +-------------------------------------------------------------------------------- + +{- + Get the exponent-prefix of an atom: + + - Peek at the next word. + - Calculate the number of least-significant bits in that word (there's + a primitive for this). + - Advance by that number of bits. + - Return the number of bits +-} +dExp :: Get Word +dExp = do + W# w <- peekWord + let res = W# (ctz# w) + advance res + pure res + +dAtomLen :: Get Word +dAtomLen = do + e <- dExp + p <- dWordBits (e-1) + pure (2^e .|. p) + +dRef :: Get Word +dRef = dAtomLen >>= dWordBits + +dAtom :: Get Atom +dAtom = do + n <- dAtomLen + b <- dBits n + pure (bitsToAtom b) + +dCell :: Get Noun +dCell = Cell <$> dNoun <*> dNoun + +{-| + Get a Noun. + + - Get a bit + - If it's zero, get an atom. + - Otherwise, get another bit. + - If it's zero, get a cell. + - If it's one, get an atom. +-} +dNoun :: Get Noun +dNoun = do + p <- getPos + + let yield r = insRef p r >> pure r + + dBit >>= \case + False -> (Atom <$> dAtom) >>= yield + True -> dBit >>= \case + False -> dCell >>= yield + True -> dRef >>= getRef + +{- + Count leading zero bits. + + Read a 64 bit word from the buffer and get the number of leading + zeros in that word. This works as long as no atom is larger than + 2 zettabytes. + + - TODO Need to handle the edge-case where there are less than 64 bits + remaining in the buffer. Those extra bytes need to be zeros. One way + to handle this might be to add a zero word to the end of the buffer, + but that would require a re-alloc. Probably the right way is to + write new `peek` primitives that handle this case. + + - TODO Error out if we hit the end *and* the word is all zeros. + + Alright, let's pseudo-code this out: + + Grab the next 64 bits. Pill files are always LSB-first +-} diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs index 003a75623..4d7c593f1 100644 --- a/pkg/hair/lib/Data/Noun/Pill.hs +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -1,6 +1,23 @@ {-# LANGUAGE MagicHash #-} --- TODO Handle 32-bit architectures +{- + TODO Handle 32-bit architectures + TODO A faster version of this is possible: + + - Get the byte-length of a file. + - Round up to a multiple of 8 (or 4 if 32bit cpu) + - Allocate a mutable vector of Word8 with that size. + - Read the file into the array. + - Manually cast to an array of Word. + - On big endian, update each words with `System.Endian.fromLE64`. + - If there are trailing 0 words, adjust the vector size to delete them. + - unsafeFreeze the vector. + - Run `byteArrayToBigNat#` on the underlying byte array. + - Convert the BigNat to a Natural, to an Atom. + - The whole thing becomes zero-copy for little endian machines, with + one zero-copy transformation of the whole structure on big-endian + machines. +-} module Data.Noun.Pill where diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 2bbbb4df5..ecebf9b2a 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -67,6 +67,7 @@ dependencies: - transformers - unordered-containers - vector + - hashtables default-extensions: - ApplicativeDo diff --git a/stack.yaml b/stack.yaml index e15320c3f..fe9c2bbee 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,3 +10,8 @@ ghc-options: extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 - flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38 + +build: + library-profiling: true + executable-profiling: true + executable-stripping: false From a129f7e6f1809afd80382a0ca7392b833e1b2f33 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 22 May 2019 18:14:21 -0700 Subject: [PATCH 036/431] Type Inference for Attila's IR --- pkg/hoon/lib/Language/Attila/IR.hs | 198 +++++++++++++++++++++++++++++ pkg/hoon/package.yaml | 1 + 2 files changed, 199 insertions(+) create mode 100644 pkg/hoon/lib/Language/Attila/IR.hs diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hoon/lib/Language/Attila/IR.hs new file mode 100644 index 000000000..671f4e5b6 --- /dev/null +++ b/pkg/hoon/lib/Language/Attila/IR.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE OverloadedLists #-} + +module Language.Attila.IR where + +import ClassyPrelude hiding (either, fail, try) +import GHC.Natural +import Control.Lens +import Data.Vector (Vector, (!?)) +import Control.Monad.Fail +import Control.Arrow ((>>>)) +import Data.ChunkedZip (Zip) + +-------------------------------------------------------------------------------- + +type Nat = Natural +type Vec = Vector + +data Ty + = Nat + | Sum (Vec Ty) + | Mul (Vec Ty) + | Nok Ty Ty + | Fix Ty + | All Ty + | Ref Nat + deriving (Eq, Ord, Show) + +{- + An IR Expression + + Formulas and subject manipulation: + + - Sub -- Reference the current subject. + - Lam -- A formula (with the type for its subject) + - Wit -- Run an expression against a new subject. + - Fir -- Run a formula against a subject. + + Atoms: + + - Lit -- An atom literal. + - Inc -- Increment an atom. + - Eke -- Atom equality. + + Product Types: + + - Tup -- Construct a product type. + - Get -- Get a field out of a product. + - Mod -- Update a field of a product. + + Sum Types: + + - Cho -- Construct a (branch of a) sum type. + - Eat -- Pattern match (switch) on a sum type. +-} +data Exp + = Sub + | Lam Ty Exp + | Wit Exp Exp + | Fir Exp Exp + | Lit Nat + | Inc Exp + | Eke Exp Exp + | Tup (Vec Exp) + | Get Exp Nat + | Cho (Vec Ty) Nat Exp + | Eat Exp (Vec Exp) + +newtype Infer a = Infer { runInfer :: Either Text a } + deriving newtype (Eq, Ord, Show, Functor, Applicative, Monad) + +instance MonadFail Infer where + fail = Infer . Left . pack + +infGuard :: String -> Bool -> Infer () +infGuard _ True = pure () +infGuard msg False = fail msg + +infer :: Ty -> Exp -> Infer Ty +infer sub Sub = pure sub +infer sub (Lam lub b) = Nok lub <$> infer lub b +infer sub (Wit new bod) = do newSub <- infer sub new + infer newSub bod +infer sub (Fir new bod) = do newSub <- infer sub new + infer newSub bod +infer _ (Lit _) = pure Nat +infer sub (Inc exp) = do eTy <- infer sub exp + infGuard "bad-inc" (eTy == Nat) + pure Nat +infer sub (Eke ex1 ex2) = do ty1 <- infer sub ex1 + ty2 <- infer sub ex2 + infGuard "bad-eq" (ty1 == Nat && ty2 == Nat) + pure Nat +infer sub (Tup exps) = Mul <$> traverse (infer sub) exps +infer sub (Get tup n) = infer sub tup >>= inferGet n +infer sub (Cho tys n exp) = infer sub exp >>= inferCho tys n +infer sub (Eat exp bods) = inferEat sub exp bods + +inferGet :: Nat -> Ty -> Infer Ty +inferGet n = \case Mul tys -> idx tys + _ -> fail "not-mul" + where + idx tys = (tys !? fromIntegral n) & \case + Nothing -> fail "mul-bad-index" + Just ty -> pure ty + +inferCho :: Vec Ty -> Nat -> Ty -> Infer Ty +inferCho tys n ty = do + (tys !? fromIntegral n) & \case + Nothing -> fail "cho-bad-index" + Just tu -> do infGuard "cho-bad-match" (tu == ty) + pure (Sum tys) + +unify :: Vec Ty -> Infer Ty +unify = toList >>> \case [] -> pure voidTy + x:xs -> do infGuard "bad-unify" (all (== x) xs) + pure x + +zipWithM :: (Monad m, Traversable seq, Zip seq) + => (a -> b -> m c) -> seq a -> seq b -> m (seq c) +zipWithM f xs ys = sequence (zipWith f xs ys) + +inferEat :: Ty -> Exp -> Vec Exp -> Infer Ty +inferEat sub exp bods = + infer sub exp >>= \case Sum tys -> checkSum tys + _ -> fail "eat-not-sum" + where + checkSum :: Vec Ty -> Infer Ty + checkSum tys = do + infGuard "eat-bad-len" (length tys == length bods) + unify =<< zipWithM checkBranch tys bods + + checkBranch :: Ty -> Exp -> Infer Ty + checkBranch brTy exp = infer (pair brTy sub) exp + +-------------------------------------------------------------------------------- + +unit :: Ty +unit = Mul [] + +voidTy :: Ty +voidTy = Sum [] + +pair :: Ty -> Ty -> Ty +pair x y = Mul [x,y] + +either :: Ty -> Ty -> Ty +either x y = Sum [x, y] + +-------------------------------------------------------------------------------- + +tAtom :: Ty +tAtom = Nat + +tNoun :: Ty +tNoun = Fix $ either Nat (pair (Ref 0) (Ref 0)) + +tOpt :: Ty +tOpt = All $ either unit (Ref 0) + +tEith :: Ty +tEith = All $ All $ either (Ref 1) (Ref 0) + +-------------------------------------------------------------------------------- + +{- +data Exp + = Sub + | Lam Ty Exp + | Wit Exp Exp + | Fir Exp Exp + | Lit Nat + | Inc Exp + | Eke Exp Exp + | Tup (Vec Exp) + | Get Exp Nat + | Cho (Vec Ty) Nat Exp + | Eat Exp (Vec Exp) +-} + +try :: Exp -> Either Text Ty +try = runInfer . infer voidTy + +tryTup :: Either Text Ty +tryTup = try $ Get (Get (Tup [Lit 3, Tup [Lit 4, Lit 5]]) 1) 0 + +tryWid :: Either Text Ty +tryWid = try $ Wit (Lit 3) Sub + +cho :: Exp +cho = Cho [Nat, Nat] 0 (Lit 0) + +tryCho :: Either Text Ty +tryCho = try cho + +tryEat :: Either Text Ty +tryEat = try $ Eat cho [Get Sub 0, Inc (Lit 0)] + +-- Credits: Morgan, Ted, Benjamin diff --git a/pkg/hoon/package.yaml b/pkg/hoon/package.yaml index 9cc4e550d..9c8bc3dcb 100644 --- a/pkg/hoon/package.yaml +++ b/pkg/hoon/package.yaml @@ -12,6 +12,7 @@ dependencies: - async - base - case-insensitive + - chunked-data - classy-prelude - containers - data-fix From ae3031f3fcc87671933c6a70f6db5bd535678269 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 23 May 2019 00:12:44 -0700 Subject: [PATCH 037/431] Nock code generation for Attila. --- pkg/hoon/lib/Language/Attila/IR.hs | 204 +++++++++++++++++++++++------ 1 file changed, 164 insertions(+), 40 deletions(-) diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hoon/lib/Language/Attila/IR.hs index 671f4e5b6..d141850ba 100644 --- a/pkg/hoon/lib/Language/Attila/IR.hs +++ b/pkg/hoon/lib/Language/Attila/IR.hs @@ -5,10 +5,11 @@ module Language.Attila.IR where import ClassyPrelude hiding (either, fail, try) import GHC.Natural import Control.Lens -import Data.Vector (Vector, (!?)) +import Data.Vector (Vector, (!), (!?)) import Control.Monad.Fail import Control.Arrow ((>>>)) import Data.ChunkedZip (Zip) +import Language.Hoon.Nock.Types -------------------------------------------------------------------------------- @@ -61,9 +62,18 @@ data Exp | Inc Exp | Eke Exp Exp | Tup (Vec Exp) - | Get Exp Nat + | Get Nat Exp | Cho (Vec Ty) Nat Exp | Eat Exp (Vec Exp) + deriving (Eq, Ord, Show) + +-------------------------------------------------------------------------------- + +zipWithM :: (Monad m, Traversable seq, Zip seq) + => (a -> b -> m c) -> seq a -> seq b -> m (seq c) +zipWithM f xs ys = sequence (zipWith f xs ys) + +-------------------------------------------------------------------------------- newtype Infer a = Infer { runInfer :: Either Text a } deriving newtype (Eq, Ord, Show, Functor, Applicative, Monad) @@ -75,6 +85,14 @@ infGuard :: String -> Bool -> Infer () infGuard _ True = pure () infGuard msg False = fail msg +unify :: Vec Ty -> Infer Ty +unify = toList >>> \case [] -> pure voidTy + x:xs -> do let err = "bad-unify " <> show (x:xs) + infGuard err (all (== x) xs) + pure x + +-------------------------------------------------------------------------------- + infer :: Ty -> Exp -> Infer Ty infer sub Sub = pure sub infer sub (Lam lub b) = Nok lub <$> infer lub b @@ -84,14 +102,12 @@ infer sub (Fir new bod) = do newSub <- infer sub new infer newSub bod infer _ (Lit _) = pure Nat infer sub (Inc exp) = do eTy <- infer sub exp - infGuard "bad-inc" (eTy == Nat) - pure Nat + unify [eTy, Nat] infer sub (Eke ex1 ex2) = do ty1 <- infer sub ex1 ty2 <- infer sub ex2 - infGuard "bad-eq" (ty1 == Nat && ty2 == Nat) - pure Nat + unify [Nat, ty1, ty2] infer sub (Tup exps) = Mul <$> traverse (infer sub) exps -infer sub (Get tup n) = infer sub tup >>= inferGet n +infer sub (Get n tup) = infer sub tup >>= inferGet n infer sub (Cho tys n exp) = infer sub exp >>= inferCho tys n infer sub (Eat exp bods) = inferEat sub exp bods @@ -107,18 +123,9 @@ inferCho :: Vec Ty -> Nat -> Ty -> Infer Ty inferCho tys n ty = do (tys !? fromIntegral n) & \case Nothing -> fail "cho-bad-index" - Just tu -> do infGuard "cho-bad-match" (tu == ty) + Just tu -> do unify [tu, ty] pure (Sum tys) -unify :: Vec Ty -> Infer Ty -unify = toList >>> \case [] -> pure voidTy - x:xs -> do infGuard "bad-unify" (all (== x) xs) - pure x - -zipWithM :: (Monad m, Traversable seq, Zip seq) - => (a -> b -> m c) -> seq a -> seq b -> m (seq c) -zipWithM f xs ys = sequence (zipWith f xs ys) - inferEat :: Ty -> Exp -> Vec Exp -> Infer Ty inferEat sub exp bods = infer sub exp >>= \case Sum tys -> checkSum tys @@ -130,7 +137,7 @@ inferEat sub exp bods = unify =<< zipWithM checkBranch tys bods checkBranch :: Ty -> Exp -> Infer Ty - checkBranch brTy exp = infer (pair brTy sub) exp + checkBranch brTy exp = infer (pair (pair Nat brTy) sub) exp -------------------------------------------------------------------------------- @@ -160,39 +167,156 @@ tOpt = All $ either unit (Ref 0) tEith :: Ty tEith = All $ All $ either (Ref 1) (Ref 0) --------------------------------------------------------------------------------- +tBool :: Ty +tBool = either unit unit -{- -data Exp - = Sub - | Lam Ty Exp - | Wit Exp Exp - | Fir Exp Exp - | Lit Nat - | Inc Exp - | Eke Exp Exp - | Tup (Vec Exp) - | Get Exp Nat - | Cho (Vec Ty) Nat Exp - | Eat Exp (Vec Exp) --} +tOrd :: Ty +tOrd = Sum [unit, unit, unit] + + +-- Expression Examples --------------------------------------------------------- + +tup2 :: Exp -> Exp -> Exp +tup2 x y = Tup [x, y] + +choEx :: Exp +choEx = Cho [Nat, Nat] 0 (Lit 0) + +tupEx :: Exp +tupEx = Get 0 $ Get 1 $ tup2 (Lit 3) $ tup2 (Lit 4) (Lit 5) + +widEx :: Exp +widEx = Wit (Lit 3) Sub + +eatEx :: Exp +eatEx = Eat choEx [Get 1 (Get 0 Sub), Inc (Lit 0)] + + +-------------------------------------------------------------------------------- try :: Exp -> Either Text Ty try = runInfer . infer voidTy +build :: Exp -> Either Text (Ty, Nock) +build = compile voidTy + tryTup :: Either Text Ty -tryTup = try $ Get (Get (Tup [Lit 3, Tup [Lit 4, Lit 5]]) 1) 0 +tryTup = try tupEx tryWid :: Either Text Ty -tryWid = try $ Wit (Lit 3) Sub - -cho :: Exp -cho = Cho [Nat, Nat] 0 (Lit 0) +tryWid = try widEx tryCho :: Either Text Ty -tryCho = try cho +tryCho = try choEx tryEat :: Either Text Ty -tryEat = try $ Eat cho [Get Sub 0, Inc (Lit 0)] +tryEat = try eatEx + +buildTup :: Either Text (Ty, Nock) +buildTup = build tupEx + +buildWid :: Either Text (Ty, Nock) +buildWid = build widEx + +buildCho :: Either Text (Ty, Nock) +buildCho = build choEx + +buildEat :: Either Text (Ty, Nock) +buildEat = build eatEx + +-------------------------------------------------------------------------------- + +-- TODO Record layout. +compile :: Ty -> Exp -> Either Text (Ty, Nock) +compile sut = \case + Sub -> + pure (sut, NZeroAxis 1) + Lit n -> + pure (Nat, NOneConst (Atom $ fromIntegral n)) + Inc x -> do + (_, nock) <- compile sut x + pure (Nat, NFourSucc nock) + Cho tys n exp -> do + (_, nock) <- compile sut exp + let tag = NOneConst (Atom (fromIntegral n)) + pure (Sum tys, NCons tag nock) + Get n exp -> do + (vecTy, vecNock) <- compile sut exp + + tys <- case vecTy of + Mul tys -> pure tys + ty -> Left ("get-not-mul: " <> tshow ty) + + let axis = getAxis n (fromIntegral $ length tys) + let resTy = tys ! fromIntegral n + pure (resTy, NSevenThen vecNock (NZeroAxis $ fromIntegral axis)) + + Tup xs -> do + ty <- runInfer (infer sut (Tup xs)) + nock <- genCons sut (toList xs) + pure (ty, nock) + + Eat exp brs -> do + (headTy, nock) <- compile sut exp + + newSubjTys <- headTy & \case + Sum tys -> pure $ fmap (\x -> pair (pair Nat x) sut) tys + _ -> Left "you are dumb" + + nocks <- fmap snd <$> zipWithM compile newSubjTys brs + + resTy <- runInfer (infer sut (Eat exp brs)) + + pure (resTy, NEightPush nock (cases (toList nocks))) + + Eke x y -> do + (_, nock1) <- compile sut x + (_, nock2) <- compile sut y + pure (tBool, NFiveEq nock1 nock2) + + Wit ex1 ex2 -> do + (sut', nock1) <- compile sut ex1 + (resTy, nock2) <- compile sut' ex2 + pure (resTy, NSevenThen nock1 nock2) + + Lam ty exp -> do + resTy <- runInfer (infer ty exp) + nock <- (NOneConst . nockToNoun . snd) <$> compile ty exp + pure (Nok sut resTy, nock) + + Fir sub for -> do + (subTy, subNock) <- compile sut sub + (forTy, forNock) <- compile sut for + resTy <- case forTy of + Nok _ resTy -> pure resTy + _ -> Left "bad-fir-e" + pure (resTy, NTwoCompose subNock forNock) + -- TODO Nock nine + +zapZap :: Nock +zapZap = NZeroAxis 0 + +genCons :: Ty -> [Exp] -> Either Text Nock +genCons sut [] = snd <$> compile sut (Lit 0) +genCons sut [x] = snd <$> compile sut x +genCons sut (x:xs) = do + (_, n) <- compile sut x + (_, ns) <- compile sut (Tup (fromList xs)) + pure (NCons n ns) + +cases :: [Nock] -> Nock +cases = go 0 + where + go tag [] = zapZap + go tag (nock:nocks) = NSixIf (NFiveEq (NOneConst (Atom (fromIntegral tag))) + (NZeroAxis 4)) + nock + (go (tag+1) nocks) + +getAxis :: Nat -> Nat -> Nat +getAxis 0 1 = 1 +getAxis 0 len = 2 +getAxis i len | i+1 == len = 1 + getAxis (i-1) len +getAxis i len = 2 * (1 + getAxis (i-1) len) -- Credits: Morgan, Ted, Benjamin From e6fd5006923824d8fd8d784c49fd2f6e8fe0d1cb Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 23 May 2019 14:54:48 -0700 Subject: [PATCH 038/431] Attila.IR cleanup. --- pkg/hoon/lib/Language/Attila/IR.hs | 213 ++++++++++++----------------- 1 file changed, 85 insertions(+), 128 deletions(-) diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hoon/lib/Language/Attila/IR.hs index d141850ba..1a6091ac8 100644 --- a/pkg/hoon/lib/Language/Attila/IR.hs +++ b/pkg/hoon/lib/Language/Attila/IR.hs @@ -2,7 +2,7 @@ module Language.Attila.IR where -import ClassyPrelude hiding (either, fail, try) +import ClassyPrelude hiding (fail, try) import GHC.Natural import Control.Lens import Data.Vector (Vector, (!), (!?)) @@ -10,6 +10,7 @@ import Control.Monad.Fail import Control.Arrow ((>>>)) import Data.ChunkedZip (Zip) import Language.Hoon.Nock.Types +import Text.Show.Pretty (pPrint) -------------------------------------------------------------------------------- @@ -81,14 +82,14 @@ newtype Infer a = Infer { runInfer :: Either Text a } instance MonadFail Infer where fail = Infer . Left . pack -infGuard :: String -> Bool -> Infer () -infGuard _ True = pure () -infGuard msg False = fail msg +guardInfer :: String -> Bool -> Infer () +guardInfer _ True = pure () +guardInfer msg False = fail msg unify :: Vec Ty -> Infer Ty -unify = toList >>> \case [] -> pure voidTy +unify = toList >>> \case [] -> pure tVoid x:xs -> do let err = "bad-unify " <> show (x:xs) - infGuard err (all (== x) xs) + guardInfer err (all (== x) xs) pure x -------------------------------------------------------------------------------- @@ -112,66 +113,43 @@ infer sub (Cho tys n exp) = infer sub exp >>= inferCho tys n infer sub (Eat exp bods) = inferEat sub exp bods inferGet :: Nat -> Ty -> Infer Ty -inferGet n = \case Mul tys -> idx tys - _ -> fail "not-mul" - where - idx tys = (tys !? fromIntegral n) & \case - Nothing -> fail "mul-bad-index" - Just ty -> pure ty +inferGet n ty = do + Mul tys <- pure ty + maybe (fail "mul-bad-index") pure (tys !? fromIntegral n) inferCho :: Vec Ty -> Nat -> Ty -> Infer Ty inferCho tys n ty = do - (tys !? fromIntegral n) & \case - Nothing -> fail "cho-bad-index" - Just tu -> do unify [tu, ty] - pure (Sum tys) + tu <- maybe (fail "cho-bad-index") pure (tys !? fromIntegral n) + unify [tu, ty] + pure (Sum tys) inferEat :: Ty -> Exp -> Vec Exp -> Infer Ty -inferEat sub exp bods = - infer sub exp >>= \case Sum tys -> checkSum tys - _ -> fail "eat-not-sum" +inferEat sub exp bods = do + Sum tys <- infer sub exp + guardInfer "eat-bad-len" (length tys == length bods) + unify =<< zipWithM checkBranch tys bods where - checkSum :: Vec Ty -> Infer Ty - checkSum tys = do - infGuard "eat-bad-len" (length tys == length bods) - unify =<< zipWithM checkBranch tys bods - checkBranch :: Ty -> Exp -> Infer Ty - checkBranch brTy exp = infer (pair (pair Nat brTy) sub) exp + checkBranch brTy exp = infer (tSum (tSum Nat brTy) sub) exp -------------------------------------------------------------------------------- -unit :: Ty -unit = Mul [] +tPair :: Ty -> Ty -> Ty +tPair x y = Mul [x,y] -voidTy :: Ty -voidTy = Sum [] +tSum :: Ty -> Ty -> Ty +tSum x y = Sum [x, y] -pair :: Ty -> Ty -> Ty -pair x y = Mul [x,y] - -either :: Ty -> Ty -> Ty -either x y = Sum [x, y] - --------------------------------------------------------------------------------- - -tAtom :: Ty +tUnit, tVoid, tAtom, tNoun, tOpt, tEith, tBool, tOrd, tTop :: Ty +tUnit = Mul [] +tVoid = Sum [] tAtom = Nat - -tNoun :: Ty -tNoun = Fix $ either Nat (pair (Ref 0) (Ref 0)) - -tOpt :: Ty -tOpt = All $ either unit (Ref 0) - -tEith :: Ty -tEith = All $ All $ either (Ref 1) (Ref 0) - -tBool :: Ty -tBool = either unit unit - -tOrd :: Ty -tOrd = Sum [unit, unit, unit] +tNoun = Fix $ tSum Nat (tSum (Ref 0) (Ref 0)) +tOpt = All $ tSum tUnit (Ref 0) +tEith = All $ All $ tSum (Ref 1) (Ref 0) +tBool = tSum tUnit tUnit +tOrd = Sum [tUnit, tUnit, tUnit] +tTop = All $ Ref 0 -- Expression Examples --------------------------------------------------------- @@ -179,130 +157,109 @@ tOrd = Sum [unit, unit, unit] tup2 :: Exp -> Exp -> Exp tup2 x y = Tup [x, y] -choEx :: Exp +choEx, tupEx, widEx, eatEx :: Exp choEx = Cho [Nat, Nat] 0 (Lit 0) - -tupEx :: Exp tupEx = Get 0 $ Get 1 $ tup2 (Lit 3) $ tup2 (Lit 4) (Lit 5) - -widEx :: Exp widEx = Wit (Lit 3) Sub - -eatEx :: Exp eatEx = Eat choEx [Get 1 (Get 0 Sub), Inc (Lit 0)] -------------------------------------------------------------------------------- -try :: Exp -> Either Text Ty -try = runInfer . infer voidTy +try :: Exp -> IO () +try e = do + putStrLn "" + pPrint e + putStrLn "\n" + putStrLn "" + pPrint (runInfer (infer tTop e)) + putStrLn "\n" + putStrLn "" + pPrint (compile tTop e) + putStrLn "\n" -build :: Exp -> Either Text (Ty, Nock) -build = compile voidTy - -tryTup :: Either Text Ty +tryTup :: IO () tryTup = try tupEx -tryWid :: Either Text Ty +tryWid :: IO () tryWid = try widEx -tryCho :: Either Text Ty +tryCho :: IO () tryCho = try choEx -tryEat :: Either Text Ty +tryEat :: IO () tryEat = try eatEx -buildTup :: Either Text (Ty, Nock) -buildTup = build tupEx - -buildWid :: Either Text (Ty, Nock) -buildWid = build widEx - -buildCho :: Either Text (Ty, Nock) -buildCho = build choEx - -buildEat :: Either Text (Ty, Nock) -buildEat = build eatEx +tryAll :: IO () +tryAll = tryTup >> tryWid >> tryCho >> tryEat -------------------------------------------------------------------------------- -- TODO Record layout. -compile :: Ty -> Exp -> Either Text (Ty, Nock) +compile :: Ty -> Exp -> Either Text Nock compile sut = \case Sub -> - pure (sut, NZeroAxis 1) + pure (NZeroAxis 1) Lit n -> - pure (Nat, NOneConst (Atom $ fromIntegral n)) + pure (NOneConst (Atom $ fromIntegral n)) Inc x -> do - (_, nock) <- compile sut x - pure (Nat, NFourSucc nock) + nock <- compile sut x + pure (NFourSucc nock) Cho tys n exp -> do - (_, nock) <- compile sut exp - let tag = NOneConst (Atom (fromIntegral n)) - pure (Sum tys, NCons tag nock) + nock <- compile sut exp + pure (NCons (NOneConst (Atom (fromIntegral n))) nock) Get n exp -> do - (vecTy, vecNock) <- compile sut exp - - tys <- case vecTy of - Mul tys -> pure tys - ty -> Left ("get-not-mul: " <> tshow ty) - - let axis = getAxis n (fromIntegral $ length tys) - let resTy = tys ! fromIntegral n - pure (resTy, NSevenThen vecNock (NZeroAxis $ fromIntegral axis)) + vecTy <- runInfer (infer sut exp) + vecNock <- compile sut exp + axis <- case vecTy of + Mul tys -> pure (getAxis n (fromIntegral $ length tys)) + ty -> Left ("get-not-mul: " <> tshow ty) + pure (NSevenThen vecNock (NZeroAxis $ fromIntegral axis)) Tup xs -> do - ty <- runInfer (infer sut (Tup xs)) nock <- genCons sut (toList xs) - pure (ty, nock) + pure nock Eat exp brs -> do - (headTy, nock) <- compile sut exp - + headTy <- runInfer (infer sut exp) + nock <- compile sut exp newSubjTys <- headTy & \case - Sum tys -> pure $ fmap (\x -> pair (pair Nat x) sut) tys - _ -> Left "you are dumb" + Sum tys -> pure (tys <&> (\x -> tSum (tSum Nat x) sut)) + _ -> Left "you are dumb" - nocks <- fmap snd <$> zipWithM compile newSubjTys brs + nocks <- zipWithM compile newSubjTys brs - resTy <- runInfer (infer sut (Eat exp brs)) - - pure (resTy, NEightPush nock (cases (toList nocks))) + pure (NEightPush nock (cases (toList nocks))) Eke x y -> do - (_, nock1) <- compile sut x - (_, nock2) <- compile sut y - pure (tBool, NFiveEq nock1 nock2) + nock1 <- compile sut x + nock2 <- compile sut y + pure (NFiveEq nock1 nock2) Wit ex1 ex2 -> do - (sut', nock1) <- compile sut ex1 - (resTy, nock2) <- compile sut' ex2 - pure (resTy, NSevenThen nock1 nock2) + sut' <- runInfer (infer sut ex1) + nock1 <- compile sut ex1 + nock2 <- compile sut' ex2 + pure (NSevenThen nock1 nock2) Lam ty exp -> do - resTy <- runInfer (infer ty exp) - nock <- (NOneConst . nockToNoun . snd) <$> compile ty exp - pure (Nok sut resTy, nock) + NOneConst . nockToNoun <$> compile ty exp Fir sub for -> do - (subTy, subNock) <- compile sut sub - (forTy, forNock) <- compile sut for - resTy <- case forTy of - Nok _ resTy -> pure resTy - _ -> Left "bad-fir-e" - pure (resTy, NTwoCompose subNock forNock) + subNock <- compile sut sub + forNock <- compile sut for + pure (NTwoCompose subNock forNock) -- TODO Nock nine zapZap :: Nock zapZap = NZeroAxis 0 genCons :: Ty -> [Exp] -> Either Text Nock -genCons sut [] = snd <$> compile sut (Lit 0) -genCons sut [x] = snd <$> compile sut x -genCons sut (x:xs) = do - (_, n) <- compile sut x - (_, ns) <- compile sut (Tup (fromList xs)) - pure (NCons n ns) +genCons sut [] = compile sut (Lit 0) +genCons sut [x] = compile sut x +genCons sut (x:xs) = do n <- compile sut x + ns <- compile sut (Tup (fromList xs)) + pure (NCons n ns) cases :: [Nock] -> Nock cases = go 0 From 8e3d71747c770f789c226b3ef84298d287c34053 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 23 May 2019 15:16:32 -0700 Subject: [PATCH 039/431] More cleanup. --- pkg/hoon/lib/Language/Attila/IR.hs | 92 ++++++++++++++++-------------- 1 file changed, 49 insertions(+), 43 deletions(-) diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hoon/lib/Language/Attila/IR.hs index 1a6091ac8..f5f2a4165 100644 --- a/pkg/hoon/lib/Language/Attila/IR.hs +++ b/pkg/hoon/lib/Language/Attila/IR.hs @@ -10,7 +10,7 @@ import Control.Monad.Fail import Control.Arrow ((>>>)) import Data.ChunkedZip (Zip) import Language.Hoon.Nock.Types -import Text.Show.Pretty (pPrint) +import Text.Show.Pretty (ppShow) -------------------------------------------------------------------------------- @@ -57,15 +57,15 @@ data Ty data Exp = Sub | Lam Ty Exp - | Wit Exp Exp + | Wit Ty Exp Exp | Fir Exp Exp | Lit Nat | Inc Exp | Eke Exp Exp | Tup (Vec Exp) - | Get Nat Exp + | Get {- (Vec Ty) -} Nat Exp | Cho (Vec Ty) Nat Exp - | Eat Exp (Vec Exp) + | Eat {- (Vec Ty) -} Exp (Vec Exp) deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- @@ -95,26 +95,28 @@ unify = toList >>> \case [] -> pure tVoid -------------------------------------------------------------------------------- infer :: Ty -> Exp -> Infer Ty -infer sub Sub = pure sub -infer sub (Lam lub b) = Nok lub <$> infer lub b -infer sub (Wit new bod) = do newSub <- infer sub new - infer newSub bod -infer sub (Fir new bod) = do newSub <- infer sub new - infer newSub bod -infer _ (Lit _) = pure Nat -infer sub (Inc exp) = do eTy <- infer sub exp - unify [eTy, Nat] -infer sub (Eke ex1 ex2) = do ty1 <- infer sub ex1 - ty2 <- infer sub ex2 - unify [Nat, ty1, ty2] -infer sub (Tup exps) = Mul <$> traverse (infer sub) exps -infer sub (Get n tup) = infer sub tup >>= inferGet n -infer sub (Cho tys n exp) = infer sub exp >>= inferCho tys n -infer sub (Eat exp bods) = inferEat sub exp bods +infer sut Sub = pure sut +infer sut (Lam lub b) = Nok lub <$> infer lub b +infer sut (Wit ty new bod) = do newSub <- infer sut new + unify [ty, newSub] + infer ty bod +infer sut (Fir new bod) = do newSub <- infer sut new + infer newSub bod +infer _ (Lit _) = pure Nat +infer sut (Inc exp) = do eTy <- infer sut exp + unify [eTy, Nat] +infer sut (Eke ex1 ex2) = do ty1 <- infer sut ex1 + ty2 <- infer sut ex2 + unify [Nat, ty1, ty2] +infer sut (Tup exps) = Mul <$> traverse (infer sut) exps +infer sut (Get n tup) = infer sut tup >>= inferGet n +infer sut (Cho tys n exp) = infer sut exp >>= inferCho tys n +infer sut (Eat exp bods) = inferEat sut exp bods inferGet :: Nat -> Ty -> Infer Ty inferGet n ty = do - Mul tys <- pure ty + tys <- ty & \case Mul tys -> pure tys + _ -> fail ("mul-bad-ty: " <> show ty) maybe (fail "mul-bad-index") pure (tys !? fromIntegral n) inferCho :: Vec Ty -> Nat -> Ty -> Infer Ty @@ -130,7 +132,7 @@ inferEat sub exp bods = do unify =<< zipWithM checkBranch tys bods where checkBranch :: Ty -> Exp -> Infer Ty - checkBranch brTy exp = infer (tSum (tSum Nat brTy) sub) exp + checkBranch brTy exp = infer (tPair (tPair Nat brTy) sub) exp -------------------------------------------------------------------------------- @@ -160,38 +162,43 @@ tup2 x y = Tup [x, y] choEx, tupEx, widEx, eatEx :: Exp choEx = Cho [Nat, Nat] 0 (Lit 0) tupEx = Get 0 $ Get 1 $ tup2 (Lit 3) $ tup2 (Lit 4) (Lit 5) -widEx = Wit (Lit 3) Sub +widEx = Wit Nat (Lit 3) Sub eatEx = Eat choEx [Get 1 (Get 0 Sub), Inc (Lit 0)] -------------------------------------------------------------------------------- -try :: Exp -> IO () -try e = do - putStrLn "" - pPrint e - putStrLn "\n" - putStrLn "" - pPrint (runInfer (infer tTop e)) - putStrLn "\n" - putStrLn "" - pPrint (compile tTop e) - putStrLn "\n" +indent :: String -> String +indent = unlines . fmap (" " <>) . lines + +try :: Text -> Exp -> IO () +try m e = do + putStrLn ("<" <> m <> ">") + putStrLn " " + putStr (pack $ indent (ppShow e)) + putStrLn " " + putStrLn " " + putStr (pack $ indent (ppShow (runInfer (infer tTop e)))) + putStrLn " " + putStrLn " " + putStr (pack $ indent (ppShow (compile tTop e))) + putStrLn " " + putStrLn (" m <> ">\n") tryTup :: IO () -tryTup = try tupEx +tryTup = try "tup" tupEx -tryWid :: IO () -tryWid = try widEx +tryWit :: IO () +tryWit = try "wid" widEx tryCho :: IO () -tryCho = try choEx +tryCho = try "cho" choEx tryEat :: IO () -tryEat = try eatEx +tryEat = try "eat" eatEx tryAll :: IO () -tryAll = tryTup >> tryWid >> tryCho >> tryEat +tryAll = tryTup >> tryWit >> tryCho >> tryEat -------------------------------------------------------------------------------- @@ -224,7 +231,7 @@ compile sut = \case headTy <- runInfer (infer sut exp) nock <- compile sut exp newSubjTys <- headTy & \case - Sum tys -> pure (tys <&> (\x -> tSum (tSum Nat x) sut)) + Sum tys -> pure (tys <&> (\x -> tPair (tPair Nat x) sut)) _ -> Left "you are dumb" nocks <- zipWithM compile newSubjTys brs @@ -236,8 +243,7 @@ compile sut = \case nock2 <- compile sut y pure (NFiveEq nock1 nock2) - Wit ex1 ex2 -> do - sut' <- runInfer (infer sut ex1) + Wit sut' ex1 ex2 -> do nock1 <- compile sut ex1 nock2 <- compile sut' ex2 pure (NSevenThen nock1 nock2) From 5dc839bc362b852803a215362d5a277e83bfbcdb Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Thu, 23 May 2019 16:58:18 -0700 Subject: [PATCH 040/431] Add some server stuff. --- pkg/arvo | 2 +- pkg/hair/lib/Data/Noun/Jam/Fast.hs | 9 +++++---- pkg/hair/lib/Vere/Http.hs | 12 ++++++++++-- pkg/hair/lib/Vere/Http/Client.hs | 3 +-- pkg/hair/lib/Vere/Http/Server.hs | 31 ++++++++++++++++++++++++++++++ pkg/hair/package.yaml | 3 ++- 6 files changed, 50 insertions(+), 10 deletions(-) diff --git a/pkg/arvo b/pkg/arvo index 587b4d26d..23507c12f 160000 --- a/pkg/arvo +++ b/pkg/arvo @@ -1 +1 @@ -Subproject commit 587b4d26df6396a21478a110fc0736df319298a0 +Subproject commit 23507c12fbe8ff42cb165e1ec5456b895bf6de5b diff --git a/pkg/hair/lib/Data/Noun/Jam/Fast.hs b/pkg/hair/lib/Data/Noun/Jam/Fast.hs index 97f6763d6..9ac77c498 100644 --- a/pkg/hair/lib/Data/Noun/Jam/Fast.hs +++ b/pkg/hair/lib/Data/Noun/Jam/Fast.hs @@ -244,10 +244,11 @@ peekWord :: Get Word peekWord = do off <- peekUsedBits cur <- peekCurWord - if off == 0 then pure cur else do - nex <- peekNextWord - advance 64 - pure (dropLowBits off cur .|. dropHighBits off nex) + if off == 0 then pure cur else + do + nex <- peekNextWord + advance 64 + pure (dropLowBits off cur .|. dropHighBits off nex) dropLowBits :: Word -> Word -> Word dropLowBits bits wor = shiftR wor (fromIntegral bits :: Int) diff --git a/pkg/hair/lib/Vere/Http.hs b/pkg/hair/lib/Vere/Http.hs index 00553d8ea..6d034840a 100644 --- a/pkg/hair/lib/Vere/Http.hs +++ b/pkg/hair/lib/Vere/Http.hs @@ -5,10 +5,13 @@ module Vere.Http where import ClassyPrelude import Data.Noun +import qualified Data.CaseInsensitive as CI +import qualified Network.HTTP.Types as HT +import qualified Network.HTTP.Types.Method as H + data Header = Header Text Text -data Method = CONNECT | DELETE | GET | HEAD | OPTIONS | POST | PUT | TRACE - deriving (Eq,Ord,Show) +type Method = H.StdMethod data Request = Request { method :: Method @@ -27,3 +30,8 @@ data Event = Started ResponseHeader -- [%start hdr (unit octs) ?] | Done -- [%continue ~ %.y] | Canceled -- %cancel | Failed Text -- %cancel + +convertHeaders :: [HT.Header] -> [Header] +convertHeaders = fmap f + where + f (k, v) = Header (decodeUtf8 (CI.original k)) (decodeUtf8 v) diff --git a/pkg/hair/lib/Vere/Http/Client.hs b/pkg/hair/lib/Vere/Http/Client.hs index d3833f5f8..2261c1ab4 100644 --- a/pkg/hair/lib/Vere/Http/Client.hs +++ b/pkg/hair/lib/Vere/Http/Client.hs @@ -47,8 +47,7 @@ cvtRespHeaders :: H.Response a -> ResponseHeader cvtRespHeaders resp = ResponseHeader (HT.statusCode (H.responseStatus resp)) heads where - heads = H.responseHeaders resp <&> \(k, v) -> - Header (decodeUtf8 (CI.original k)) (decodeUtf8 v) + heads = convertHeaders (H.responseHeaders resp) -------------------------------------------------------------------------------- diff --git a/pkg/hair/lib/Vere/Http/Server.hs b/pkg/hair/lib/Vere/Http/Server.hs index fc2c89a57..7333fce87 100644 --- a/pkg/hair/lib/Vere/Http/Server.hs +++ b/pkg/hair/lib/Vere/Http/Server.hs @@ -5,6 +5,11 @@ module Vere.Http.Server where import ClassyPrelude import Vere.Http +import Data.Noun.Atom +import Data.Noun.Pill (packAtom) +import qualified Network.HTTP.Types.Method as H +import qualified Network.Wai as H + type ServerId = Word type ConnectionId = Word type RequestId = Word @@ -37,3 +42,29 @@ data ClientResponse | Cancel data MimeData = MimeData Text ByteString + +-- + +cookMeth :: H.Request -> Maybe Method +cookMeth re = + case H.parseMethod (H.requestMethod re) of + Left _ -> Nothing + Right m -> Just m + +data Octs = Octs Atom Atom + +bsToOcts :: ByteString -> Octs +bsToOcts bs = Octs (fromIntegral (length bs)) (packAtom bs) + +readEvents :: H.Request -> IO Request +readEvents request = do + let Just method = cookMeth request + url = decodeUtf8 (H.rawPathInfo request) + headers = convertHeaders (H.requestHeaders request) + bodyLbs <- H.strictRequestBody request + let body = if length bodyLbs == 0 then Nothing + else Just (toStrict bodyLbs) + + -- TODO: Check if wai just deletes the 'host': header like h2o does? + + pure (Request method url headers body) diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index ecebf9b2a..afe845b21 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -42,6 +42,7 @@ dependencies: - extra - flat - ghc-prim + - hashtables - http-client - http-types - integer-gmp @@ -67,7 +68,7 @@ dependencies: - transformers - unordered-containers - vector - - hashtables + - wai default-extensions: - ApplicativeDo From 98f861afb453329241df8101396494f017bf9938 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Thu, 23 May 2019 16:58:29 -0700 Subject: [PATCH 041/431] \#*\#*\#*\#*\#*\#*\#* --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index d7c0f17a5..02b9bc0c1 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ TAGS cross/ release/ .stack-work +\#*\# From 7989d07ec30fa6dfa58d9683541eb4c2ebfc04c5 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 23 May 2019 17:16:28 -0700 Subject: [PATCH 042/431] More Attilla.IR cleanup. --- pkg/hoon/lib/Language/Attila/IR.hs | 114 ++++++++++------------- pkg/hoon/lib/Language/Hoon/Nock/Types.hs | 1 - 2 files changed, 51 insertions(+), 64 deletions(-) diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hoon/lib/Language/Attila/IR.hs index f5f2a4165..c0b7be399 100644 --- a/pkg/hoon/lib/Language/Attila/IR.hs +++ b/pkg/hoon/lib/Language/Attila/IR.hs @@ -63,9 +63,9 @@ data Exp | Inc Exp | Eke Exp Exp | Tup (Vec Exp) - | Get {- (Vec Ty) -} Nat Exp + | Get Nat (Vec Ty) Exp | Cho (Vec Ty) Nat Exp - | Eat {- (Vec Ty) -} Exp (Vec Exp) + | Eat (Vec Ty) Exp (Vec Exp) deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- @@ -95,44 +95,36 @@ unify = toList >>> \case [] -> pure tVoid -------------------------------------------------------------------------------- infer :: Ty -> Exp -> Infer Ty -infer sut Sub = pure sut -infer sut (Lam lub b) = Nok lub <$> infer lub b -infer sut (Wit ty new bod) = do newSub <- infer sut new - unify [ty, newSub] - infer ty bod -infer sut (Fir new bod) = do newSub <- infer sut new - infer newSub bod -infer _ (Lit _) = pure Nat -infer sut (Inc exp) = do eTy <- infer sut exp - unify [eTy, Nat] -infer sut (Eke ex1 ex2) = do ty1 <- infer sut ex1 - ty2 <- infer sut ex2 - unify [Nat, ty1, ty2] -infer sut (Tup exps) = Mul <$> traverse (infer sut) exps -infer sut (Get n tup) = infer sut tup >>= inferGet n -infer sut (Cho tys n exp) = infer sut exp >>= inferCho tys n -infer sut (Eat exp bods) = inferEat sut exp bods - -inferGet :: Nat -> Ty -> Infer Ty -inferGet n ty = do - tys <- ty & \case Mul tys -> pure tys - _ -> fail ("mul-bad-ty: " <> show ty) - maybe (fail "mul-bad-index") pure (tys !? fromIntegral n) - -inferCho :: Vec Ty -> Nat -> Ty -> Infer Ty -inferCho tys n ty = do - tu <- maybe (fail "cho-bad-index") pure (tys !? fromIntegral n) - unify [tu, ty] - pure (Sum tys) - -inferEat :: Ty -> Exp -> Vec Exp -> Infer Ty -inferEat sub exp bods = do - Sum tys <- infer sub exp - guardInfer "eat-bad-len" (length tys == length bods) - unify =<< zipWithM checkBranch tys bods - where - checkBranch :: Ty -> Exp -> Infer Ty - checkBranch brTy exp = infer (tPair (tPair Nat brTy) sub) exp +infer sut Sub = pure sut +infer sut (Lam lub b) = Nok lub <$> infer lub b +infer sut (Wit ty new bod) = do newSub <- infer sut new + unify [ty, newSub] + infer ty bod +infer sut (Fir new bod) = do newSub <- infer sut new + infer newSub bod +infer _ (Lit _) = pure Nat +infer sut (Inc exp) = do eTy <- infer sut exp + unify [eTy, Nat] +infer sut (Eke ex1 ex2) = do ty1 <- infer sut ex1 + ty2 <- infer sut ex2 + unify [Nat, ty1, ty2] +infer sut (Tup exps) = Mul <$> traverse (infer sut) exps +infer sut (Get n tys tup) = do tupTy <- infer sut tup + unify [Mul tys, tupTy] + maybe (fail "mul-bad-index") pure + (tys !? fromIntegral n) +infer sut (Cho tys n exp) = do ty <- infer sut exp + tu <- maybe (fail "cho-bad-index") pure + (tys !? fromIntegral n) + unify [tu, ty] + pure (Sum tys) +infer sut (Eat tys exp bods) = do expTy <- infer sut exp + unify [expTy, Sum tys] + guardInfer "eat-bad-len" + (length tys == length bods) + let checkBranch br exp = + infer (tPair (tPair Nat br) sut) exp + unify =<< zipWithM checkBranch tys bods -------------------------------------------------------------------------------- @@ -161,9 +153,17 @@ tup2 x y = Tup [x, y] choEx, tupEx, widEx, eatEx :: Exp choEx = Cho [Nat, Nat] 0 (Lit 0) -tupEx = Get 0 $ Get 1 $ tup2 (Lit 3) $ tup2 (Lit 4) (Lit 5) widEx = Wit Nat (Lit 3) Sub -eatEx = Eat choEx [Get 1 (Get 0 Sub), Inc (Lit 0)] +tupEx = Get 0 [Nat, Nat] + $ Get 1 [Nat, Mul [Nat, Nat]] + $ tup2 (Lit 3) (tup2 (Lit 4) (Lit 5)) + +eatEx = Eat [Nat, Nat] + choEx + [ Get 1 [Nat, Nat] + (Get 0 [Mul [Nat, Nat], tTop] Sub) + , Inc (Lit 0) + ] -------------------------------------------------------------------------------- @@ -173,17 +173,13 @@ indent = unlines . fmap (" " <>) . lines try :: Text -> Exp -> IO () try m e = do - putStrLn ("<" <> m <> ">") - putStrLn " " + putStrLn (m <> ":") + putStrLn " exp:" putStr (pack $ indent (ppShow e)) - putStrLn " " - putStrLn " " + putStrLn " type:" putStr (pack $ indent (ppShow (runInfer (infer tTop e)))) - putStrLn " " - putStrLn " " + putStrLn " nock:" putStr (pack $ indent (ppShow (compile tTop e))) - putStrLn " " - putStrLn (" m <> ">\n") tryTup :: IO () tryTup = try "tup" tupEx @@ -215,27 +211,19 @@ compile sut = \case Cho tys n exp -> do nock <- compile sut exp pure (NCons (NOneConst (Atom (fromIntegral n))) nock) - Get n exp -> do - vecTy <- runInfer (infer sut exp) + Get n tys exp -> do vecNock <- compile sut exp - axis <- case vecTy of - Mul tys -> pure (getAxis n (fromIntegral $ length tys)) - ty -> Left ("get-not-mul: " <> tshow ty) + axis <- pure (getAxis n (fromIntegral $ length tys)) pure (NSevenThen vecNock (NZeroAxis $ fromIntegral axis)) Tup xs -> do nock <- genCons sut (toList xs) pure nock - Eat exp brs -> do - headTy <- runInfer (infer sut exp) + Eat tys exp brs -> do nock <- compile sut exp - newSubjTys <- headTy & \case - Sum tys -> pure (tys <&> (\x -> tPair (tPair Nat x) sut)) - _ -> Left "you are dumb" - - nocks <- zipWithM compile newSubjTys brs - + newSubjTys <- pure (tys <&> (\x -> tPair (tPair Nat x) sut)) + nocks <- zipWithM compile newSubjTys brs pure (NEightPush nock (cases (toList nocks))) Eke x y -> do diff --git a/pkg/hoon/lib/Language/Hoon/Nock/Types.hs b/pkg/hoon/lib/Language/Hoon/Nock/Types.hs index cce513476..014be2b6e 100644 --- a/pkg/hoon/lib/Language/Hoon/Nock/Types.hs +++ b/pkg/hoon/lib/Language/Hoon/Nock/Types.hs @@ -55,4 +55,3 @@ nockToNoun = go ho (Tag x) = (Atom x) ho (Assoc x n) = (Cell (Atom x) (go n)) - From edd289181b307c0e5a7cab29dc965f84de960d90 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Fri, 24 May 2019 16:03:46 -0700 Subject: [PATCH 043/431] Some server stuff. --- pkg/hair/lib/Vere/Http/Server.hs | 63 +++++++++++++++++++++++++++----- pkg/hair/package.yaml | 2 + 2 files changed, 56 insertions(+), 9 deletions(-) diff --git a/pkg/hair/lib/Vere/Http/Server.hs b/pkg/hair/lib/Vere/Http/Server.hs index 7333fce87..95517f253 100644 --- a/pkg/hair/lib/Vere/Http/Server.hs +++ b/pkg/hair/lib/Vere/Http/Server.hs @@ -5,10 +5,13 @@ module Vere.Http.Server where import ClassyPrelude import Vere.Http +import Control.Concurrent (ThreadId, killThread) import Data.Noun.Atom import Data.Noun.Pill (packAtom) -import qualified Network.HTTP.Types.Method as H -import qualified Network.Wai as H +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.WarpTLS as W type ServerId = Word type ConnectionId = Word @@ -34,7 +37,7 @@ newtype Key = Key PEM newtype Cert = Cert PEM data Wain = Wain [Text] -data PEM +newtype PEM = PEM ByteString data ClientResponse = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString) @@ -45,9 +48,51 @@ data MimeData = MimeData Text ByteString -- -cookMeth :: H.Request -> Maybe Method +data Ev + +data State = State + { thread :: MVar (Maybe (Config, ThreadId)) + , sChan :: MVar Ev + } + +init :: IO State +init = + -- When we initialize things, we send an event into arvo + -- When we receive the set-config event, then we start stuff up + + -- This works for now, but we need to actually do stuff per above. + State <$> newMVar Nothing + <*> newEmptyMVar + +onSetConfig :: State -> Config -> IO () +onSetConfig s c = do + v <- takeMVar (thread s) + + maybe (pure ()) (killThread . snd) v + + putMVar (thread s) Nothing + startServer s c + +startServer :: State -> Config -> IO () +startServer s c = do + tls <- case (secure c) of + Nothing -> error "no wai" + Just (Key (PEM key), Cert (PEM cert)) -> + pure (W.tlsSettingsMemory cert key) + + -- we need to do the dance where we do the socket checking dance. or shove a + -- socket into it. + W.runTLS tls W.defaultSettings (app s) + +app :: State -> W.Application +app s req respond = bracket_ + (pure ()) + (pure ()) + (respond $ W.responseLBS H.status200 [] "Hello World") + +cookMeth :: W.Request -> Maybe Method cookMeth re = - case H.parseMethod (H.requestMethod re) of + case H.parseMethod (W.requestMethod re) of Left _ -> Nothing Right m -> Just m @@ -56,12 +101,12 @@ data Octs = Octs Atom Atom bsToOcts :: ByteString -> Octs bsToOcts bs = Octs (fromIntegral (length bs)) (packAtom bs) -readEvents :: H.Request -> IO Request +readEvents :: W.Request -> IO Request readEvents request = do let Just method = cookMeth request - url = decodeUtf8 (H.rawPathInfo request) - headers = convertHeaders (H.requestHeaders request) - bodyLbs <- H.strictRequestBody request + url = decodeUtf8 (W.rawPathInfo request) + headers = convertHeaders (W.requestHeaders request) + bodyLbs <- W.strictRequestBody request let body = if length bodyLbs == 0 then Nothing else Just (toStrict bodyLbs) diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index afe845b21..ac060c486 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -69,6 +69,8 @@ dependencies: - unordered-containers - vector - wai + - warp + - warp-tls default-extensions: - ApplicativeDo From 845890e87c8edf6ef8d964a7385453e3c3054871 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Fri, 24 May 2019 16:08:59 -0700 Subject: [PATCH 044/431] Various fixes and improvements. --- pkg/hair/lib/Vere/Http/Server.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/pkg/hair/lib/Vere/Http/Server.hs b/pkg/hair/lib/Vere/Http/Server.hs index 95517f253..f3f37806b 100644 --- a/pkg/hair/lib/Vere/Http/Server.hs +++ b/pkg/hair/lib/Vere/Http/Server.hs @@ -5,7 +5,7 @@ module Vere.Http.Server where import ClassyPrelude import Vere.Http -import Control.Concurrent (ThreadId, killThread) +import Control.Concurrent (ThreadId, killThread, forkIO) import Data.Noun.Atom import Data.Noun.Pill (packAtom) import qualified Network.HTTP.Types as H @@ -82,7 +82,8 @@ startServer s c = do -- we need to do the dance where we do the socket checking dance. or shove a -- socket into it. - W.runTLS tls W.defaultSettings (app s) + tid <- forkIO $ W.runTLS tls W.defaultSettings (app s) + putMVar (thread s) (Just (c, tid)) app :: State -> W.Application app s req respond = bracket_ From 0be4b8527f4f7b26a477a2b26e7309a7181dee32 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 24 May 2019 18:10:24 -0700 Subject: [PATCH 045/431] Attila: Use nock 9 for firing arms. --- pkg/hoon/lib/Language/Attila/IR.hs | 127 +++++++++++++++++++---------- 1 file changed, 85 insertions(+), 42 deletions(-) diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hoon/lib/Language/Attila/IR.hs index c0b7be399..5680f9b89 100644 --- a/pkg/hoon/lib/Language/Attila/IR.hs +++ b/pkg/hoon/lib/Language/Attila/IR.hs @@ -35,7 +35,8 @@ data Ty - Sub -- Reference the current subject. - Lam -- A formula (with the type for its subject) - Wit -- Run an expression against a new subject. - - Fir -- Run a formula against a subject. + - Eva -- Eval a formula against a subject. + - Fir -- Fire an arm of a core. Atoms: @@ -58,7 +59,8 @@ data Exp = Sub | Lam Ty Exp | Wit Ty Exp Exp - | Fir Exp Exp + | Eva Exp Exp + | Fir Nat (Ty, Vec Ty) Exp | Lit Nat | Inc Exp | Eke Exp Exp @@ -92,39 +94,79 @@ unify = toList >>> \case [] -> pure tVoid guardInfer err (all (== x) xs) pure x +unifyVec :: Vec Ty -> Vec Ty -> Infer (Vec Ty) +unifyVec xs ys = do + let lenMsg = "unify-bad-len: " <> show (xs, ys) + guardInfer lenMsg (length xs == length ys) + zipWithM (\x y -> unify [x,y]) xs ys + -------------------------------------------------------------------------------- +battery :: Ty -> Infer (Vec Ty) +battery (Mul [Mul arms, _ctx]) = pure arms +battery ty = fail ("battery-not-core: " <> show ty) + +arm :: Nat -> Ty -> Vec Ty -> Infer (Nat, Ty, Ty) +arm n cor arms = do + let len = fromIntegral (length arms) + arms !? fromIntegral n & \case + Nothing -> + fail ("arm-bad-idx: " <> show (n, arms)) + Just (Nok nokSut nokRes) -> do + unify [cor, nokSut] + pure (getAxis n len, nokSut, nokRes) + Just armTy -> + fail ("arm-not-nok: " <> show armTy) + +nokResTy :: Ty -> Ty -> Infer Ty +nokResTy sut (Nok nSut nRes) = unify [sut, nSut] $> nRes +nokResTy _ ty = fail ("not-nok: " <> show ty) + infer :: Ty -> Exp -> Infer Ty -infer sut Sub = pure sut -infer sut (Lam lub b) = Nok lub <$> infer lub b -infer sut (Wit ty new bod) = do newSub <- infer sut new - unify [ty, newSub] - infer ty bod -infer sut (Fir new bod) = do newSub <- infer sut new - infer newSub bod -infer _ (Lit _) = pure Nat -infer sut (Inc exp) = do eTy <- infer sut exp - unify [eTy, Nat] -infer sut (Eke ex1 ex2) = do ty1 <- infer sut ex1 - ty2 <- infer sut ex2 - unify [Nat, ty1, ty2] -infer sut (Tup exps) = Mul <$> traverse (infer sut) exps -infer sut (Get n tys tup) = do tupTy <- infer sut tup - unify [Mul tys, tupTy] - maybe (fail "mul-bad-index") pure - (tys !? fromIntegral n) -infer sut (Cho tys n exp) = do ty <- infer sut exp - tu <- maybe (fail "cho-bad-index") pure - (tys !? fromIntegral n) - unify [tu, ty] - pure (Sum tys) -infer sut (Eat tys exp bods) = do expTy <- infer sut exp - unify [expTy, Sum tys] - guardInfer "eat-bad-len" - (length tys == length bods) - let checkBranch br exp = - infer (tPair (tPair Nat br) sut) exp - unify =<< zipWithM checkBranch tys bods +infer sut = \case + Sub -> do + pure sut + Lam lub b -> do + Nok lub <$> infer lub b + Wit ty new bod -> do + newSut <- infer sut new + unify [ty, newSut] + infer ty bod + Eva new bod -> do + sut' <- infer sut new + infer sut bod >>= nokResTy sut + Fir n (corTy, armTys) cor -> do + corTy' <- infer sut cor + armTys' <- battery corTy + unify [corTy, corTy'] + unifyVec armTys armTys' + view _3 <$> arm n corTy armTys + Lit _ -> do + pure Nat + Inc exp -> do + eTy <- infer sut exp + unify [eTy, Nat] + Eke ex1 ex2 -> do + ty1 <- infer sut ex1 + ty2 <- infer sut ex2 + unify [Nat, ty1, ty2] + Tup exps -> do + Mul <$> traverse (infer sut) exps + Get n tys tup -> do + tupTy <- infer sut tup + unify [Mul tys, tupTy] + maybe (fail "mul-bad-index") pure (tys !? fromIntegral n) + Cho tys n exp -> do + ty <- infer sut exp + tu <- maybe (fail "cho-bad-index") pure (tys !? fromIntegral n) + unify [tu, ty] + pure (Sum tys) + Eat tys exp bods -> do + expTy <- infer sut exp + unify [expTy, Sum tys] + guardInfer "eat-bad-len" (length tys == length bods) + let checkBranch br exp = infer (tPair (tPair Nat br) sut) exp + unify =<< zipWithM checkBranch tys bods -------------------------------------------------------------------------------- @@ -134,8 +176,9 @@ tPair x y = Mul [x,y] tSum :: Ty -> Ty -> Ty tSum x y = Sum [x, y] -tUnit, tVoid, tAtom, tNoun, tOpt, tEith, tBool, tOrd, tTop :: Ty +tUnit, tBox, tVoid, tAtom, tNoun, tOpt, tEith, tBool, tOrd, tTop :: Ty tUnit = Mul [] +tBox = All $ Mul [Ref 0] tVoid = Sum [] tAtom = Nat tNoun = Fix $ tSum Nat (tSum (Ref 0) (Ref 0)) @@ -198,7 +241,10 @@ tryAll = tryTup >> tryWit >> tryCho >> tryEat -------------------------------------------------------------------------------- --- TODO Record layout. +{- + - TODO Record layout (tree instead of list). + - TODO Sum layout (use all of atom, atom-head, and cell-head). +-} compile :: Ty -> Exp -> Either Text Nock compile sut = \case Sub -> @@ -215,35 +261,32 @@ compile sut = \case vecNock <- compile sut exp axis <- pure (getAxis n (fromIntegral $ length tys)) pure (NSevenThen vecNock (NZeroAxis $ fromIntegral axis)) - Tup xs -> do nock <- genCons sut (toList xs) pure nock - Eat tys exp brs -> do nock <- compile sut exp newSubjTys <- pure (tys <&> (\x -> tPair (tPair Nat x) sut)) nocks <- zipWithM compile newSubjTys brs pure (NEightPush nock (cases (toList nocks))) - Eke x y -> do nock1 <- compile sut x nock2 <- compile sut y pure (NFiveEq nock1 nock2) - Wit sut' ex1 ex2 -> do nock1 <- compile sut ex1 nock2 <- compile sut' ex2 pure (NSevenThen nock1 nock2) - Lam ty exp -> do NOneConst . nockToNoun <$> compile ty exp - - Fir sub for -> do + Eva sub for -> do subNock <- compile sut sub forNock <- compile sut for pure (NTwoCompose subNock forNock) - -- TODO Nock nine + Fir n (corTy, armTys) cor -> do + getCore <- compile sut cor + (a,_,_) <- runInfer (arm n corTy armTys) + pure (NNineInvoke (fromIntegral a) getCore) zapZap :: Nock zapZap = NZeroAxis 0 From 20a95edacb412a295cd9fda655b0922cfd01984e Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 24 May 2019 18:33:46 -0700 Subject: [PATCH 046/431] Bugfix + core example (but has infinite type until recursive types are implemented). --- pkg/hoon/lib/Language/Attila/IR.hs | 44 ++++++++++++++++++++++++++++-- 1 file changed, 41 insertions(+), 3 deletions(-) diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hoon/lib/Language/Attila/IR.hs index 5680f9b89..30f0dabbd 100644 --- a/pkg/hoon/lib/Language/Attila/IR.hs +++ b/pkg/hoon/lib/Language/Attila/IR.hs @@ -133,8 +133,9 @@ infer sut = \case unify [ty, newSut] infer ty bod Eva new bod -> do - sut' <- infer sut new - infer sut bod >>= nokResTy sut + sut' <- infer sut new + nokTy <- infer sut bod + nokResTy sut' nokTy Fir n (corTy, armTys) cor -> do corTy' <- infer sut cor armTys' <- battery corTy @@ -208,6 +209,25 @@ eatEx = Eat [Nat, Nat] , Inc (Lit 0) ] +lamEx :: Exp +lamEx = Lam Nat (tup2 (Inc Sub) Sub) + +evaEx :: Exp +evaEx = Eva (Lit 0) lamEx + +armExTy, batExTy, corExTy :: Ty +armExTy = Nok corExTy Nat +batExTy = Mul [armExTy] +corExTy = Mul [batExTy, Nat] + +armEx :: Exp +armEx = Lam corExTy Sub + +batEx :: Exp +batEx = Tup [armEx] + +corEx :: Exp +corEx = Tup [batEx, Lit 0] -------------------------------------------------------------------------------- @@ -236,8 +256,26 @@ tryCho = try "cho" choEx tryEat :: IO () tryEat = try "eat" eatEx +tryLam :: IO () +tryLam = try "lam" lamEx + +tryEva :: IO () +tryEva = try "eva" evaEx + +{- TODO Implement recursive types -} +-- tryArm :: IO () +-- tryArm = try "arm" armEx + +{- TODO Implement recursive types -} +-- tryBat :: IO () +-- tryBat = try "bat" batEx + +{- TODO Implement recursive types -} +-- tryCor :: IO () +-- tryCor = try "cor" corEx + tryAll :: IO () -tryAll = tryTup >> tryWit >> tryCho >> tryEat +tryAll = tryTup >> tryWit >> tryCho >> tryEat >> tryLam >> tryEva -------------------------------------------------------------------------------- From 854e2da4b86fd57d8f1d2e5b795aeab70dd0c4b1 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 27 May 2019 16:10:17 -0700 Subject: [PATCH 047/431] Correct axis for fire. --- pkg/hoon/lib/Language/Attila/IR.hs | 97 ++++++++++++++++-------------- 1 file changed, 51 insertions(+), 46 deletions(-) diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hoon/lib/Language/Attila/IR.hs index 30f0dabbd..3d8551099 100644 --- a/pkg/hoon/lib/Language/Attila/IR.hs +++ b/pkg/hoon/lib/Language/Attila/IR.hs @@ -88,11 +88,19 @@ guardInfer :: String -> Bool -> Infer () guardInfer _ True = pure () guardInfer msg False = fail msg +unify2 :: Ty -> Ty -> Infer Ty +unify2 x y = do + let err = "(bad_unify " <> show x <> " ## " <> show y <> ")" + guardInfer err (x == y) + pure x + unify :: Vec Ty -> Infer Ty -unify = toList >>> \case [] -> pure tVoid - x:xs -> do let err = "bad-unify " <> show (x:xs) - guardInfer err (all (== x) xs) - pure x +unify = go . toList + where + go :: [Ty] -> Infer Ty + go [] = pure tVoid + go [x] = pure x + go (x:y:zs) = unify2 x y >> go (y:zs) unifyVec :: Vec Ty -> Vec Ty -> Infer (Vec Ty) unifyVec xs ys = do @@ -114,7 +122,7 @@ arm n cor arms = do fail ("arm-bad-idx: " <> show (n, arms)) Just (Nok nokSut nokRes) -> do unify [cor, nokSut] - pure (getAxis n len, nokSut, nokRes) + pure (armAxis n len, nokSut, nokRes) Just armTy -> fail ("arm-not-nok: " <> show armTy) @@ -195,9 +203,9 @@ tTop = All $ Ref 0 tup2 :: Exp -> Exp -> Exp tup2 x y = Tup [x, y] -choEx, tupEx, widEx, eatEx :: Exp +choEx, tupEx, witEx, eatEx :: Exp choEx = Cho [Nat, Nat] 0 (Lit 0) -widEx = Wit Nat (Lit 3) Sub +witEx = Wit Nat (Lit 3) Sub tupEx = Get 0 [Nat, Nat] $ Get 1 [Nat, Mul [Nat, Nat]] $ tup2 (Lit 3) (tup2 (Lit 4) (Lit 5)) @@ -218,10 +226,10 @@ evaEx = Eva (Lit 0) lamEx armExTy, batExTy, corExTy :: Ty armExTy = Nok corExTy Nat batExTy = Mul [armExTy] -corExTy = Mul [batExTy, Nat] +corExTy = Fix $ Mul [Mul [Nok (Ref 0) Nat], Nat] armEx :: Exp -armEx = Lam corExTy Sub +armEx = Lam corExTy (Get 1 [batExTy, Nat] Sub) batEx :: Exp batEx = Tup [armEx] @@ -229,6 +237,9 @@ batEx = Tup [armEx] corEx :: Exp corEx = Tup [batEx, Lit 0] +firEx :: Exp +firEx = Fir 0 (corExTy, [armExTy]) corEx + -------------------------------------------------------------------------------- indent :: String -> String @@ -244,38 +255,18 @@ try m e = do putStrLn " nock:" putStr (pack $ indent (ppShow (compile tTop e))) -tryTup :: IO () -tryTup = try "tup" tupEx - -tryWit :: IO () -tryWit = try "wid" widEx - -tryCho :: IO () -tryCho = try "cho" choEx - -tryEat :: IO () -tryEat = try "eat" eatEx - -tryLam :: IO () -tryLam = try "lam" lamEx - -tryEva :: IO () -tryEva = try "eva" evaEx - -{- TODO Implement recursive types -} --- tryArm :: IO () --- tryArm = try "arm" armEx - -{- TODO Implement recursive types -} --- tryBat :: IO () --- tryBat = try "bat" batEx - -{- TODO Implement recursive types -} --- tryCor :: IO () --- tryCor = try "cor" corEx - tryAll :: IO () -tryAll = tryTup >> tryWit >> tryCho >> tryEat >> tryLam >> tryEva +tryAll = do + try "tup" tupEx + try "wit" witEx + try "cho" choEx + try "eat" eatEx + try "lam" lamEx + try "eva" evaEx + try "arm" armEx + try "bat" batEx + try "cor" corEx + try "fir" firEx -------------------------------------------------------------------------------- @@ -297,7 +288,7 @@ compile sut = \case pure (NCons (NOneConst (Atom (fromIntegral n))) nock) Get n tys exp -> do vecNock <- compile sut exp - axis <- pure (getAxis n (fromIntegral $ length tys)) + axis <- pure (tupAxis n (fromIntegral $ length tys)) pure (NSevenThen vecNock (NZeroAxis $ fromIntegral axis)) Tup xs -> do nock <- genCons sut (toList xs) @@ -345,10 +336,24 @@ cases = go 0 nock (go (tag+1) nocks) -getAxis :: Nat -> Nat -> Nat -getAxis 0 1 = 1 -getAxis 0 len = 2 -getAxis i len | i+1 == len = 1 + getAxis (i-1) len -getAxis i len = 2 * (1 + getAxis (i-1) len) +tupAxis :: Nat -> Nat -> Nat +tupAxis 0 1 = 1 +tupAxis 0 len = 2 +tupAxis i len | i+1 == len = 1 + tupAxis (i-1) len +tupAxis i len = 2 * (1 + tupAxis (i-1) len) + +armAxis :: Nat -> Nat -> Nat +armAxis 0 1 = 2 +armAxis 0 len = 4 +armAxis i len | i+1 == len = 1 + armAxis (i-1) len +armAxis i len = 2 * (1 + armAxis (i-1) len) -- Credits: Morgan, Ted, Benjamin + +{- +Fix (Mul [Mul [Nok (Ref 0) Nat],Nat]) +Fix (Mul [Mul [Nok (Ref 0) Nat],Nat]) + +1: (Fix (Mul [Mul [Nok (Ref 0) Nat],Nat])) +2: (Fix (Mul [Mul [Nok (Ref 0) Nat],Nat])) +-} From c5cc3308ce3e88e4dc310d0a3a1b111ca637d5de Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Tue, 28 May 2019 17:16:30 -0700 Subject: [PATCH 048/431] Sketching lmdb integration. Unfinished. --- pkg/hair/lib/Data/Noun/Pill.hs | 6 +++++ pkg/hair/lib/Vere/Log.hs | 45 ++++++++++++++++++++++++++++++++++ pkg/hair/package.yaml | 1 + 3 files changed, 52 insertions(+) create mode 100644 pkg/hair/lib/Vere/Log.hs diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs index 4d7c593f1..14bf656d9 100644 --- a/pkg/hair/lib/Data/Noun/Pill.hs +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -157,6 +157,12 @@ unpackAtom (MkAtom a) = wordsToBytes (naturalToWords a) -------------------------------------------------------------------------------- +bsToNoun :: ByteString -> Maybe Noun +bsToNoun = cue . packAtom + +nounToBs :: Noun -> ByteString +nounToBs = unpackAtom . jam + loadFile :: FilePath -> IO Atom loadFile = fmap packAtom . readFile diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs new file mode 100644 index 000000000..3d23ee3b5 --- /dev/null +++ b/pkg/hair/lib/Vere/Log.hs @@ -0,0 +1,45 @@ +module Vere.Log where + +import Database.LMDB.Raw +import ClassyPrelude +import Data.Void +import Data.ByteString.Unsafe + +data State = State + { env :: MDB_env + , q :: TQueue Void + } + + +init :: FilePath -> IO State +init dir = do + env <- mdb_env_create + mdb_env_set_maxdbs env 3 + mdb_env_set_mapsize env (40 * 1024 * 1024 * 1024) + mdb_env_open env dir [] + tq <- newTQueueIO + pure (State env tq) + + +shutdown :: State -> IO () +shutdown s = mdb_env_close (env s) + + +readQueue :: TQueue a -> STM [a] +readQueue q = do + first <- readTQueue q + go [first] + where + go acc = tryReadTQueue q >>= \case + Nothing -> pure (reverse acc) + Just item -> go (item:acc) + + +-- put :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> ByteString -> IO () +-- put flags txn db key val = do +-- unsafeUseAsCStringLen key $ \(pkey, skey) -> +-- unsafeUseAsCStringLen val $ \(pval, sval) -> do +-- let m_key = MDB_val skey pkey +-- m_val = MDB_val sval pval +-- success <- mdb_put flags txn db m_key m_val +-- pure () diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index ac060c486..8c2705d19 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -48,6 +48,7 @@ dependencies: - integer-gmp - largeword - lens + - lmdb - megaparsec - mtl - multimap From 43ba628aa6beb9923b7efff30bf7813f6c3d77ba Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 28 May 2019 17:32:39 -0700 Subject: [PATCH 049/431] Got Vere.Log.put to compile. --- pkg/hair/lib/Vere/Log.hs | 38 ++++++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 16 deletions(-) diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs index 3d23ee3b5..b5df2239c 100644 --- a/pkg/hair/lib/Vere/Log.hs +++ b/pkg/hair/lib/Vere/Log.hs @@ -1,15 +1,20 @@ module Vere.Log where import Database.LMDB.Raw -import ClassyPrelude +import ClassyPrelude hiding ((<|)) import Data.Void import Data.ByteString.Unsafe +import GHC.Ptr (castPtr) +import Data.List.NonEmpty (NonEmpty(..), (<|)) + +-------------------------------------------------------------------------------- data State = State { env :: MDB_env , q :: TQueue Void } +-------------------------------------------------------------------------------- init :: FilePath -> IO State init dir = do @@ -20,26 +25,27 @@ init dir = do tq <- newTQueueIO pure (State env tq) - shutdown :: State -> IO () shutdown s = mdb_env_close (env s) +-------------------------------------------------------------------------------- -readQueue :: TQueue a -> STM [a] -readQueue q = do - first <- readTQueue q - go [first] +readQueue :: TQueue a -> STM (NonEmpty a) +readQueue q = + readTQueue q >>= go . singleton where go acc = tryReadTQueue q >>= \case - Nothing -> pure (reverse acc) - Just item -> go (item:acc) + Nothing -> pure (reverse acc) + Just item -> go (item <| acc) +byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a +byteStringAsMdbVal bs k = + unsafeUseAsCStringLen bs \(ptr,sz) -> + k (MDB_val (fromIntegral sz) (castPtr ptr)) --- put :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> ByteString -> IO () --- put flags txn db key val = do --- unsafeUseAsCStringLen key $ \(pkey, skey) -> --- unsafeUseAsCStringLen val $ \(pval, sval) -> do --- let m_key = MDB_val skey pkey --- m_val = MDB_val sval pval --- success <- mdb_put flags txn db m_key m_val --- pure () +put :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> ByteString + -> IO Bool +put flags txn db key val = + byteStringAsMdbVal key \mKey -> + byteStringAsMdbVal val \mVal -> + mdb_put flags txn db mKey mVal From e562dac9f7ae92831250580ca8f7007541502b9a Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 29 May 2019 11:33:09 -0700 Subject: [PATCH 050/431] Various fixes and improvements. --- pkg/hair/lib/Vere/Isle.hs | 27 ++++++++++ pkg/hair/lib/Vere/Isle/Util.hs | 94 ++++++++++++++++++++++++++++++++++ pkg/hair/lib/Vere/Log.hs | 21 ++++---- pkg/hair/package.yaml | 2 + 4 files changed, 135 insertions(+), 9 deletions(-) create mode 100644 pkg/hair/lib/Vere/Isle.hs create mode 100644 pkg/hair/lib/Vere/Isle/Util.hs diff --git a/pkg/hair/lib/Vere/Isle.hs b/pkg/hair/lib/Vere/Isle.hs new file mode 100644 index 000000000..0fb25b228 --- /dev/null +++ b/pkg/hair/lib/Vere/Isle.hs @@ -0,0 +1,27 @@ +module Vere.Isle where + +import Prelude +import qualified Vere.Isle.Util as C +import qualified SDL + +-------------------------------------------------------------------------------- + +{- + +-} + +-------------------------------------------------------------------------------- + +main :: IO () +main = C.withSDL $ C.withWindow "Lesson 01" (640, 480) $ + \w -> do + + screen <- SDL.getWindowSurface w + -- pixelFormat <- SDL.surfaceFormat `applyToPointer` screen + -- color <- SDL.mapRGB pixelFormat 0xFF 0xFF 0xFF + SDL.surfaceFillRect screen Nothing (SDL.V4 maxBound maxBound maxBound maxBound) + SDL.updateWindowSurface w + + SDL.delay 2000 + + SDL.freeSurface screen diff --git a/pkg/hair/lib/Vere/Isle/Util.hs b/pkg/hair/lib/Vere/Isle/Util.hs new file mode 100644 index 000000000..b99334e4c --- /dev/null +++ b/pkg/hair/lib/Vere/Isle/Util.hs @@ -0,0 +1,94 @@ +module Vere.Isle.Util where + +import Prelude + +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) +import SDL (($=)) + +import qualified SDL +import qualified SDL.Image + +-------------------------------------------------------------------------------- + +withSDL :: (MonadIO m) => m a -> m () +withSDL op = do + SDL.initialize [] + void op + SDL.quit + + +withSDLImage :: (MonadIO m) => m a -> m () +withSDLImage op = do + SDL.Image.initialize [] + void op + SDL.Image.quit + + +withWindow :: (MonadIO m) => Text -> (Int, Int) -> (SDL.Window -> m a) -> m () +withWindow title (x, y) op = do + w <- SDL.createWindow title p + SDL.showWindow w + void $ op w + SDL.destroyWindow w + + where + p = SDL.defaultWindow { SDL.windowInitialSize = z } + z = SDL.V2 (fromIntegral x) (fromIntegral y) + + +withRenderer :: (MonadIO m) => SDL.Window -> (SDL.Renderer -> m a) -> m () +withRenderer w op = do + r <- SDL.createRenderer w (-1) rendererConfig + void $ op r + SDL.destroyRenderer r + + +rendererConfig :: SDL.RendererConfig +rendererConfig = SDL.RendererConfig + { SDL.rendererType = SDL.AcceleratedVSyncRenderer + , SDL.rendererTargetTexture = False + } + + +renderSurfaceToWindow :: (MonadIO m) => SDL.Window -> SDL.Surface -> SDL.Surface -> m () +renderSurfaceToWindow w s i + = SDL.surfaceBlit i Nothing s Nothing + >> SDL.updateWindowSurface w + + +isContinue :: Maybe SDL.Event -> Bool +isContinue = maybe True (not . isQuitEvent) + + +conditionallyRun :: (Monad m) => m a -> Bool -> m Bool +conditionallyRun f True = True <$ f +conditionallyRun _ False = pure False + + +isQuitEvent :: SDL.Event -> Bool +isQuitEvent (SDL.Event _t SDL.QuitEvent) = True +isQuitEvent _ = False + + +setHintQuality :: (MonadIO m) => m () +setHintQuality = SDL.HintRenderScaleQuality $= SDL.ScaleNearest + + +loadTextureWithInfo :: (MonadIO m) => SDL.Renderer -> FilePath -> m (SDL.Texture, SDL.TextureInfo) +loadTextureWithInfo r p = do + t <- SDL.Image.loadTexture r p + i <- SDL.queryTexture t + pure (t, i) + + +mkPoint :: a -> a -> SDL.Point SDL.V2 a +mkPoint x y = SDL.P (SDL.V2 x y) + + +mkRect :: a -> a -> a -> a-> SDL.Rectangle a +mkRect x y w h = SDL.Rectangle o z + where + o = SDL.P (SDL.V2 x y) + z = SDL.V2 w h diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs index b5df2239c..05a1473e1 100644 --- a/pkg/hair/lib/Vere/Log.hs +++ b/pkg/hair/lib/Vere/Log.hs @@ -1,11 +1,10 @@ module Vere.Log where import Database.LMDB.Raw -import ClassyPrelude hiding ((<|)) +import ClassyPrelude import Data.Void import Data.ByteString.Unsafe import GHC.Ptr (castPtr) -import Data.List.NonEmpty (NonEmpty(..), (<|)) -------------------------------------------------------------------------------- @@ -30,22 +29,26 @@ shutdown s = mdb_env_close (env s) -------------------------------------------------------------------------------- -readQueue :: TQueue a -> STM (NonEmpty a) +{- + Read one or more items from a TQueue, only blocking on the first item. +-} +readQueue :: TQueue a -> STM (NonNull [a]) readQueue q = readTQueue q >>= go . singleton where - go acc = tryReadTQueue q >>= \case - Nothing -> pure (reverse acc) - Just item -> go (item <| acc) + go acc = + tryReadTQueue q >>= \case + Nothing -> pure (reverse acc) + Just item -> go (item <| acc) byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a byteStringAsMdbVal bs k = unsafeUseAsCStringLen bs \(ptr,sz) -> k (MDB_val (fromIntegral sz) (castPtr ptr)) -put :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> ByteString - -> IO Bool -put flags txn db key val = +putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> ByteString + -> IO Bool +putRaw flags txn db key val = byteStringAsMdbVal key \mKey -> byteStringAsMdbVal val \mVal -> mdb_put flags txn db mKey mVal diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 8c2705d19..d0493b2e2 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -56,6 +56,8 @@ dependencies: - pretty-show - primitive - QuickCheck + - sdl2 + - sdl2-image - semigroups - smallcheck - stm From a37ac1041367cdd23d064e39a6edb7eed24b922e Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 29 May 2019 12:47:14 -0700 Subject: [PATCH 051/431] Isle colors. --- pkg/hair/lib/Vere/Isle.hs | 38 ++++++++++++++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/pkg/hair/lib/Vere/Isle.hs b/pkg/hair/lib/Vere/Isle.hs index 0fb25b228..3fc7143c4 100644 --- a/pkg/hair/lib/Vere/Isle.hs +++ b/pkg/hair/lib/Vere/Isle.hs @@ -1,14 +1,44 @@ module Vere.Isle where -import Prelude +import ClassyPrelude + import qualified Vere.Isle.Util as C -import qualified SDL +import qualified SDL as SDL + +import Data.Flat (Flat) -------------------------------------------------------------------------------- -{- +data Color + = Black | DarkGray + | Blue | LightBlue + | Green | LightGreen + | Cyan | LightCyan + | Red | LightRed + | Magenta | LightMagenta + | Brown | Yellow + | LightGray | White + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + deriving anyclass Flat --} +toRGB :: Color -> (Word8, Word8, Word8) +toRGB = \case + Black -> (0x00, 0x00, 0x00) + DarkGray -> (0x55, 0x55, 0x55) + Blue -> (0x00, 0x00, 0xAA) + LightBlue -> (0x55, 0x55, 0xFF) + Green -> (0x00, 0xAA, 0x00) + LightGreen -> (0x55, 0xFF, 0x55) + Cyan -> (0x00, 0xAA, 0xAA) + LightCyan -> (0x55, 0xFF, 0xFF) + Red -> (0xAA, 0x00, 0x00) + LightRed -> (0xFF, 0x55, 0x55) + Magenta -> (0xAA, 0x00, 0xAA) + LightMagenta -> (0xFF, 0x55, 0xFF) + Brown -> (0xAA, 0x55, 0x00) + Yellow -> (0xFF, 0xFF, 0x55) + LightGray -> (0xAA, 0xAA, 0xAA) + White -> (0xFF, 0xFF, 0xFF) -------------------------------------------------------------------------------- From 0509e9d45c449eb673cccf711a838852091c6c67 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Wed, 29 May 2019 16:19:07 -0700 Subject: [PATCH 052/431] Lots more code for lmdb. --- pkg/hair/lib/Vere/Log.hs | 140 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 136 insertions(+), 4 deletions(-) diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs index 05a1473e1..b9617657b 100644 --- a/pkg/hair/lib/Vere/Log.hs +++ b/pkg/hair/lib/Vere/Log.hs @@ -1,10 +1,22 @@ +-- TODO: Make sure transaction closed in all error cases module Vere.Log where -import Database.LMDB.Raw import ClassyPrelude +import Data.Noun +import Data.Noun.Atom +import Data.Noun.Jam +import Data.Noun.Pill import Data.Void -import Data.ByteString.Unsafe -import GHC.Ptr (castPtr) +import Database.LMDB.Raw +import Foreign.Ptr +import Foreign.Marshal.Alloc + +import Foreign.Storable (peek, poke, sizeOf) + +import qualified Data.ByteString.Unsafe as BU +import qualified Data.ByteString as B +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV -------------------------------------------------------------------------------- @@ -13,6 +25,12 @@ data State = State , q :: TQueue Void } +data LogIdentity = LogIdentity + { who :: Noun + , is_fake :: Noun + , life :: Noun + } + -------------------------------------------------------------------------------- init :: FilePath -> IO State @@ -43,12 +61,126 @@ readQueue q = byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a byteStringAsMdbVal bs k = - unsafeUseAsCStringLen bs \(ptr,sz) -> + BU.unsafeUseAsCStringLen bs \(ptr,sz) -> k (MDB_val (fromIntegral sz) (castPtr ptr)) +mdbValToAtom :: MDB_val -> IO Atom +mdbValToAtom (MDB_val sz ptr) = do + packAtom <$> BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) + +mdbValToNoun :: MDB_val -> IO Noun +mdbValToNoun (MDB_val sz ptr) = do + bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) + maybe (error "mdb bad cue") pure (cue (packAtom bs)) + putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> ByteString -> IO Bool putRaw flags txn db key val = byteStringAsMdbVal key \mKey -> byteStringAsMdbVal val \mVal -> mdb_put flags txn db mKey mVal + +put :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO () +put flags txn db bsKey val = + putRaw flags txn db bsKey bsVal >>= \case + True -> pure () + False -> error "mdb bad put" + where bsVal = nounToBs val + +get :: MDB_txn -> MDB_dbi -> ByteString -> IO Noun +get txn db key = + byteStringAsMdbVal key \mKey -> + mdb_get txn db mKey >>= maybe (error "mdb bad get") mdbValToNoun + +mdbValToWord64 :: MDB_val -> IO Word64 +mdbValToWord64 (MDB_val sz ptr) = do + assertErr (sz == 8) "wrong size in mdbValToWord64" + peek (castPtr ptr) + +-------------------------------------------------------------------------------- + +withWordPtr :: Word64 -> (Ptr Word64 -> IO a) -> IO a +withWordPtr w cb = do + allocaBytes (sizeOf w) (\p -> poke p w >> cb p) + +-- TODO: This will read len items and will error if there are less than that +-- available. This differs from the current pier.c's expectations. +readEvents :: MDB_env -> Word64 -> Word64 -> IO (V.Vector (Word64,Atom)) +readEvents env first len = + withWordPtr first $ \pIdx -> + withKVPtrs (MDB_val 64 (castPtr pIdx)) (MDB_val 0 nullPtr) $ \pKey pVal -> + do + txn <- mdb_txn_begin env Nothing True + db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] + cur <- mdb_cursor_open txn db + + found <- mdb_cursor_get MDB_SET_KEY cur pKey pVal + assertErr found "mdb could not read initial event of sequence" + + vec <- V.generateM (int len) \i -> do + key <- peek pKey >>= mdbValToWord64 + val <- peek pVal >>= mdbValToAtom + + let idx = first + (fromIntegral i) + + assertErr (key /= idx) "missing event in database" + + found <- mdb_cursor_get MDB_NEXT cur pKey pVal + assertErr found "lmdb: next event not found" + pure (idx, val) + + mdb_cursor_close cur + mdb_txn_abort txn + + pure vec + + +int :: Word64 -> Int +int = fromIntegral + +assertErr :: Bool -> String -> IO () +assertErr True _ = pure () +assertErr False m = error m + +latestEventNumber :: MDB_env -> IO Word64 +latestEventNumber env = + do + txn <- mdb_txn_begin env Nothing False + db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] + cur <- mdb_cursor_open txn db + res <- fetch txn db cur + mdb_cursor_close cur + mdb_txn_abort txn + pure res + where + key = MDB_val 0 nullPtr + val = MDB_val 0 nullPtr + fetch txn db cur = + withKVPtrs key val $ \pKey pVal -> + mdb_cursor_get MDB_LAST cur pKey pVal >>= \case + False -> pure 0 + True -> peek pKey >>= mdbValToWord64 + + +-------------------------------------------------------------------------------- + +writeLogIdentity :: MDB_env -> LogIdentity -> IO () +writeLogIdentity env LogIdentity{..} = do + txn <- mdb_txn_begin env Nothing False + db <- mdb_dbi_open txn (Just "META") [] + let flags = compileWriteFlags [] + put flags txn db "who" who + put flags txn db "is-fake" is_fake + put flags txn db "life" life + mdb_txn_commit txn + pure () + +readLogIdentity :: MDB_env -> IO LogIdentity +readLogIdentity env = do + txn <- mdb_txn_begin env Nothing True + db <- mdb_dbi_open txn (Just "META") [] + who <- get txn db "who" + is_fake <- get txn db "is-fake" + life <- get txn db "life" + mdb_txn_abort txn + pure (LogIdentity who is_fake life) From 80ffe5f8eca764b2f096194a6cb81a5d50844343 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Wed, 29 May 2019 16:43:51 -0700 Subject: [PATCH 053/431] Think about writeEvent? --- pkg/hair/lib/Vere/Log.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs index b9617657b..dbb3ca0f2 100644 --- a/pkg/hair/lib/Vere/Log.hs +++ b/pkg/hair/lib/Vere/Log.hs @@ -20,9 +20,12 @@ import qualified Data.Vector.Mutable as MV -------------------------------------------------------------------------------- +-- TODO: We are uncertain about q's type. There's some serious entanglement +-- with u3_pier in this logic in the C code, and you might not be able to get +-- away with anything less than passing the full u3_writ around. data State = State { env :: MDB_env - , q :: TQueue Void + , q :: TQueue (Word64,Atom,Noun) } data LogIdentity = LogIdentity @@ -103,6 +106,12 @@ withWordPtr :: Word64 -> (Ptr Word64 -> IO a) -> IO a withWordPtr w cb = do allocaBytes (sizeOf w) (\p -> poke p w >> cb p) + +writeEvent :: State -> Word64 -> Atom -> Noun -> IO () +writeEvent s id event effect = atomically $ + writeTQueue (q s) (id, event, effect) + + -- TODO: This will read len items and will error if there are less than that -- available. This differs from the current pier.c's expectations. readEvents :: MDB_env -> Word64 -> Word64 -> IO (V.Vector (Word64,Atom)) From 3514439fe1e26a4732ff2a33e778652c43ccaeb7 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Thu, 30 May 2019 13:19:26 -0700 Subject: [PATCH 054/431] We can read data from an lmdb event log. (And maybe write, but we didn't test that.) --- pkg/hair/lib/Vere/Log.hs | 153 ++++++++++++++++++------------ pkg/hair/lib/Vere/Pier.hs | 17 ++++ pkg/hair/lib/Vere/Pier/Types.hs | 45 +++++++++ pkg/hair/lib/Vere/TestReadPier.hs | 27 ++++++ pkg/hair/package.yaml | 1 + 5 files changed, 182 insertions(+), 61 deletions(-) create mode 100644 pkg/hair/lib/Vere/Pier.hs create mode 100644 pkg/hair/lib/Vere/Pier/Types.hs create mode 100644 pkg/hair/lib/Vere/TestReadPier.hs diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs index dbb3ca0f2..638cbf678 100644 --- a/pkg/hair/lib/Vere/Log.hs +++ b/pkg/hair/lib/Vere/Log.hs @@ -1,7 +1,16 @@ -- TODO: Make sure transaction closed in all error cases -module Vere.Log where +-- TODO: Don't allow writing non-contiguous events +module Vere.Log ( + init, + shutdown, + -- we don't export write; you use the queue + readEvents, + latestEventNumber, + readLogIdentity, + writeLogIdentity +) where -import ClassyPrelude +import ClassyPrelude hiding (init) import Data.Noun import Data.Noun.Atom import Data.Noun.Jam @@ -10,6 +19,7 @@ import Data.Void import Database.LMDB.Raw import Foreign.Ptr import Foreign.Marshal.Alloc +import Vere.Pier.Types import Foreign.Storable (peek, poke, sizeOf) @@ -20,33 +30,26 @@ import qualified Data.Vector.Mutable as MV -------------------------------------------------------------------------------- --- TODO: We are uncertain about q's type. There's some serious entanglement --- with u3_pier in this logic in the C code, and you might not be able to get --- away with anything less than passing the full u3_writ around. -data State = State - { env :: MDB_env - , q :: TQueue (Word64,Atom,Noun) - } - -data LogIdentity = LogIdentity - { who :: Noun - , is_fake :: Noun - , life :: Noun - } - --------------------------------------------------------------------------------- - -init :: FilePath -> IO State -init dir = do +-- TODO: Handle throws on the async +init :: FilePath -> TQueue (Writ [Effect]) -> (Writ [Effect] -> STM ()) + -> IO LogState +init dir inp cb = do env <- mdb_env_create mdb_env_set_maxdbs env 3 mdb_env_set_mapsize env (40 * 1024 * 1024 * 1024) mdb_env_open env dir [] - tq <- newTQueueIO - pure (State env tq) + writer <- persistThread env inp cb + pure (LogState env inp cb writer) -shutdown :: State -> IO () -shutdown s = mdb_env_close (env s) +-- TODO: properly handle shutdowns during write +shutdown :: LogState -> IO () +shutdown s = do + void $ waitCancel (writer s) + mdb_env_close (env s) + + +waitCancel :: Async a -> IO (Either SomeException a) +waitCancel async = cancel async >> waitCatch async -------------------------------------------------------------------------------- @@ -76,19 +79,23 @@ mdbValToNoun (MDB_val sz ptr) = do bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) maybe (error "mdb bad cue") pure (cue (packAtom bs)) -putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> ByteString - -> IO Bool +putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO () putRaw flags txn db key val = - byteStringAsMdbVal key \mKey -> - byteStringAsMdbVal val \mVal -> - mdb_put flags txn db mKey mVal - -put :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO () -put flags txn db bsKey val = - putRaw flags txn db bsKey bsVal >>= \case + mdb_put flags txn db key val >>= \case True -> pure () False -> error "mdb bad put" - where bsVal = nounToBs val + +putNoun :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO () +putNoun flags txn db key val = + byteStringAsMdbVal key $ \mKey -> + byteStringAsMdbVal (nounToBs val) $ \mVal -> + putRaw flags txn db mKey mVal + +putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO () +putJam flags txn db id (Jam atom) = + withWord64AsMDBval id $ \idVal -> + byteStringAsMdbVal (unpackAtom atom) $ \mVal -> + putRaw flags txn db idVal mVal get :: MDB_txn -> MDB_dbi -> ByteString -> IO Noun get txn db key = @@ -100,24 +107,48 @@ mdbValToWord64 (MDB_val sz ptr) = do assertErr (sz == 8) "wrong size in mdbValToWord64" peek (castPtr ptr) +withWord64AsMDBval :: Word64 -> (MDB_val -> IO a) -> IO a +withWord64AsMDBval w cb = do + withWordPtr w $ \p -> + cb (MDB_val (fromIntegral (sizeOf w)) (castPtr p)) + -------------------------------------------------------------------------------- withWordPtr :: Word64 -> (Ptr Word64 -> IO a) -> IO a withWordPtr w cb = do allocaBytes (sizeOf w) (\p -> poke p w >> cb p) +-- TODO: We need to be able to send back an exception to the main thread on an +-- exception on the persistence thread. +persistThread :: MDB_env + -> TQueue (Writ [Effect]) + -> (Writ [Effect] -> STM ()) + -> IO (Async ()) +persistThread env inputQueue onPersist = async $ + do + writs <- atomically $ readQueue inputQueue + writeEvents writs + atomically $ traverse_ onPersist writs + where + writeEvents writs = do + txn <- mdb_txn_begin env Nothing False + db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] -writeEvent :: State -> Word64 -> Atom -> Noun -> IO () -writeEvent s id event effect = atomically $ - writeTQueue (q s) (id, event, effect) + let flags = compileWriteFlags [MDB_NOOVERWRITE] + for_ writs $ \w -> + putJam flags txn db (eventId w) (event w) + + mdb_txn_commit txn + +deriving instance Show MDB_val -- TODO: This will read len items and will error if there are less than that -- available. This differs from the current pier.c's expectations. -readEvents :: MDB_env -> Word64 -> Word64 -> IO (V.Vector (Word64,Atom)) -readEvents env first len = +readEvents :: LogState -> Word64 -> Word64 -> IO (V.Vector (Word64,Atom)) +readEvents (LogState env _ _ _) first len = withWordPtr first $ \pIdx -> - withKVPtrs (MDB_val 64 (castPtr pIdx)) (MDB_val 0 nullPtr) $ \pKey pVal -> + withKVPtrs (MDB_val 8 (castPtr pIdx)) (MDB_val 0 nullPtr) $ \pKey pVal -> do txn <- mdb_txn_begin env Nothing True db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] @@ -132,10 +163,12 @@ readEvents env first len = let idx = first + (fromIntegral i) - assertErr (key /= idx) "missing event in database" + assertErr (key == idx) ("missing event in database " <> (show idx)) + + when (i + 1 /= (int len)) do + found <- mdb_cursor_get MDB_NEXT cur pKey pVal + assertErr found "lmdb: next event not found" - found <- mdb_cursor_get MDB_NEXT cur pKey pVal - assertErr found "lmdb: next event not found" pure (idx, val) mdb_cursor_close cur @@ -143,7 +176,6 @@ readEvents env first len = pure vec - int :: Word64 -> Int int = fromIntegral @@ -151,10 +183,10 @@ assertErr :: Bool -> String -> IO () assertErr True _ = pure () assertErr False m = error m -latestEventNumber :: MDB_env -> IO Word64 -latestEventNumber env = +latestEventNumber :: LogState -> IO Word64 +latestEventNumber (LogState env _ _ _) = do - txn <- mdb_txn_begin env Nothing False + txn <- mdb_txn_begin env Nothing True db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] cur <- mdb_cursor_open txn db res <- fetch txn db cur @@ -170,22 +202,10 @@ latestEventNumber env = False -> pure 0 True -> peek pKey >>= mdbValToWord64 - -------------------------------------------------------------------------------- -writeLogIdentity :: MDB_env -> LogIdentity -> IO () -writeLogIdentity env LogIdentity{..} = do - txn <- mdb_txn_begin env Nothing False - db <- mdb_dbi_open txn (Just "META") [] - let flags = compileWriteFlags [] - put flags txn db "who" who - put flags txn db "is-fake" is_fake - put flags txn db "life" life - mdb_txn_commit txn - pure () - -readLogIdentity :: MDB_env -> IO LogIdentity -readLogIdentity env = do +readLogIdentity :: LogState -> IO LogIdentity +readLogIdentity (LogState env _ _ _) = do txn <- mdb_txn_begin env Nothing True db <- mdb_dbi_open txn (Just "META") [] who <- get txn db "who" @@ -193,3 +213,14 @@ readLogIdentity env = do life <- get txn db "life" mdb_txn_abort txn pure (LogIdentity who is_fake life) + +writeLogIdentity :: LogState -> LogIdentity -> IO () +writeLogIdentity (LogState env _ _ _) LogIdentity{..} = do + txn <- mdb_txn_begin env Nothing False + db <- mdb_dbi_open txn (Just "META") [] + let flags = compileWriteFlags [] + putNoun flags txn db "who" who + putNoun flags txn db "is-fake" is_fake + putNoun flags txn db "life" life + mdb_txn_commit txn + pure () diff --git a/pkg/hair/lib/Vere/Pier.hs b/pkg/hair/lib/Vere/Pier.hs new file mode 100644 index 000000000..d86f544b7 --- /dev/null +++ b/pkg/hair/lib/Vere/Pier.hs @@ -0,0 +1,17 @@ +module Vere.Pier where + +import ClassyPrelude +import Vere.Pier.Types +import qualified Vere.Log as Log + +initPier :: FilePath -> IO Pier +initPier top = do + let logPath = top <> "/log" + + computeQueue <- newTQueueIO + persistQueue <- newTQueueIO + releaseQueue <- newTQueueIO + + logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) + + pure (Pier{..}) diff --git a/pkg/hair/lib/Vere/Pier/Types.hs b/pkg/hair/lib/Vere/Pier/Types.hs new file mode 100644 index 000000000..536cdcb81 --- /dev/null +++ b/pkg/hair/lib/Vere/Pier/Types.hs @@ -0,0 +1,45 @@ +module Vere.Pier.Types where + +import ClassyPrelude +import Data.Noun +import Data.Noun.Atom +import Database.LMDB.Raw +import Urbit.Time + +data Effect +data Ovum +newtype Mug = Mug Word32 + +newtype Jam = Jam Atom + +data Writ a = Writ + { eventId :: Word64 + , job :: (Wen, Ovum) -- (pair date ovum) + , timeout :: Maybe Word + , mug :: Mug + , event :: Jam -- mat + , payload :: a + } + +data Pier = Pier + { computeQueue :: TQueue (Writ Word) + , persistQueue :: TQueue (Writ [Effect]) + , releaseQueue :: TQueue (Writ [Effect]) + , logState :: LogState + } + +-- TODO: We are uncertain about q's type. There's some serious entanglement +-- with u3_pier in this logic in the C code, and you might not be able to get +-- away with anything less than passing the full u3_writ around. +data LogState = LogState + { env :: MDB_env + , inputQueue :: TQueue (Writ [Effect]) + , onPersist :: Writ [Effect] -> STM () + , writer :: Async () + } + +data LogIdentity = LogIdentity + { who :: Noun + , is_fake :: Noun + , life :: Noun + } deriving Show diff --git a/pkg/hair/lib/Vere/TestReadPier.hs b/pkg/hair/lib/Vere/TestReadPier.hs new file mode 100644 index 000000000..d29f8aa14 --- /dev/null +++ b/pkg/hair/lib/Vere/TestReadPier.hs @@ -0,0 +1,27 @@ +module Vere.TestReadPier where + +import ClassyPrelude +import Data.Noun.Jam +import qualified Vere.Log as Log + +main :: IO () +main = do + let logPath = "/Users/erg/src/urbit/zod/.urb/log/" + + -- junk + persistQueue <- newTQueueIO + releaseQueue <- newTQueueIO + logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) + + -- + log <- Log.readLogIdentity logState + print log + + -- + latestEvent <- Log.latestEventNumber logState + print latestEvent + + -- + events <- Log.readEvents logState 1000 1 + print $ cue . snd <$> events + diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index d0493b2e2..64f98297a 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -102,6 +102,7 @@ default-extensions: - Rank2Types - RankNTypes - RecordWildCards + - StandaloneDeriving - ScopedTypeVariables - TemplateHaskell - TupleSections From 96b652b4fbb39f4f35ef48fceb1d32c5de59932b Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Thu, 30 May 2019 14:24:14 -0700 Subject: [PATCH 055/431] We can write small events, but we can't write large ones because unpackAtom --- pkg/hair/app/test/Main.hs | 44 +++++++++++++++++++++++++++++++ pkg/hair/lib/Data/Noun/Pill.hs | 2 +- pkg/hair/lib/Vere/Log.hs | 16 ++++++----- pkg/hair/lib/Vere/Pier/Types.hs | 2 -- pkg/hair/lib/Vere/TestReadPier.hs | 27 ------------------- pkg/hair/package.yaml | 11 ++++++++ 6 files changed, 65 insertions(+), 37 deletions(-) create mode 100644 pkg/hair/app/test/Main.hs delete mode 100644 pkg/hair/lib/Vere/TestReadPier.hs diff --git a/pkg/hair/app/test/Main.hs b/pkg/hair/app/test/Main.hs new file mode 100644 index 000000000..743674035 --- /dev/null +++ b/pkg/hair/app/test/Main.hs @@ -0,0 +1,44 @@ +module Main where + +import ClassyPrelude +import Vere.Pier.Types +import Data.Noun.Jam hiding (main) +import qualified Vere.Log as Log + +main :: IO () +main = do + let logPath = "/Users/erg/src/urbit/zod/.urb/log/" + falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog/" + + -- junk + persistQueue <- newTQueueIO + releaseQueue <- newTQueueIO + logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) + + -- + log <- Log.readLogIdentity logState + print log + + -- + latestEvent <- Log.latestEventNumber logState + print latestEvent + + -- + events <- Log.readEvents logState 30 3000 + --print $ cue . snd <$> events + + -- + persistQueue2 <- newTQueueIO + releaseQueue2 <- newTQueueIO + falseLogState <- Log.init falselogPath persistQueue2 (writeTQueue releaseQueue2) + + let writs = events <&> \(id, a) -> + Writ id Nothing (Jam a) [] + + print "About to write" + for_ writs $ \w -> atomically $ writeTQueue persistQueue2 w + + print "About to wait" + + replicateM_ 100 $ atomically $ readTQueue releaseQueue2 + print "Done" diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs index 14bf656d9..078239e69 100644 --- a/pkg/hair/lib/Data/Noun/Pill.hs +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -153,7 +153,7 @@ packAtom :: ByteString -> Atom packAtom = MkAtom . wordsToNatural . bytesToWords . stripTrailingZeros unpackAtom :: Atom -> ByteString -unpackAtom (MkAtom a) = wordsToBytes (naturalToWords a) +unpackAtom (MkAtom a) = trace "unpack" $! wordsToBytes (naturalToWords a) -------------------------------------------------------------------------------- diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs index 638cbf678..b5f12c40b 100644 --- a/pkg/hair/lib/Vere/Log.hs +++ b/pkg/hair/lib/Vere/Log.hs @@ -92,10 +92,12 @@ putNoun flags txn db key val = putRaw flags txn db mKey mVal putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO () -putJam flags txn db id (Jam atom) = - withWord64AsMDBval id $ \idVal -> - byteStringAsMdbVal (unpackAtom atom) $ \mVal -> - putRaw flags txn db idVal mVal +putJam flags txn db id (Jam atom) = do + withWord64AsMDBval id $ \idVal -> do + -- TODO: This unpackAtom hangs. + let !bs = unpackAtom atom + byteStringAsMdbVal bs $ \mVal -> do + putRaw flags txn db idVal mVal get :: MDB_txn -> MDB_dbi -> ByteString -> IO Noun get txn db key = @@ -124,8 +126,8 @@ persistThread :: MDB_env -> TQueue (Writ [Effect]) -> (Writ [Effect] -> STM ()) -> IO (Async ()) -persistThread env inputQueue onPersist = async $ - do +persistThread env inputQueue onPersist = asyncBound $ + forever do writs <- atomically $ readQueue inputQueue writeEvents writs atomically $ traverse_ onPersist writs @@ -136,7 +138,7 @@ persistThread env inputQueue onPersist = async $ let flags = compileWriteFlags [MDB_NOOVERWRITE] - for_ writs $ \w -> + for_ writs $ \w -> do putJam flags txn db (eventId w) (event w) mdb_txn_commit txn diff --git a/pkg/hair/lib/Vere/Pier/Types.hs b/pkg/hair/lib/Vere/Pier/Types.hs index 536cdcb81..6e86e3b43 100644 --- a/pkg/hair/lib/Vere/Pier/Types.hs +++ b/pkg/hair/lib/Vere/Pier/Types.hs @@ -14,9 +14,7 @@ newtype Jam = Jam Atom data Writ a = Writ { eventId :: Word64 - , job :: (Wen, Ovum) -- (pair date ovum) , timeout :: Maybe Word - , mug :: Mug , event :: Jam -- mat , payload :: a } diff --git a/pkg/hair/lib/Vere/TestReadPier.hs b/pkg/hair/lib/Vere/TestReadPier.hs deleted file mode 100644 index d29f8aa14..000000000 --- a/pkg/hair/lib/Vere/TestReadPier.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Vere.TestReadPier where - -import ClassyPrelude -import Data.Noun.Jam -import qualified Vere.Log as Log - -main :: IO () -main = do - let logPath = "/Users/erg/src/urbit/zod/.urb/log/" - - -- junk - persistQueue <- newTQueueIO - releaseQueue <- newTQueueIO - logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) - - -- - log <- Log.readLogIdentity logState - print log - - -- - latestEvent <- Log.latestEventNumber logState - print latestEvent - - -- - events <- Log.readEvents logState 1000 1 - print $ cue . snd <$> events - diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index 64f98297a..f1ec4d871 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -9,6 +9,17 @@ library: - -O2 executables: + test: + main: Main.hs + source-dirs: app/test + dependencies: ["vere"] + ghc-options: + - -threaded + - -rtsopts + - "-with-rtsopts=-H128m" + - -fwarn-incomplete-patterns + - -O2 + uterm: main: Main.hs source-dirs: app/uterm From 73b93e90cbe43574565585969bdfd06134fbb638 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 30 May 2019 15:48:22 -0700 Subject: [PATCH 056/431] Optimized (and some cleanup of) pill creation. --- pkg/hair/lib/Data/Noun/Atom.hs | 2 +- pkg/hair/lib/Data/Noun/Pill.hs | 138 +++++++++++++++++++++++---------- 2 files changed, 96 insertions(+), 44 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hair/lib/Data/Noun/Atom.hs index d73067d9b..1ac03a1c4 100644 --- a/pkg/hair/lib/Data/Noun/Atom.hs +++ b/pkg/hair/lib/Data/Noun/Atom.hs @@ -18,7 +18,7 @@ import Data.Flat -------------------------------------------------------------------------------- -newtype Atom = MkAtom Natural +newtype Atom = MkAtom { unAtom :: Natural } deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral, Flat) instance Show Atom where diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs index 078239e69..153c9808d 100644 --- a/pkg/hair/lib/Data/Noun/Pill.hs +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -25,7 +25,7 @@ import ClassyPrelude import Data.Noun hiding (toList, fromList) import Data.Noun.Atom import Data.Noun.Jam hiding (main) -import Data.Flat +import Data.Flat hiding (from) import Control.Monad.Except import Control.Lens hiding (index, Index) import Data.Either.Extra (mapLeft) @@ -35,12 +35,15 @@ import GHC.Integer.GMP.Internals import GHC.Int import GHC.Word import GHC.Exts (sizeofByteArray#) +import System.IO.Unsafe (unsafePerformIO) import qualified Data.Vector as V +import qualified Data.Primitive.Types as Prim import qualified Data.Primitive.ByteArray as Prim import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Unboxed as VU import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BU import Test.Tasty import Test.Tasty.TH @@ -49,17 +52,35 @@ import Test.QuickCheck -------------------------------------------------------------------------------- -stripTrailingZeros :: IsSequence seq - => Int ~ Index seq - => (Eq (Element seq), Num (Element seq)) - => seq -> seq -stripTrailingZeros buf = take (len - go 0 (len - 1)) buf +{- + A `Pill` is a bytestring without trailing zeros. +-} +newtype Pill = Pill { unPill :: ByteString } + +strip :: (IsSequence seq, Int ~ Index seq, Eq (Element seq), Num (Element seq)) + => seq -> seq +strip buf = take (len - go 0 (len - 1)) buf where len = length buf go n i | i < 0 = n | 0 == unsafeIndex buf i = go (n+1) (i-1) | otherwise = n +pillBytes :: Iso' Pill ByteString +pillBytes = iso to from + where + to :: Pill -> ByteString + to = strip . unPill + + from :: ByteString -> Pill + from = Pill . strip + +instance Eq Pill where + (==) x y = (x ^. pillBytes) == (y ^. pillBytes) + +instance Show Pill where + show = show . view pillBytes + -------------------------------------------------------------------------------- wordsToBigNat :: VP.Vector Word -> BigNat @@ -130,47 +151,72 @@ unpackWord wor = reverse $ fromList $ go 0 [] -------------------------------------------------------------------------------- -bytesToWords :: ByteString -> VP.Vector Word -bytesToWords bytes = +wordsToBytes :: VP.Vector Word -> VP.Vector Word8 +wordsToBytes (VP.Vector off sz buf) = VP.Vector (off*8) (sz*8) buf + +byteStrToWords :: ByteString -> VP.Vector Word +byteStrToWords bytes = VP.generate (1 + length bytes `div` 8) $ \i -> packWord (BS.drop (i*8) bytes) -fromPrimVec :: Prim a => VP.Vector a -> V.Vector a -fromPrimVec vp = V.generate (VP.length vp) (VP.unsafeIndex vp) +-- TODO Support Big-Endian +bytesBS :: Iso' (VP.Vector Word8) ByteString +bytesBS = iso to from + where + to :: VP.Vector Word8 -> ByteString + to (VP.Vector off sz buf) = + BS.copy $ BS.drop off $ unsafePerformIO $ BU.unsafePackAddressLen sz ptr + where + Prim.Addr ptr = Prim.byteArrayContents buf -wordsToBytes :: VP.Vector Word -> ByteString -wordsToBytes = stripTrailingZeros . concat . fmap unpackWord . fromPrimVec + from :: ByteString -> VP.Vector Word8 + from bs = VP.generate (length bs) (BS.index bs) + +pillWords :: Iso' Pill (VP.Vector Word) +pillWords = iso to from + where + to = byteStrToWords . view pillBytes + from = Pill . view bytesBS . wordsToBytes -------------------------------------------------------------------------------- -dumbPackAtom :: ByteString -> Atom -dumbPackAtom bs = go 0 0 (toList bs) +{- + This is a stupid, but obviously correct version of `packAtom`. +-} +dumbPackAtom :: Pill -> Atom +dumbPackAtom = go 0 0 . toList . view pillBytes where go acc i [] = acc go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs -packAtom :: ByteString -> Atom -packAtom = MkAtom . wordsToNatural . bytesToWords . stripTrailingZeros +packAtom :: Pill -> Atom +packAtom = MkAtom . wordsToNatural . byteStrToWords . view pillBytes -unpackAtom :: Atom -> ByteString -unpackAtom (MkAtom a) = trace "unpack" $! wordsToBytes (naturalToWords a) +unpackAtom :: Atom -> Pill +unpackAtom = view (from pillWords) . naturalToWords . unAtom -------------------------------------------------------------------------------- -bsToNoun :: ByteString -> Maybe Noun -bsToNoun = cue . packAtom +readPill :: FilePath -> IO Pill +readPill = fmap Pill . readFile -nounToBs :: Noun -> ByteString -nounToBs = unpackAtom . jam +writePill :: FilePath -> Pill -> IO () +writePill fp = writeFile fp . view pillBytes + +pillToNoun :: Pill -> Maybe Noun +pillToNoun = cue . packAtom + +nounToPill :: Noun -> Pill +nounToPill = unpackAtom . jam loadFile :: FilePath -> IO Atom -loadFile = fmap packAtom . readFile +loadFile = fmap packAtom . readPill loadJam :: FilePath -> IO (Maybe Noun) loadJam = fmap cue . loadFile dumpJam :: FilePath -> Noun -> IO () -dumpJam pat = writeFile pat . unpackAtom . jam +dumpJam pat = writePill pat . unpackAtom . jam dumpFlat :: Flat a => FilePath -> a -> IO () dumpFlat pat = writeFile pat . flat @@ -180,23 +226,29 @@ loadFlat pat = do bs <- readFile pat pure $ mapLeft tshow $ unflat bs -data Pill = Brass | Ivory | Solid +data PillFile = Brass | Ivory | Solid -instance Show Pill where +instance Show PillFile where show = \case Brass -> "./bin/brass.pill" Solid -> "./bin/solid.pill" Ivory -> "./bin/ivory.pill" -tryLoadPill :: Pill -> IO () +tryLoadPill :: PillFile -> IO Atom tryLoadPill pill = do a@(MkAtom nat) <- loadFile (show pill) putStrLn "loaded" print (a > 0) putStrLn "evaled" print (take 10 $ VP.toList $ naturalToWords nat) + pure a -tryCuePill :: Pill -> IO () +tryPackPill :: PillFile -> IO () +tryPackPill pf = do + atm <- tryLoadPill pf + print $ length $ unPill $ unpackAtom atm + +tryCuePill :: PillFile -> IO () tryCuePill pill = loadJam (show pill) >>= \case Nothing -> print "nil" Just (Atom _) -> print "atom" @@ -207,12 +259,18 @@ tryCuePill pill = instance Arbitrary ByteString where arbitrary = fromList <$> arbitrary +instance Arbitrary Pill where + arbitrary = Pill <$> arbitrary + instance Arbitrary BigNat where arbitrary = naturalToBigNat <$> arbitrary instance Show BigNat where show = show . NatJ# +testIso :: Eq a => Iso' a b -> a -> Bool +testIso iso x = x == (x ^. iso . from iso) + roundTrip :: Eq a => (a -> b) -> (b -> a) -> (a -> Bool) roundTrip dump load x = x == load (dump x) @@ -222,31 +280,25 @@ equiv f g x = f x == g x check :: Atom -> Atom check = toAtom . (id :: Integer -> Integer) . fromAtom -clean :: IsSequence seq - => Int ~ Index seq - => (Eq (Element seq), Num (Element seq)) - => seq -> seq -clean = stripTrailingZeros - prop_packWordSane = equiv packWord dumbPackWord . fromList prop_packWord = roundTrip unpackWord packWord -prop_unpackWord = roundTrip packWord (clean . unpackWord) . clean . take 8 +prop_unpackWord = roundTrip packWord (strip . unpackWord) . strip . take 8 prop_unpackBigNat = roundTrip bigNatToWords wordsToBigNat prop_packBigNat = roundTrip (wordsToBigNat . VP.fromList) - (clean . VP.toList . bigNatToWords) - . clean + (strip . VP.toList . bigNatToWords) + . strip -prop_implodeBytes = roundTrip bytesToWords wordsToBytes . clean +prop_implodeBytes = roundTrip (view pillWords) (view (from pillWords)) -prop_explodeBytes = roundTrip (wordsToBytes . VP.fromList) - (clean . VP.toList . bytesToWords) - . clean +prop_explodeBytes = roundTrip (view (from pillWords) . VP.fromList) + (strip . VP.toList . view pillWords) + . strip -prop_packAtomSane = equiv packAtom dumbPackAtom . fromList +prop_packAtomSane = equiv packAtom dumbPackAtom . Pill . fromList prop_unpackAtom = roundTrip unpackAtom packAtom -prop_packAtom = roundTrip packAtom unpackAtom . clean +prop_packAtom = roundTrip packAtom unpackAtom . Pill . strip -------------------------------------------------------------------------------- From 2727ae74d055fa655371c9b533429b47cf2c0749 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Thu, 30 May 2019 16:04:06 -0700 Subject: [PATCH 057/431] Completed event log code. We can write the log entirely. --- pkg/hair/app/test/Main.hs | 12 +++++++----- pkg/hair/lib/Data/Noun/Pill.hs | 3 +++ pkg/hair/lib/Vere/Http/Server.hs | 4 ++-- pkg/hair/lib/Vere/Log.hs | 9 ++++----- 4 files changed, 16 insertions(+), 12 deletions(-) diff --git a/pkg/hair/app/test/Main.hs b/pkg/hair/app/test/Main.hs index 743674035..645674b1f 100644 --- a/pkg/hair/app/test/Main.hs +++ b/pkg/hair/app/test/Main.hs @@ -7,8 +7,8 @@ import qualified Vere.Log as Log main :: IO () main = do - let logPath = "/Users/erg/src/urbit/zod/.urb/log/" - falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog/" + let logPath = "/Users/erg/src/urbit/zod/.urb/falselog/" + falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog2/" -- junk persistQueue <- newTQueueIO @@ -16,15 +16,15 @@ main = do logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) -- - log <- Log.readLogIdentity logState - print log + logId <- Log.readLogIdentity logState + print logId -- latestEvent <- Log.latestEventNumber logState print latestEvent -- - events <- Log.readEvents logState 30 3000 + events <- Log.readEvents logState 1 3142 --print $ cue . snd <$> events -- @@ -32,6 +32,8 @@ main = do releaseQueue2 <- newTQueueIO falseLogState <- Log.init falselogPath persistQueue2 (writeTQueue releaseQueue2) + Log.writeLogIdentity falseLogState logId + let writs = events <&> \(id, a) -> Writ id Nothing (Jam a) [] diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs index 153c9808d..77343ae9d 100644 --- a/pkg/hair/lib/Data/Noun/Pill.hs +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -209,6 +209,9 @@ pillToNoun = cue . packAtom nounToPill :: Noun -> Pill nounToPill = unpackAtom . jam +nounToBs :: Noun -> ByteString +nounToBs = unPill . nounToPill + loadFile :: FilePath -> IO Atom loadFile = fmap packAtom . readPill diff --git a/pkg/hair/lib/Vere/Http/Server.hs b/pkg/hair/lib/Vere/Http/Server.hs index f3f37806b..a81d52eb0 100644 --- a/pkg/hair/lib/Vere/Http/Server.hs +++ b/pkg/hair/lib/Vere/Http/Server.hs @@ -7,7 +7,7 @@ import Vere.Http import Control.Concurrent (ThreadId, killThread, forkIO) import Data.Noun.Atom -import Data.Noun.Pill (packAtom) +import Data.Noun.Pill (packAtom, Pill(..)) import qualified Network.HTTP.Types as H import qualified Network.Wai as W import qualified Network.Wai.Handler.Warp as W @@ -100,7 +100,7 @@ cookMeth re = data Octs = Octs Atom Atom bsToOcts :: ByteString -> Octs -bsToOcts bs = Octs (fromIntegral (length bs)) (packAtom bs) +bsToOcts bs = Octs (fromIntegral (length bs)) (packAtom (Pill bs)) readEvents :: W.Request -> IO Request readEvents request = do diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs index b5f12c40b..789762b5c 100644 --- a/pkg/hair/lib/Vere/Log.hs +++ b/pkg/hair/lib/Vere/Log.hs @@ -72,12 +72,12 @@ byteStringAsMdbVal bs k = mdbValToAtom :: MDB_val -> IO Atom mdbValToAtom (MDB_val sz ptr) = do - packAtom <$> BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) + packAtom . Pill <$> BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) mdbValToNoun :: MDB_val -> IO Noun mdbValToNoun (MDB_val sz ptr) = do bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) - maybe (error "mdb bad cue") pure (cue (packAtom bs)) + maybe (error "mdb bad cue") pure (cue (packAtom (Pill bs))) putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO () putRaw flags txn db key val = @@ -94,8 +94,7 @@ putNoun flags txn db key val = putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO () putJam flags txn db id (Jam atom) = do withWord64AsMDBval id $ \idVal -> do - -- TODO: This unpackAtom hangs. - let !bs = unpackAtom atom + let !bs = unPill (unpackAtom atom) byteStringAsMdbVal bs $ \mVal -> do putRaw flags txn db idVal mVal @@ -219,7 +218,7 @@ readLogIdentity (LogState env _ _ _) = do writeLogIdentity :: LogState -> LogIdentity -> IO () writeLogIdentity (LogState env _ _ _) LogIdentity{..} = do txn <- mdb_txn_begin env Nothing False - db <- mdb_dbi_open txn (Just "META") [] + db <- mdb_dbi_open txn (Just "META") [MDB_CREATE] let flags = compileWriteFlags [] putNoun flags txn db "who" who putNoun flags txn db "is-fake" is_fake From d6905191ed6d73aabfa6fdc0c7a85c2491b80d06 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 30 May 2019 19:53:00 -0700 Subject: [PATCH 058/431] Use Iso's in Data.Noun.Pill --- pkg/hair/lib/Data/Noun/Pill.hs | 238 ++++++++++++++++--------------- pkg/hair/lib/Vere/Http/Server.hs | 27 +++- pkg/hair/lib/Vere/Log.hs | 26 ++-- 3 files changed, 163 insertions(+), 128 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hair/lib/Data/Noun/Pill.hs index 77343ae9d..20e4dd77b 100644 --- a/pkg/hair/lib/Data/Noun/Pill.hs +++ b/pkg/hair/lib/Data/Noun/Pill.hs @@ -2,6 +2,7 @@ {- TODO Handle 32-bit architectures + TODO Handle big-endian. TODO A faster version of this is possible: - Get the byte-length of a file. @@ -25,7 +26,7 @@ import ClassyPrelude import Data.Noun hiding (toList, fromList) import Data.Noun.Atom import Data.Noun.Jam hiding (main) -import Data.Flat hiding (from) +import Data.Flat hiding (from, to) import Control.Monad.Except import Control.Lens hiding (index, Index) import Data.Either.Extra (mapLeft) @@ -57,6 +58,14 @@ import Test.QuickCheck -} newtype Pill = Pill { unPill :: ByteString } +instance Eq Pill where + (==) x y = (x ^. pillBS) == (y ^. pillBS) + +instance Show Pill where + show = show . view pillBS + +-------------------------------------------------------------------------------- + strip :: (IsSequence seq, Int ~ Index seq, Eq (Element seq), Num (Element seq)) => seq -> seq strip buf = take (len - go 0 (len - 1)) buf @@ -66,8 +75,8 @@ strip buf = take (len - go 0 (len - 1)) buf | 0 == unsafeIndex buf i = go (n+1) (i-1) | otherwise = n -pillBytes :: Iso' Pill ByteString -pillBytes = iso to from +pillBS :: Iso' Pill ByteString +pillBS = iso to from where to :: Pill -> ByteString to = strip . unPill @@ -75,54 +84,38 @@ pillBytes = iso to from from :: ByteString -> Pill from = Pill . strip -instance Eq Pill where - (==) x y = (x ^. pillBytes) == (y ^. pillBytes) +-------------------------------------------------------------------------------- -instance Show Pill where - show = show . view pillBytes +bigNatWords :: Iso' BigNat (VP.Vector Word) +bigNatWords = iso to from + where + to (BN# bArr) = VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8) + (Prim.ByteArray bArr) + + from v@(VP.Vector off (I# len) (Prim.ByteArray buf)) = + case VP.length v of + 0 -> zeroBigNat + 1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w) + n -> if off /= 0 then error "words2Nat: bad-vec" else + byteArrayToBigNat# buf len -------------------------------------------------------------------------------- -wordsToBigNat :: VP.Vector Word -> BigNat -wordsToBigNat v@(VP.Vector off (I# len) (Prim.ByteArray buf)) = - case VP.length v of - 0 -> zeroBigNat - 1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w) - n -> if off /= 0 then error "words2Nat: bad-vec" else - byteArrayToBigNat# buf len +bigNatBits :: Iso' BigNat (VU.Vector Bool) +bigNatBits = undefined -bigNatToWords :: BigNat -> VP.Vector Word -bigNatToWords (BN# bArr) = VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8) - $ Prim.ByteArray bArr +natWords :: Iso' Natural (VP.Vector Word) +natWords = naturalBigNat . bigNatWords --------------------------------------------------------------------------------- +naturalBigNat :: Iso' Natural BigNat +naturalBigNat = iso to from + where + to = \case NatS# w -> wordToBigNat w + NatJ# bn -> bn -bigNatToBits :: BigNat -> VU.Vector Bool -bigNatToBits = undefined - -bitsToBigNat :: BigNat -> VU.Vector Bool -bitsToBigNat = undefined - --------------------------------------------------------------------------------- - -naturalToBigNat :: Natural -> BigNat -naturalToBigNat (NatS# w) = wordToBigNat w -naturalToBigNat (NatJ# bn) = bn - -bigNatToNatural :: BigNat -> Natural -bigNatToNatural bn = - case sizeofBigNat# bn of - 0# -> 0 - 1# -> NatS# (bigNatToWord bn) - _ -> NatJ# bn - --------------------------------------------------------------------------------- - -wordsToNatural :: VP.Vector Word -> Natural -wordsToNatural = bigNatToNatural . wordsToBigNat - -naturalToWords :: Natural -> VP.Vector Word -naturalToWords = bigNatToWords . naturalToBigNat + from bn = case sizeofBigNat# bn of 0# -> 0 + 1# -> NatS# (bigNatToWord bn) + _ -> NatJ# bn -------------------------------------------------------------------------------- @@ -133,31 +126,31 @@ dumbPackWord bs = go 0 0 (toList bs) go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs -- TODO This assumes 64-bit words -packWord :: ByteString -> Word -packWord buf = go 0 0 - where - top = min 8 (length buf) - i idx off = shiftL (fromIntegral $ BS.index buf idx) off - go acc idx = if idx >= top then acc else - go (acc .|. i idx (8*idx)) (idx+1) +packedWord :: Iso' ByteString Word +packedWord = iso to from + where + from wor = reverse $ fromList $ go 0 [] + where + go i acc | i >= 8 = acc + go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc) - --- TODO This assumes 64-bit words -unpackWord :: Word -> ByteString -unpackWord wor = reverse $ fromList $ go 0 [] - where - go i acc | i >= 8 = acc - go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc) + to buf = go 0 0 + where + top = min 8 (length buf) + i idx off = shiftL (fromIntegral $ BS.index buf idx) off + go acc idx = if idx >= top then acc else + go (acc .|. i idx (8*idx)) (idx+1) -------------------------------------------------------------------------------- wordsToBytes :: VP.Vector Word -> VP.Vector Word8 -wordsToBytes (VP.Vector off sz buf) = VP.Vector (off*8) (sz*8) buf +wordsToBytes (VP.Vector off sz buf) = + VP.Vector (off*8) (sz*8) buf -byteStrToWords :: ByteString -> VP.Vector Word -byteStrToWords bytes = - VP.generate (1 + length bytes `div` 8) $ \i -> - packWord (BS.drop (i*8) bytes) +bsToWords :: ByteString -> VP.Vector Word +bsToWords bs = + VP.generate (1 + length bs `div` 8) $ \i -> + view packedWord (BS.drop (i*8) bs) -- TODO Support Big-Endian bytesBS :: Iso' (VP.Vector Word8) ByteString @@ -173,61 +166,75 @@ bytesBS = iso to from from bs = VP.generate (length bs) (BS.index bs) pillWords :: Iso' Pill (VP.Vector Word) -pillWords = iso to from +pillWords = iso toVec fromVec where - to = byteStrToWords . view pillBytes - from = Pill . view bytesBS . wordsToBytes + toVec = view (pillBS . to bsToWords) + fromVec = view (to wordsToBytes . bytesBS . from pillBS) + +_CueBytes :: Prism' ByteString Noun +_CueBytes = from pillBS . from pill . _Cue -------------------------------------------------------------------------------- {- - This is a stupid, but obviously correct version of `packAtom`. + This is a stupid, but obviously correct version of `view (from pill)`. -} dumbPackAtom :: Pill -> Atom -dumbPackAtom = go 0 0 . toList . view pillBytes +dumbPackAtom = go 0 0 . toList . view pillBS where go acc i [] = acc go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs -packAtom :: Pill -> Atom -packAtom = MkAtom . wordsToNatural . byteStrToWords . view pillBytes +atomNat :: Iso' Atom Natural +atomNat = iso unAtom MkAtom -unpackAtom :: Atom -> Pill -unpackAtom = view (from pillWords) . naturalToWords . unAtom +pill :: Iso' Atom Pill +pill = iso toAtom fromPill + where + toAtom = view (atomNat . natWords . from pillWords) + fromPill = view (pillBS . to bsToWords . from natWords . from atomNat) -------------------------------------------------------------------------------- -readPill :: FilePath -> IO Pill -readPill = fmap Pill . readFile +_Cue :: Prism' Atom Noun +_Cue = prism' jam cue -writePill :: FilePath -> Pill -> IO () -writePill fp = writeFile fp . view pillBytes +_Tall :: Flat a => Prism' ByteString a +_Tall = prism' flat (eitherToMaybe . unflat) + where + eitherToMaybe :: Either a b -> Maybe b + eitherToMaybe (Left x) = Nothing + eitherToMaybe (Right x) = Just x -pillToNoun :: Pill -> Maybe Noun -pillToNoun = cue . packAtom +-------------------------------------------------------------------------------- -nounToPill :: Noun -> Pill -nounToPill = unpackAtom . jam +loadPill :: FilePath -> IO Pill +loadPill = fmap Pill . readFile -nounToBs :: Noun -> ByteString -nounToBs = unPill . nounToPill +loadAtom :: FilePath -> IO Atom +loadAtom = fmap (view $ from pillBS . from pill) . readFile -loadFile :: FilePath -> IO Atom -loadFile = fmap packAtom . readPill - -loadJam :: FilePath -> IO (Maybe Noun) -loadJam = fmap cue . loadFile - -dumpJam :: FilePath -> Noun -> IO () -dumpJam pat = writePill pat . unpackAtom . jam - -dumpFlat :: Flat a => FilePath -> a -> IO () -dumpFlat pat = writeFile pat . flat +loadNoun :: FilePath -> IO (Maybe Noun) +loadNoun = fmap (preview $ from pillBS . from pill . _Cue) . readFile loadFlat :: Flat a => FilePath -> IO (Either Text a) -loadFlat pat = do - bs <- readFile pat - pure $ mapLeft tshow $ unflat bs +loadFlat = fmap (mapLeft tshow . unflat) . readFile + +-------------------------------------------------------------------------------- + +dumpPill :: FilePath -> Pill -> IO () +dumpPill fp = writeFile fp . view pillBS + +dumpAtom :: FilePath -> Atom -> IO () +dumpAtom fp = writeFile fp . view (pill . pillBS) + +dumpJam :: FilePath -> Noun -> IO () +dumpJam fp = writeFile fp . view (re _Cue . pill . pillBS) + +dumpFlat :: Flat a => FilePath -> a -> IO () +dumpFlat fp = writeFile fp . flat + +-------------------------------------------------------------------------------- data PillFile = Brass | Ivory | Solid @@ -239,23 +246,23 @@ instance Show PillFile where tryLoadPill :: PillFile -> IO Atom tryLoadPill pill = do - a@(MkAtom nat) <- loadFile (show pill) + a@(MkAtom nat) <- loadAtom (show pill) putStrLn "loaded" print (a > 0) putStrLn "evaled" - print (take 10 $ VP.toList $ naturalToWords nat) + print (take 10 $ VP.toList $ nat ^. natWords) pure a tryPackPill :: PillFile -> IO () tryPackPill pf = do atm <- tryLoadPill pf - print $ length $ unPill $ unpackAtom atm + print $ length (atm ^. pill . pillBS) tryCuePill :: PillFile -> IO () tryCuePill pill = - loadJam (show pill) >>= \case Nothing -> print "nil" - Just (Atom _) -> print "atom" - _ -> print "cell" + loadNoun (show pill) >>= \case Nothing -> print "nil" + Just (Atom _) -> print "atom" + _ -> print "cell" -- Tests ----------------------------------------------------------------------- @@ -266,11 +273,13 @@ instance Arbitrary Pill where arbitrary = Pill <$> arbitrary instance Arbitrary BigNat where - arbitrary = naturalToBigNat <$> arbitrary + arbitrary = view naturalBigNat <$> arbitrary instance Show BigNat where show = show . NatJ# +-------------------------------------------------------------------------------- + testIso :: Eq a => Iso' a b -> a -> Bool testIso iso x = x == (x ^. iso . from iso) @@ -283,14 +292,19 @@ equiv f g x = f x == g x check :: Atom -> Atom check = toAtom . (id :: Integer -> Integer) . fromAtom -prop_packWordSane = equiv packWord dumbPackWord . fromList -prop_packWord = roundTrip unpackWord packWord -prop_unpackWord = roundTrip packWord (strip . unpackWord) . strip . take 8 +-------------------------------------------------------------------------------- -prop_unpackBigNat = roundTrip bigNatToWords wordsToBigNat +prop_packWordSane = equiv (view packedWord) dumbPackWord . fromList +prop_packWord = testIso (from packedWord) +prop_unpackWord = roundTrip (view packedWord) + (strip . view (from packedWord)) + . strip + . take 8 -prop_packBigNat = roundTrip (wordsToBigNat . VP.fromList) - (strip . VP.toList . bigNatToWords) +prop_unpackBigNat = testIso bigNatWords + +prop_packBigNat = roundTrip (view (from bigNatWords) . VP.fromList) + (strip . VP.toList . view bigNatWords) . strip prop_implodeBytes = roundTrip (view pillWords) (view (from pillWords)) @@ -299,9 +313,9 @@ prop_explodeBytes = roundTrip (view (from pillWords) . VP.fromList) (strip . VP.toList . view pillWords) . strip -prop_packAtomSane = equiv packAtom dumbPackAtom . Pill . fromList -prop_unpackAtom = roundTrip unpackAtom packAtom -prop_packAtom = roundTrip packAtom unpackAtom . Pill . strip +prop_packAtomSane = equiv (view (from pill)) dumbPackAtom . Pill . fromList +prop_unpackAtom = roundTrip (view pill) (view (from pill)) +prop_packAtom = roundTrip (view (from pill)) (view pill) . Pill . strip -------------------------------------------------------------------------------- diff --git a/pkg/hair/lib/Vere/Http/Server.hs b/pkg/hair/lib/Vere/Http/Server.hs index a81d52eb0..2e1586a29 100644 --- a/pkg/hair/lib/Vere/Http/Server.hs +++ b/pkg/hair/lib/Vere/Http/Server.hs @@ -4,13 +4,16 @@ module Vere.Http.Server where import ClassyPrelude import Vere.Http +import Data.Noun.Atom +import Control.Lens import Control.Concurrent (ThreadId, killThread, forkIO) -import Data.Noun.Atom -import Data.Noun.Pill (packAtom, Pill(..)) -import qualified Network.HTTP.Types as H -import qualified Network.Wai as W -import qualified Network.Wai.Handler.Warp as W +import Data.Noun.Pill (pill, pillBS, Pill(..)) + +import qualified Data.ByteString as BS +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.WarpTLS as W type ServerId = Word @@ -99,8 +102,18 @@ cookMeth re = data Octs = Octs Atom Atom -bsToOcts :: ByteString -> Octs -bsToOcts bs = Octs (fromIntegral (length bs)) (packAtom (Pill bs)) +bsOcts :: Iso' ByteString Octs +bsOcts = iso toOcts fromOcts + where + toOcts :: ByteString -> Octs + toOcts bs = + Octs (fromIntegral (length bs)) (bs ^. from (pill . pillBS)) + + fromOcts :: Octs -> ByteString + fromOcts (Octs (fromIntegral -> len) atm) = bs <> pad + where + bs = atm ^. pill . pillBS + pad = BS.replicate (max 0 (len - length bs)) 0 readEvents :: W.Request -> IO Request readEvents request = do diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hair/lib/Vere/Log.hs index 789762b5c..719d147e0 100644 --- a/pkg/hair/lib/Vere/Log.hs +++ b/pkg/hair/lib/Vere/Log.hs @@ -11,6 +11,8 @@ module Vere.Log ( ) where import ClassyPrelude hiding (init) +import Control.Lens hiding ((<|)) + import Data.Noun import Data.Noun.Atom import Data.Noun.Jam @@ -21,12 +23,13 @@ import Foreign.Ptr import Foreign.Marshal.Alloc import Vere.Pier.Types +import Control.Lens ((^.)) import Foreign.Storable (peek, poke, sizeOf) import qualified Data.ByteString.Unsafe as BU -import qualified Data.ByteString as B -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV +import qualified Data.ByteString as B +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV -------------------------------------------------------------------------------- @@ -47,7 +50,6 @@ shutdown s = do void $ waitCancel (writer s) mdb_env_close (env s) - waitCancel :: Async a -> IO (Either SomeException a) waitCancel async = cancel async >> waitCatch async @@ -72,12 +74,18 @@ byteStringAsMdbVal bs k = mdbValToAtom :: MDB_val -> IO Atom mdbValToAtom (MDB_val sz ptr) = do - packAtom . Pill <$> BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) + bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) + pure (bs ^. from (pill . pillBS)) + +maybeErr :: Maybe a -> String -> IO a +maybeErr (Just x) _ = pure x +maybeErr Nothing msg = error msg mdbValToNoun :: MDB_val -> IO Noun mdbValToNoun (MDB_val sz ptr) = do bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) - maybe (error "mdb bad cue") pure (cue (packAtom (Pill bs))) + let res = (bs ^? from pillBS . from pill . _Cue) + maybeErr res "mdb bad cue" putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO () putRaw flags txn db key val = @@ -88,13 +96,13 @@ putRaw flags txn db key val = putNoun :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO () putNoun flags txn db key val = byteStringAsMdbVal key $ \mKey -> - byteStringAsMdbVal (nounToBs val) $ \mVal -> + byteStringAsMdbVal (val ^. re _CueBytes) $ \mVal -> putRaw flags txn db mKey mVal putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO () -putJam flags txn db id (Jam atom) = do +putJam flags txn db id (Jam atom) = do withWord64AsMDBval id $ \idVal -> do - let !bs = unPill (unpackAtom atom) + let !bs = atom ^. pill . pillBS byteStringAsMdbVal bs $ \mVal -> do putRaw flags txn db idVal mVal From 585cb74c1f25cad0062c529377d00e5b2f02502f Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Fri, 31 May 2019 15:55:21 -0700 Subject: [PATCH 059/431] Start work on the thing which communicates with the subprocess. --- pkg/hair/lib/Vere/Pier.hs | 1 + pkg/hair/lib/Vere/Worker.hs | 247 ++++++++++++++++++++++++++++++++++++ pkg/hair/package.yaml | 1 + 3 files changed, 249 insertions(+) create mode 100644 pkg/hair/lib/Vere/Worker.hs diff --git a/pkg/hair/lib/Vere/Pier.hs b/pkg/hair/lib/Vere/Pier.hs index d86f544b7..5b8c709c7 100644 --- a/pkg/hair/lib/Vere/Pier.hs +++ b/pkg/hair/lib/Vere/Pier.hs @@ -15,3 +15,4 @@ initPier top = do logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) pure (Pier{..}) + diff --git a/pkg/hair/lib/Vere/Worker.hs b/pkg/hair/lib/Vere/Worker.hs new file mode 100644 index 000000000..26e370023 --- /dev/null +++ b/pkg/hair/lib/Vere/Worker.hs @@ -0,0 +1,247 @@ +module Vere.Worker where + +import ClassyPrelude +import Control.Lens +import Data.Void + +import Data.Noun +import Data.Noun.Atom +import Data.Noun.Jam +import Data.Noun.Poet +import Data.Noun.Pill +import Vere.Pier.Types +import System.Process + +data Worker = Worker + { sendHandle :: Handle + , recvHandle :: Handle + , process :: ProcessHandle + + -- , getInput :: STM (Writ ()) + -- , onComputed :: Writ [Effect] -> STM () + +-- , onExit :: Worker -> IO () +-- , task :: Async () + } + +newtype Cord = Cord ByteString + deriving (Eq) + +instance Show Cord where + show (Cord bs) = show bs -- TODO + +------------------------------------- + +class Poet a where + _Poet :: Prism' Noun a + +toNoun' :: Poet a => a -> Noun +toNoun' = review _Poet + +fromNoun' :: Poet a => Noun -> Maybe a +fromNoun' = preview _Poet + +instance Poet Cord where + _Poet = undefined + +instance ToNoun Cord where + toNoun = undefined + +------------------------------------- + +start :: IO Worker +start = do + -- Think about how to handle process exit + -- Tear down subprocess on exit? (terminiteProcess) + (Just stdin, Just stdout, _, ph) <- + createProcess (proc "urbit-worker" []){ std_in = CreatePipe, + std_out = CreatePipe } + pure (Worker stdin stdout ph) + +kill :: Worker -> IO () +kill worker = undefined + +work :: Word64 -> Jam -> Atom +work id (Jam a) = jam $ toNoun (Cord "work", id, a) + +data Job = Job Void + deriving (Eq, Show) + +data Tank = Tank Void + deriving (Eq, Show) + +type EventId = Word64 + +data Ship = Ship Word64 -- @p + deriving (Eq, Show) + +data ShipId = ShipId { addr :: Ship, fake :: Bool } + deriving (Eq, Show) + +data Play + = PlayNone -- ~ + | PlaySnap EventId Mug ShipId -- [@ @ @ ?] + deriving Eq + +-- TODO Hack +deriving instance Show Mug +deriving instance Eq Mug +deriving instance Eq Ovum +deriving instance Show Ovum + +data Plea + = Play Play + | Work EventId Mug Job + | Done EventId Mug [Ovum] + | Stdr EventId Cord + | Slog EventId Word32 Tank + deriving Eq + + +type CompletedEventId = Word64 +type NextEventId = Word64 + +type LogState = Maybe EventId + +type WorkerState = (EventId, Mug) + + +-- boot +-- boot = do +-- sendAtom w ( + +printTank :: Word32 -> Tank -> IO () +printTank pri t = print "tank" + + +assertErr = undefined + +sendAndRecv :: Worker -> EventId -> Atom -> IO (Either (EventId, Mug, Job) (EventId, Mug, [Ovum])) +sendAndRecv w eventId event = + do + sendAtom w (work eventId (Jam event)) + loop + where + recv i m o = do + assertErr (i == eventId) "bad event id in sendAndRecv" + pure (Right (i, m, o)) + replace i m j = do + assertErr (i == eventId) "bad replacement id in sendAndRecv" + pure (Left (i, m, j)) + loop = recvPlea w >>= \case + Nothing -> error "everything is on fire. i'm sorry." + Just (Play p) -> error "the state is in the wrong place." + Just (Done i m o) -> recv i m o + Just (Work i m j) -> replace i m j + Just (Stdr _ cord) -> print cord >> loop + Just (Slog _ pri t) -> (printTank pri t) >> loop + + +sendBootEvent = undefined + +-- the ship is booted, but it is behind. shove events to the worker until it is +-- caught up. +replay :: Worker -> WorkerState -> EventId + -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) + -> IO () +replay w (wid, wmug) lastCommitedId getEvents = do + case wid of + 1 -> sendBootEvent + _ -> pure () + + -- todo: we want to stream these in chunks + events <- getEvents wid (1 + lastCommitedId - wid) + + for_ events $ \(eventId, event) -> do + (Right (i, mug, ovum)) <- sendAndRecv w eventId event + undefined + + -- todo: these actually have to happen concurrently + + + +playToState :: Play -> WorkerState +playToState = \case + PlayNone -> (1, Mug 0) + PlaySnap e m _ -> (e, m) + +-- computeThread :: Worker -> IO () +-- computeThread w = start +-- where +-- start = do +-- Just (Play p) <- recvPlea w +-- let (eventId, mug) = playToState p +-- -- fuck it, we'll do it liv_o + +-- boot :: WorkerState -> -> IO () +-- boot w = do + + +-- writ <- atomically $ (getInput w) +-- sendAtom w (work (eventId writ) (event writ)) + + +-- The flow here is that we start the worker and then we receive a play event +-- with the current worker state: +-- +-- <- [%play ...] +-- +-- Base on this, the main flow is +-- + + -- [%work ] -> + -- <- [%slog] + -- <- [%slog] + -- <- [%slog] + -- <- [%work crash=tang] + -- [%work ] -> (replacement) + -- <- [%slog] + -- <- [%done] + +-- response <- recvAtom w + + + + + + + + + + + +-------------------------------------------------------------------------------- + + +sendAtom :: Worker -> Atom -> IO () +sendAtom w a = hPut (sendHandle w) (unpackAtom a) + +atomBytes :: Iso' Atom ByteString +atomBytes = pill . pillBS + +packAtom = view (from atomBytes) + +unpackAtom :: Atom -> ByteString +unpackAtom = view atomBytes + +recvLen :: Worker -> IO Word64 +recvLen = undefined + +recvBytes :: Worker -> Word64 -> IO ByteString +recvBytes = undefined + +recvAtom :: Worker -> IO (Atom) +recvAtom w = do + len <- recvLen w + bs <- recvBytes w len + pure (packAtom bs) + +fromNoun :: Noun -> Maybe a +fromNoun = const Nothing -- TODO + +recvPlea :: Worker -> IO (Maybe Plea) +recvPlea w = do + a <- recvAtom w + pure (cue a >>= fromNoun) + +-- [%work eventId mat] diff --git a/pkg/hair/package.yaml b/pkg/hair/package.yaml index f1ec4d871..3516f8379 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hair/package.yaml @@ -66,6 +66,7 @@ dependencies: - para - pretty-show - primitive + - process - QuickCheck - sdl2 - sdl2-image From 6a5bc78370904f8a9ef0c85043397063e0f6cb3a Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 31 May 2019 17:21:44 -0700 Subject: [PATCH 060/431] More progress on worker interaction. --- pkg/hair/lib/Data/Noun/Poet.hs | 54 ++++++++++- pkg/hair/lib/Vere/Pier/Types.hs | 7 +- pkg/hair/lib/Vere/Worker.hs | 156 ++++++++++++++++++-------------- 3 files changed, 147 insertions(+), 70 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hair/lib/Data/Noun/Poet.hs index 2b685cdd6..ddfdafa6e 100644 --- a/pkg/hair/lib/Data/Noun/Poet.hs +++ b/pkg/hair/lib/Data/Noun/Poet.hs @@ -1,11 +1,13 @@ module Data.Noun.Poet where import Prelude +import Control.Lens import Control.Applicative import Control.Monad import Data.Noun import Data.Noun.Atom +import Data.Void import GHC.Natural import Data.List (intercalate) @@ -143,23 +145,69 @@ class FromNoun a where class ToNoun a where toNoun :: a -> Noun +fromNoun :: FromNoun a => Noun -> Maybe a +fromNoun n = runParser (parseNoun n) [] onFail onSuccess + where + onFail p m = Nothing + onSuccess x = Just x --- Atom Conversion ------------------------------------------------------------- +_Poet :: (ToNoun a, FromNoun a) => Prism' Noun a +_Poet = prism' toNoun fromNoun + + +-- Trivial Conversion ---------------------------------------------------------- + +instance ToNoun Void where + toNoun = absurd + +instance FromNoun Void where + parseNoun = fail "Can't produce void" instance ToNoun Noun where toNoun = id +instance FromNoun Noun where + parseNoun = pure + +-- Bool Conversion ------------------------------------------------------------- + +instance ToNoun Bool where + toNoun True = Atom 0 + toNoun False = Atom 1 + +instance FromNoun Bool where + parseNoun (Atom 0) = pure True + parseNoun (Atom 1) = pure False + parseNoun (Cell _ _) = fail "expecting a bool, but got a cell" + parseNoun (Atom a) = fail ("expecting a bool, but got " <> show a) + +-- Atom Conversion ------------------------------------------------------------- + +instance ToNoun Atom where + toNoun = Atom + +instance FromNoun Atom where + parseNoun (Cell _ _) = fail "Expecting an atom, but got a cell" + parseNoun (Atom a) = pure a + +-- Word Conversion ------------------------------------------------------------- + instance ToNoun Word where toNoun = Atom . fromIntegral instance ToNoun Word32 where toNoun = Atom . fromIntegral +instance FromNoun Word32 where + parseNoun (Cell _ _) = fail "cell is not an atom" + parseNoun (Atom a) = pure (fromIntegral a) -- TODO Overflow + instance ToNoun Word64 where toNoun = Atom . fromIntegral -instance ToNoun Atom where - toNoun = Atom +instance FromNoun Word64 where + parseNoun (Cell _ _) = fail "cell is not an atom" + parseNoun (Atom a) = pure (fromIntegral a) -- TODO Overflow instance ToNoun Natural where toNoun = toNoun . toAtom diff --git a/pkg/hair/lib/Vere/Pier/Types.hs b/pkg/hair/lib/Vere/Pier/Types.hs index 6e86e3b43..a4e501702 100644 --- a/pkg/hair/lib/Vere/Pier/Types.hs +++ b/pkg/hair/lib/Vere/Pier/Types.hs @@ -1,14 +1,19 @@ module Vere.Pier.Types where import ClassyPrelude +import Data.Void import Data.Noun import Data.Noun.Atom +import Data.Noun.Poet import Database.LMDB.Raw import Urbit.Time data Effect -data Ovum +newtype Ovum = Ovum Void + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) + newtype Mug = Mug Word32 + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) newtype Jam = Jam Atom diff --git a/pkg/hair/lib/Vere/Worker.hs b/pkg/hair/lib/Vere/Worker.hs index 26e370023..9e731e57a 100644 --- a/pkg/hair/lib/Vere/Worker.hs +++ b/pkg/hair/lib/Vere/Worker.hs @@ -4,6 +4,8 @@ import ClassyPrelude import Control.Lens import Data.Void +import System.Exit (ExitCode) + import Data.Noun import Data.Noun.Atom import Data.Noun.Jam @@ -25,29 +27,19 @@ data Worker = Worker } newtype Cord = Cord ByteString - deriving (Eq) + deriving newtype (Eq, Ord, Show) -instance Show Cord where - show (Cord bs) = show bs -- TODO - -------------------------------------- - -class Poet a where - _Poet :: Prism' Noun a - -toNoun' :: Poet a => a -> Noun -toNoun' = review _Poet - -fromNoun' :: Poet a => Noun -> Maybe a -fromNoun' = preview _Poet - -instance Poet Cord where - _Poet = undefined +-------------------------------------------------------------------------------- instance ToNoun Cord where - toNoun = undefined + toNoun (Cord bs) = Atom (bs ^. from (pill . pillBS)) -------------------------------------- +instance FromNoun Cord where + parseNoun n = do + atom <- parseNoun n + pure $ Cord (atom ^. pill . pillBS) + +-------------------------------------------------------------------------------- start :: IO Worker start = do @@ -58,8 +50,10 @@ start = do std_out = CreatePipe } pure (Worker stdin stdout ph) -kill :: Worker -> IO () -kill worker = undefined +kill :: Worker -> IO ExitCode +kill w = do + terminateProcess (process w) + waitForProcess (process w) work :: Word64 -> Jam -> Atom work id (Jam a) = jam $ toNoun (Cord "work", id, a) @@ -72,22 +66,27 @@ data Tank = Tank Void type EventId = Word64 -data Ship = Ship Word64 -- @p - deriving (Eq, Show) +newtype Ship = Ship Word64 -- @p + deriving newtype (Eq, Show, FromNoun, ToNoun) data ShipId = ShipId { addr :: Ship, fake :: Bool } deriving (Eq, Show) +-------------------------------------------------------------------------------- + data Play = PlayNone -- ~ | PlaySnap EventId Mug ShipId -- [@ @ @ ?] - deriving Eq + deriving (Eq, Show) --- TODO Hack -deriving instance Show Mug -deriving instance Eq Mug -deriving instance Eq Ovum -deriving instance Show Ovum +instance ToNoun Play where + toNoun = \case PlayNone -> Atom 0 + PlaySnap e m (ShipId a f) -> toNoun (e, m, a, f) + +instance FromNoun Play where + parseNoun = undefined + +-------------------------------------------------------------------------------- data Plea = Play Play @@ -95,8 +94,12 @@ data Plea | Done EventId Mug [Ovum] | Stdr EventId Cord | Slog EventId Word32 Tank - deriving Eq + deriving (Eq, Show) +instance FromNoun Plea where + parseNoun = undefined + +-------------------------------------------------------------------------------- type CompletedEventId = Word64 type NextEventId = Word64 @@ -105,39 +108,66 @@ type LogState = Maybe EventId type WorkerState = (EventId, Mug) +type ReplacementEv = (EventId, Mug, Job) +type WorkResult = (EventId, Mug, [Ovum]) +type WorkerResp = (Either ReplacementEv WorkResult) --- boot --- boot = do --- sendAtom w ( +-- Exceptions ------------------------------------------------------------------ + +data WorkerExn + = BadComputeId EventId WorkResult + | BadReplacementId EventId ReplacementEv + | UnexpectedPlay EventId Play + | BadPleaAtom Atom + | BadPleaNoun Noun + deriving (Show) + +instance Exception WorkerExn + +-- Utils ----------------------------------------------------------------------- printTank :: Word32 -> Tank -> IO () printTank pri t = print "tank" +guardExn :: Exception e => Bool -> e -> IO () +guardExn ok = unless ok . throwIO -assertErr = undefined +fromJustExn :: Exception e => Maybe a -> e -> IO a +fromJustExn Nothing exn = throwIO exn +fromJustExn (Just x) exn = pure x -sendAndRecv :: Worker -> EventId -> Atom -> IO (Either (EventId, Mug, Job) (EventId, Mug, [Ovum])) +-------------------------------------------------------------------------------- + +boot :: a -> IO b +boot = undefined + +sendAndRecv :: Worker -> EventId -> Atom -> IO WorkerResp sendAndRecv w eventId event = do - sendAtom w (work eventId (Jam event)) + sendAtom w $ work eventId (Jam event) loop where - recv i m o = do - assertErr (i == eventId) "bad event id in sendAndRecv" - pure (Right (i, m, o)) - replace i m j = do - assertErr (i == eventId) "bad replacement id in sendAndRecv" + produce :: WorkResult -> IO WorkerResp + produce (i, m, o) = do + guardExn (i /= eventId) (BadComputeId eventId (i, m, o)) + pure $ Right (i, m, o) + + replace :: ReplacementEv -> IO WorkerResp + replace (i, m, j) = do + guardExn (i /= eventId) (BadReplacementId eventId (i, m, j)) pure (Left (i, m, j)) + + loop :: IO WorkerResp loop = recvPlea w >>= \case - Nothing -> error "everything is on fire. i'm sorry." - Just (Play p) -> error "the state is in the wrong place." - Just (Done i m o) -> recv i m o - Just (Work i m j) -> replace i m j - Just (Stdr _ cord) -> print cord >> loop - Just (Slog _ pri t) -> (printTank pri t) >> loop + Play p -> throwIO (UnexpectedPlay eventId p) + Done i m o -> produce (i, m, o) + Work i m j -> replace (i, m, j) + Stdr _ cord -> print cord >> loop + Slog _ pri t -> printTank pri t >> loop - -sendBootEvent = undefined +sendBootEvent :: Worker -> IO () +sendBootEvent = do + undefined -- the ship is booted, but it is behind. shove events to the worker until it is -- caught up. @@ -145,9 +175,7 @@ replay :: Worker -> WorkerState -> EventId -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) -> IO () replay w (wid, wmug) lastCommitedId getEvents = do - case wid of - 1 -> sendBootEvent - _ -> pure () + when (wid == 1) (sendBootEvent w) -- todo: we want to stream these in chunks events <- getEvents wid (1 + lastCommitedId - wid) @@ -160,9 +188,9 @@ replay w (wid, wmug) lastCommitedId getEvents = do -playToState :: Play -> WorkerState -playToState = \case - PlayNone -> (1, Mug 0) +playWorkerState :: Play -> WorkerState +playWorkerState = \case + PlayNone -> (1, Mug 0) PlaySnap e m _ -> (e, m) -- computeThread :: Worker -> IO () @@ -170,12 +198,11 @@ playToState = \case -- where -- start = do -- Just (Play p) <- recvPlea w --- let (eventId, mug) = playToState p +-- let (eventId, mug) = playWorkerState p -- -- fuck it, we'll do it liv_o -- boot :: WorkerState -> -> IO () -- boot w = do - -- writ <- atomically $ (getInput w) -- sendAtom w (work (eventId writ) (event writ)) @@ -197,6 +224,7 @@ playToState = \case -- [%work ] -> (replacement) -- <- [%slog] -- <- [%done] +-- [%work eventId mat] -- response <- recvAtom w @@ -210,8 +238,7 @@ playToState = \case --------------------------------------------------------------------------------- - +-- Basic Send and Receive Operations ------------------------------------------- sendAtom :: Worker -> Atom -> IO () sendAtom w a = hPut (sendHandle w) (unpackAtom a) @@ -236,12 +263,9 @@ recvAtom w = do bs <- recvBytes w len pure (packAtom bs) -fromNoun :: Noun -> Maybe a -fromNoun = const Nothing -- TODO - -recvPlea :: Worker -> IO (Maybe Plea) +recvPlea :: Worker -> IO Plea recvPlea w = do a <- recvAtom w - pure (cue a >>= fromNoun) - --- [%work eventId mat] + n <- fromJustExn (cue a) (BadPleaAtom a) + p <- fromJustExn (fromNoun n) (BadPleaNoun n) + pure p From 5b3ab33dac61f4e91e87773530a3e8b5c81fcb33 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sat, 1 Jun 2019 14:07:40 -0700 Subject: [PATCH 061/431] Lots of noun parsing/unparsing code. --- pkg/hair/lib/Data/Noun/Jam.hs | 5 +- pkg/hair/lib/Data/Noun/Poet.hs | 181 ++++++++++++++++++++++++++++----- pkg/hair/lib/Vere/Isle.hs | 5 + pkg/hair/lib/Vere/Worker.hs | 94 ++++++++--------- 4 files changed, 204 insertions(+), 81 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hair/lib/Data/Noun/Jam.hs index d55244f72..803f37a3f 100644 --- a/pkg/hair/lib/Data/Noun/Jam.hs +++ b/pkg/hair/lib/Data/Noun/Jam.hs @@ -3,7 +3,6 @@ module Data.Noun.Jam where import ClassyPrelude import Data.Noun import Data.Noun.Atom -import Data.Noun.Poet import Data.Bits import Control.Lens import Text.Printf @@ -79,7 +78,7 @@ cue' buf = view _2 <$> go mempty 0 go tbl i = case (bitIdx i buf, bitIdx (i+1) buf) of (False, _ ) -> do Buf wid at <- rub' (Cursor (i+1) buf) - let r = toNoun at + let r = Atom at pure (wid+1, r, insertMap i r tbl) (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) @@ -169,7 +168,7 @@ cue buf = view _2 <$> go mempty 0 -- trace ("go-" <> show i) case (bitIdx i buf, bitIdx (i+1) buf) of (False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf) - let r = toNoun at + let r = Atom at pure (wid+1, r, insertMap i r tbl) (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hair/lib/Data/Noun/Poet.hs index ddfdafa6e..f3a944073 100644 --- a/pkg/hair/lib/Data/Noun/Poet.hs +++ b/pkg/hair/lib/Data/Noun/Poet.hs @@ -1,22 +1,38 @@ module Data.Noun.Poet where -import Prelude +import ClassyPrelude hiding (fromList) import Control.Lens import Control.Applicative import Control.Monad import Data.Noun import Data.Noun.Atom +import Data.Noun.Pill import Data.Void +import Data.Word import GHC.Natural import Data.List (intercalate) import Data.Typeable (Typeable) -import Data.Word (Word, Word32, Word64) import qualified Control.Monad.Fail as Fail +-- Types For Hoon Constructs --------------------------------------------------- + +{-| + `Nullable a <-> ?@(~ a)` + + This is distinct from `unit`, since there is no tag on the non-atom + case, therefore `a` must always be cell type. +-} +data Nullable a = Nil | NotNil a + deriving (Eq, Ord, Show) + +newtype Cord = Cord ByteString + deriving newtype (Eq, Ord, Show) + + -- IResult --------------------------------------------------------------------- data IResult a = IError NounPath String | ISuccess a @@ -169,7 +185,8 @@ instance ToNoun Noun where instance FromNoun Noun where parseNoun = pure --- Bool Conversion ------------------------------------------------------------- + +-- Loobean Conversion ---------------------------------------------------------- instance ToNoun Bool where toNoun True = Atom 0 @@ -181,6 +198,7 @@ instance FromNoun Bool where parseNoun (Cell _ _) = fail "expecting a bool, but got a cell" parseNoun (Atom a) = fail ("expecting a bool, but got " <> show a) + -- Atom Conversion ------------------------------------------------------------- instance ToNoun Atom where @@ -190,42 +208,153 @@ instance FromNoun Atom where parseNoun (Cell _ _) = fail "Expecting an atom, but got a cell" parseNoun (Atom a) = pure a + +-- Natural Conversion----------------------------------------------------------- + +instance ToNoun Natural where toNoun = toNoun . MkAtom +instance FromNoun Natural where parseNoun = fmap unAtom . parseNoun + + -- Word Conversion ------------------------------------------------------------- -instance ToNoun Word where - toNoun = Atom . fromIntegral +atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a +atomToWord atom = do + if atom > fromIntegral (maxBound :: a) + then fail "Atom doesn't fit in fixed-size word" + else pure (fromIntegral atom) -instance ToNoun Word32 where - toNoun = Atom . fromIntegral +wordToNoun :: Integral a => a -> Noun +wordToNoun = Atom . fromIntegral -instance FromNoun Word32 where - parseNoun (Cell _ _) = fail "cell is not an atom" - parseNoun (Atom a) = pure (fromIntegral a) -- TODO Overflow +nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a +nounToWord = parseNoun >=> atomToWord -instance ToNoun Word64 where - toNoun = Atom . fromIntegral +instance ToNoun Word where toNoun = wordToNoun +instance ToNoun Word8 where toNoun = wordToNoun +instance ToNoun Word16 where toNoun = wordToNoun +instance ToNoun Word32 where toNoun = wordToNoun +instance ToNoun Word64 where toNoun = wordToNoun -instance FromNoun Word64 where - parseNoun (Cell _ _) = fail "cell is not an atom" - parseNoun (Atom a) = pure (fromIntegral a) -- TODO Overflow - -instance ToNoun Natural where - toNoun = toNoun . toAtom +instance FromNoun Word where parseNoun = nounToWord +instance FromNoun Word8 where parseNoun = nounToWord +instance FromNoun Word16 where parseNoun = nounToWord +instance FromNoun Word32 where parseNoun = nounToWord +instance FromNoun Word64 where parseNoun = nounToWord --- Cell Conversion ------------------------------------------------------------- +-- Nullable Conversion --------------------------------------------------------- + +-- TODO Consider enforcing that `a` must be a cell. +instance ToNoun a => ToNoun (Nullable a) where + toNoun Nil = Atom 0 + toNoun (NotNil x) = toNoun x + +instance FromNoun a => FromNoun (Nullable a) where + parseNoun (Atom 0) = pure Nil + parseNoun (Atom n) = fail ("Expected ?@(~ ^), but got " <> show n) + parseNoun n = NotNil <$> parseNoun n + + +-- Maybe is `unit` ------------------------------------------------------------- + +-- TODO Consider enforcing that `a` must be a cell. +instance ToNoun a => ToNoun (Maybe a) where + toNoun Nothing = Atom 0 + toNoun (Just x) = Cell (Atom 0) (toNoun x) + +instance FromNoun a => FromNoun (Maybe a) where + parseNoun = \case + Atom 0 -> pure Nothing + Atom n -> unexpected ("atom " <> show n) + Cell (Atom 0) t -> Just <$> parseNoun t + Cell n _ -> unexpected ("cell with head-atom " <> show n) + where + unexpected s = fail ("Expected unit value, but got " <> s) + + +-- List Conversion ------------------------------------------------------------- + +instance ToNoun a => ToNoun [a] where + toNoun xs = fromList (toNoun <$> xs) + +instance FromNoun a => FromNoun [a] where + parseNoun (Atom 0) = pure [] + parseNoun (Atom _) = fail "list terminated with non-null atom" + parseNoun (Cell l r) = (:) <$> parseNoun l <*> parseNoun r + + +-- Cord Conversion ------------------------------------------------------------- + +instance ToNoun Cord where + toNoun (Cord bs) = Atom (bs ^. from (pill . pillBS)) + +instance FromNoun Cord where + parseNoun n = do + atom <- parseNoun n + pure $ Cord (atom ^. pill . pillBS) + + +-- Pair Conversion ------------------------------------------------------------- instance (ToNoun a, ToNoun b) => ToNoun (a, b) where toNoun (x, y) = Cell (toNoun x) (toNoun y) +instance (FromNoun a, FromNoun b) => FromNoun (a, b) where + parseNoun (Atom n) = fail ("expected a cell, but got an atom: " <> show n) + parseNoun (Cell l r) = (,) <$> parseNoun l <*> parseNoun r + + +-- Trel Conversion ------------------------------------------------------------- + instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where - toNoun (x, y, z) = Cell (toNoun x) - $ Cell (toNoun y) (toNoun z) + toNoun (x, y, z) = toNoun (x, (y, z)) + +instance (FromNoun a, FromNoun b, FromNoun c) => FromNoun (a, b, c) where + parseNoun n = do + (x, t) <- parseNoun n + (y, z) <- parseNoun t + pure (x, y, z) + + +-- Quad Conversion ------------------------------------------------------------- instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where - toNoun (x, y, z, a) = Cell (toNoun x) - $ Cell (toNoun y) - $ Cell (toNoun z) (toNoun a) + toNoun (p, q, r, s) = toNoun (p, (q, r, s)) -instance ToNoun a => ToNoun [a] where - toNoun xs = fromList (toNoun <$> xs) +instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d) + => FromNoun (a, b, c, d) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s) <- parseNoun tail + pure (p, q, r, s) + + +-- Pent Conversion ------------------------------------------------------------ + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e) + => ToNoun (a, b, c, d, e) where + toNoun (p, q, r, s, t) = toNoun (p, (q, r, s, t)) + +instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e) + => FromNoun (a, b, c, d, e) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t) <- parseNoun tail + pure (p, q, r, s, t) + + +-- Sext Conversion ------------------------------------------------------------ + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f) + => ToNoun (a, b, c, d, e, f) where + toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u)) + +instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e,FromNoun f) + => FromNoun (a, b, c, d, e, f) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u) <- parseNoun tail + pure (p, q, r, s, t, u) diff --git a/pkg/hair/lib/Vere/Isle.hs b/pkg/hair/lib/Vere/Isle.hs index 3fc7143c4..00a3e5227 100644 --- a/pkg/hair/lib/Vere/Isle.hs +++ b/pkg/hair/lib/Vere/Isle.hs @@ -21,6 +21,11 @@ data Color deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) deriving anyclass Flat +type Blit = Vector (Vector Color) + +solid :: Color -> Blit +solid c = replicate 640 (replicate 480 c) + toRGB :: Color -> (Word8, Word8, Word8) toRGB = \case Black -> (0x00, 0x00, 0x00) diff --git a/pkg/hair/lib/Vere/Worker.hs b/pkg/hair/lib/Vere/Worker.hs index 9e731e57a..5f6f20207 100644 --- a/pkg/hair/lib/Vere/Worker.hs +++ b/pkg/hair/lib/Vere/Worker.hs @@ -26,18 +26,6 @@ data Worker = Worker -- , task :: Async () } -newtype Cord = Cord ByteString - deriving newtype (Eq, Ord, Show) - --------------------------------------------------------------------------------- - -instance ToNoun Cord where - toNoun (Cord bs) = Atom (bs ^. from (pill . pillBS)) - -instance FromNoun Cord where - parseNoun n = do - atom <- parseNoun n - pure $ Cord (atom ^. pill . pillBS) -------------------------------------------------------------------------------- @@ -58,35 +46,23 @@ kill w = do work :: Word64 -> Jam -> Atom work id (Jam a) = jam $ toNoun (Cord "work", id, a) -data Job = Job Void - deriving (Eq, Show) +newtype Job = Job Void + deriving newtype (Eq, Show, ToNoun, FromNoun) -data Tank = Tank Void - deriving (Eq, Show) +newtype Tank = Tank Void + deriving newtype (Eq, Show, ToNoun, FromNoun) type EventId = Word64 newtype Ship = Ship Word64 -- @p - deriving newtype (Eq, Show, FromNoun, ToNoun) + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) -data ShipId = ShipId { addr :: Ship, fake :: Bool } - deriving (Eq, Show) +newtype ShipId = ShipId (Ship, Bool) + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) -------------------------------------------------------------------------------- -data Play - = PlayNone -- ~ - | PlaySnap EventId Mug ShipId -- [@ @ @ ?] - deriving (Eq, Show) - -instance ToNoun Play where - toNoun = \case PlayNone -> Atom 0 - PlaySnap e m (ShipId a f) -> toNoun (e, m, a, f) - -instance FromNoun Play where - parseNoun = undefined - --------------------------------------------------------------------------------- +type Play = Nullable (EventId, Mug, ShipId) data Plea = Play Play @@ -96,8 +72,23 @@ data Plea | Slog EventId Word32 Tank deriving (Eq, Show) +instance ToNoun Plea where + toNoun = \case + Play p -> toNoun (Cord "play", p) + Work i m j -> toNoun (Cord "work", i, m, j) + Done i m o -> toNoun (Cord "done", i, m, o) + Stdr i msg -> toNoun (Cord "stdr", i, msg) + Slog i p t -> toNoun (Cord "slog", i, p, t) + instance FromNoun Plea where - parseNoun = undefined + parseNoun n = + parseNoun n >>= \case + (Cord "play", p) -> parseNoun p <&> \p -> Play p + (Cord "work", w) -> parseNoun w <&> \(i, m, j) -> Work i m j + (Cord "done", d) -> parseNoun d <&> \(i, m, o) -> Done i m o + (Cord "stdr", r) -> parseNoun r <&> \(i, msg) -> Stdr i msg + (Cord "slog", s) -> parseNoun s <&> \(i, p, t) -> Slog i p t + (Cord tag , s) -> fail ("Invalid plea tag: " <> unpack (decodeUtf8 tag)) -------------------------------------------------------------------------------- @@ -186,26 +177,25 @@ replay w (wid, wmug) lastCommitedId getEvents = do -- todo: these actually have to happen concurrently +computeThread :: Worker -> IO () +computeThread w = start + where + start = do + Play p <- recvPlea w + let (eventId, mug) = playWorkerState p + -- fuck it, we'll do it liv_o + undefined + boot :: WorkerState -> IO () + boot workState = do + undefined + writ <- undefined -- getWrit w + sendAtom w (work (eventId writ) (event writ)) -playWorkerState :: Play -> WorkerState -playWorkerState = \case - PlayNone -> (1, Mug 0) - PlaySnap e m _ -> (e, m) - --- computeThread :: Worker -> IO () --- computeThread w = start --- where --- start = do --- Just (Play p) <- recvPlea w --- let (eventId, mug) = playWorkerState p --- -- fuck it, we'll do it liv_o - --- boot :: WorkerState -> -> IO () --- boot w = do - --- writ <- atomically $ (getInput w) --- sendAtom w (work (eventId writ) (event writ)) + playWorkerState :: Play -> WorkerState + playWorkerState = \case + Nil -> (1, Mug 0) + NotNil (e, m, _) -> (e, m) -- The flow here is that we start the worker and then we receive a play event @@ -257,7 +247,7 @@ recvLen = undefined recvBytes :: Worker -> Word64 -> IO ByteString recvBytes = undefined -recvAtom :: Worker -> IO (Atom) +recvAtom :: Worker -> IO Atom recvAtom w = do len <- recvLen w bs <- recvBytes w len From 54fc5f6078c74fe58ad768b5673a981dafdf5320 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sat, 1 Jun 2019 14:49:21 -0700 Subject: [PATCH 062/431] Types and conversion for Tank/Plum. --- pkg/hair/lib/Data/Noun/Poet.hs | 63 ++++++++++++++++++++++++++++++++++ pkg/hair/lib/Vere/Worker.hs | 31 +++++++---------- 2 files changed, 75 insertions(+), 19 deletions(-) diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hair/lib/Data/Noun/Poet.hs index f3a944073..7c99cfc37 100644 --- a/pkg/hair/lib/Data/Noun/Poet.hs +++ b/pkg/hair/lib/Data/Noun/Poet.hs @@ -29,9 +29,45 @@ import qualified Control.Monad.Fail as Fail data Nullable a = Nil | NotNil a deriving (Eq, Ord, Show) +newtype Tour = Tour [Char] + deriving (Eq, Ord, Show) + +newtype Tape = Tape ByteString + deriving (Eq, Ord, Show) + newtype Cord = Cord ByteString deriving newtype (Eq, Ord, Show) +type Tang = [Tank] + +data Tank + = TLeaf Tape + | TPlum Plum + | TPalm (Tape, Tape, Tape, Tape) [Tank] + | TRose (Tape, Tape, Tape) [Tank] + deriving (Eq, Ord, Show) + +type Tile = Cord + +data WideFmt + = WideFmt { delimit :: Tile, enclose :: Maybe (Tile, Tile) } + deriving (Eq, Ord, Show) + +data TallFmt + = TallFmt { intro :: Tile, indef :: Maybe (Tile, Tile) } + deriving (Eq, Ord, Show) + +data PlumFmt + = PlumFmt (Maybe WideFmt) (Maybe TallFmt) + deriving (Eq, Ord, Show) + +data Plum + = PAtom Cord + | PPara Tile [Cord] + | PTree PlumFmt [Plum] + | PSbrk Plum + deriving (Eq, Ord, Show) + -- IResult --------------------------------------------------------------------- @@ -294,6 +330,33 @@ instance FromNoun Cord where pure $ Cord (atom ^. pill . pillBS) +-- Tank and Plum Conversion ---------------------------------------------------- + +instance ToNoun WideFmt where toNoun (WideFmt x xs) = toNoun (x, xs) +instance ToNoun TallFmt where toNoun (TallFmt x xs) = toNoun (x, xs) +instance ToNoun PlumFmt where toNoun (PlumFmt wide tall) = toNoun (wide, tall) + +instance FromNoun WideFmt where parseNoun = fmap (uncurry WideFmt) . parseNoun +instance FromNoun TallFmt where parseNoun = fmap (uncurry TallFmt) . parseNoun +instance FromNoun PlumFmt where parseNoun = fmap (uncurry PlumFmt) . parseNoun + +instance ToNoun Plum where + toNoun = \case + PAtom cord -> toNoun cord + PPara t cs -> toNoun (Cord "para", t, cs) + PTree f ps -> toNoun (Cord "tree", f, ps) + PSbrk p -> toNoun (Cord "sbrk", p) + +instance FromNoun Plum where + parseNoun = undefined + +instance ToNoun Tank where + toNoun = undefined + +instance FromNoun Tank where + parseNoun = undefined + + -- Pair Conversion ------------------------------------------------------------- instance (ToNoun a, ToNoun b) => ToNoun (a, b) where diff --git a/pkg/hair/lib/Vere/Worker.hs b/pkg/hair/lib/Vere/Worker.hs index 5f6f20207..17fb08f72 100644 --- a/pkg/hair/lib/Vere/Worker.hs +++ b/pkg/hair/lib/Vere/Worker.hs @@ -27,16 +27,21 @@ data Worker = Worker } + -------------------------------------------------------------------------------- +-- Think about how to handle process exit +-- Tear down subprocess on exit? (terminiteProcess) start :: IO Worker -start = do - -- Think about how to handle process exit - -- Tear down subprocess on exit? (terminiteProcess) - (Just stdin, Just stdout, _, ph) <- - createProcess (proc "urbit-worker" []){ std_in = CreatePipe, - std_out = CreatePipe } - pure (Worker stdin stdout ph) +start = + do + (Just i, Just o, _, p) <- createProcess pSpec + pure (Worker i o p) + where + pSpec = + (proc "urbit-worker" []) { std_in = CreatePipe + , std_out = CreatePipe + } kill :: Worker -> IO ExitCode kill w = do @@ -49,9 +54,6 @@ work id (Jam a) = jam $ toNoun (Cord "work", id, a) newtype Job = Job Void deriving newtype (Eq, Show, ToNoun, FromNoun) -newtype Tank = Tank Void - deriving newtype (Eq, Show, ToNoun, FromNoun) - type EventId = Word64 newtype Ship = Ship Word64 -- @p @@ -219,15 +221,6 @@ computeThread w = start -- response <- recvAtom w - - - - - - - - - -- Basic Send and Receive Operations ------------------------------------------- sendAtom :: Worker -> Atom -> IO () From 3e518f4d99a8842949c733c73a6beda67eb33da0 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sat, 1 Jun 2019 14:56:09 -0700 Subject: [PATCH 063/431] Separated new-vere executables into separate package for faster builds. --- pkg/hair/notes/BehnSketch.hs.txt | 184 -- pkg/hair/notes/Sketch.hs.txt | 65 - pkg/hair/notes/c/ames.c | 563 ---- pkg/hair/notes/c/behn.c | 90 - pkg/hair/notes/c/cttp.c | 989 ------ pkg/hair/notes/c/daemon.c | 735 ----- pkg/hair/notes/c/dawn.c | 525 --- pkg/hair/notes/c/foil.c | 170 - pkg/hair/notes/c/hash_tests.c | 105 - pkg/hair/notes/c/hashtable_tests.c | 144 - pkg/hair/notes/c/http.c | 2908 ----------------- pkg/hair/notes/c/lmdb.c | 670 ---- pkg/hair/notes/c/newt.c | 359 -- pkg/hair/notes/c/pier.c | 2143 ------------ pkg/hair/notes/c/reck.c | 482 --- pkg/hair/notes/c/save.c | 66 - pkg/hair/notes/c/term.c | 1342 -------- pkg/hair/notes/c/time.c | 179 - pkg/hair/notes/c/unix.c | 1333 -------- pkg/hair/notes/c/walk.c | 334 -- pkg/hair/notes/c/worker.c | 947 ------ pkg/{hair => hs-hoon}/.gitignore | 0 .../lib/Language/Attila/AST/Parser.hs | 0 .../lib/Language/Attila/AST/Types.hs | 0 .../lib/Language/Attila/IR.hs | 0 .../lib/Language/Hoon/AST/Parser.hs | 0 .../lib/Language/Hoon/AST/Types.hs | 0 .../lib/Language/Hoon/Desugar.hs | 0 .../lib/Language/Hoon/IR/Desugar.hs | 0 .../lib/Language/Hoon/IR/Infer.hs | 0 .../lib/Language/Hoon/IR/Ty.hs | 0 .../lib/Language/Hoon/IR/Wing.hs | 0 .../lib/Language/Hoon/LL/Gen.hs | 0 .../lib/Language/Hoon/LL/Run.hs | 0 .../lib/Language/Hoon/LL/Types.hs | 0 .../lib/Language/Hoon/Nock/Types.hs | 0 .../lib/Language/Hoon/SpecToBunt.hs | 0 .../lib/Language/Hoon/SpecToMold.hs | 0 .../lib/Language/Hoon/Types.hs | 0 pkg/{hoon => hs-hoon}/package.yaml | 0 pkg/{hoon => hs-urbit}/.gitignore | 0 pkg/{hair => hs-urbit}/lib/Arvo.hs | 0 pkg/{hair => hs-urbit}/lib/Data/Noun.hs | 0 pkg/{hair => hs-urbit}/lib/Data/Noun/Atom.hs | 0 pkg/{hair => hs-urbit}/lib/Data/Noun/Jam.hs | 0 .../lib/Data/Noun/Jam/Fast.hs | 0 pkg/{hair => hs-urbit}/lib/Data/Noun/Pill.hs | 0 pkg/{hair => hs-urbit}/lib/Data/Noun/Poet.hs | 0 pkg/{hair => hs-urbit}/lib/Data/Noun/Zip.hs | 0 pkg/{hair => hs-urbit}/lib/NockRTS/Noun.hs | 0 pkg/{hair => hs-urbit}/lib/Urbit/Behn.hs | 0 pkg/{hair => hs-urbit}/lib/Urbit/CTTP.hs | 0 pkg/{hair => hs-urbit}/lib/Urbit/Time.hs | 0 pkg/{hair => hs-urbit}/lib/Urbit/Timer.hs | 0 pkg/{hair => hs-urbit}/lib/Vere.hs | 0 pkg/{hair => hs-urbit}/lib/Vere/Http.hs | 0 .../lib/Vere/Http/Client.hs | 0 .../lib/Vere/Http/Server.hs | 0 pkg/{hair => hs-urbit}/lib/Vere/Isle.hs | 0 pkg/{hair => hs-urbit}/lib/Vere/Isle/Util.hs | 0 pkg/{hair => hs-urbit}/lib/Vere/Log.hs | 0 pkg/{hair => hs-urbit}/lib/Vere/Pier.hs | 0 pkg/{hair => hs-urbit}/lib/Vere/Pier/Types.hs | 0 pkg/{hair => hs-urbit}/lib/Vere/Worker.hs | 0 pkg/hs-urbit/package.yaml | 90 + pkg/hs-vere/.gitignore | 2 + pkg/{hair => hs-vere}/app/test/Main.hs | 0 pkg/{hair => hs-vere}/app/uterm/Main.hs | 0 pkg/{hair => hs-vere}/app/vere/Main.hs | 0 pkg/{hair => hs-vere}/package.yaml | 13 +- stack.yaml | 16 +- 71 files changed, 103 insertions(+), 14351 deletions(-) delete mode 100644 pkg/hair/notes/BehnSketch.hs.txt delete mode 100644 pkg/hair/notes/Sketch.hs.txt delete mode 100644 pkg/hair/notes/c/ames.c delete mode 100644 pkg/hair/notes/c/behn.c delete mode 100644 pkg/hair/notes/c/cttp.c delete mode 100644 pkg/hair/notes/c/daemon.c delete mode 100644 pkg/hair/notes/c/dawn.c delete mode 100644 pkg/hair/notes/c/foil.c delete mode 100644 pkg/hair/notes/c/hash_tests.c delete mode 100644 pkg/hair/notes/c/hashtable_tests.c delete mode 100644 pkg/hair/notes/c/http.c delete mode 100644 pkg/hair/notes/c/lmdb.c delete mode 100644 pkg/hair/notes/c/newt.c delete mode 100644 pkg/hair/notes/c/pier.c delete mode 100644 pkg/hair/notes/c/reck.c delete mode 100644 pkg/hair/notes/c/save.c delete mode 100644 pkg/hair/notes/c/term.c delete mode 100644 pkg/hair/notes/c/time.c delete mode 100644 pkg/hair/notes/c/unix.c delete mode 100644 pkg/hair/notes/c/walk.c delete mode 100644 pkg/hair/notes/c/worker.c rename pkg/{hair => hs-hoon}/.gitignore (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Attila/AST/Parser.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Attila/AST/Types.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Attila/IR.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/AST/Parser.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/AST/Types.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/Desugar.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/IR/Desugar.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/IR/Infer.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/IR/Ty.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/IR/Wing.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/LL/Gen.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/LL/Run.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/LL/Types.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/Nock/Types.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/SpecToBunt.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/SpecToMold.hs (100%) rename pkg/{hoon => hs-hoon}/lib/Language/Hoon/Types.hs (100%) rename pkg/{hoon => hs-hoon}/package.yaml (100%) rename pkg/{hoon => hs-urbit}/.gitignore (100%) rename pkg/{hair => hs-urbit}/lib/Arvo.hs (100%) rename pkg/{hair => hs-urbit}/lib/Data/Noun.hs (100%) rename pkg/{hair => hs-urbit}/lib/Data/Noun/Atom.hs (100%) rename pkg/{hair => hs-urbit}/lib/Data/Noun/Jam.hs (100%) rename pkg/{hair => hs-urbit}/lib/Data/Noun/Jam/Fast.hs (100%) rename pkg/{hair => hs-urbit}/lib/Data/Noun/Pill.hs (100%) rename pkg/{hair => hs-urbit}/lib/Data/Noun/Poet.hs (100%) rename pkg/{hair => hs-urbit}/lib/Data/Noun/Zip.hs (100%) rename pkg/{hair => hs-urbit}/lib/NockRTS/Noun.hs (100%) rename pkg/{hair => hs-urbit}/lib/Urbit/Behn.hs (100%) rename pkg/{hair => hs-urbit}/lib/Urbit/CTTP.hs (100%) rename pkg/{hair => hs-urbit}/lib/Urbit/Time.hs (100%) rename pkg/{hair => hs-urbit}/lib/Urbit/Timer.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Http.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Http/Client.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Http/Server.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Isle.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Isle/Util.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Log.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Pier.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Pier/Types.hs (100%) rename pkg/{hair => hs-urbit}/lib/Vere/Worker.hs (100%) create mode 100644 pkg/hs-urbit/package.yaml create mode 100644 pkg/hs-vere/.gitignore rename pkg/{hair => hs-vere}/app/test/Main.hs (100%) rename pkg/{hair => hs-vere}/app/uterm/Main.hs (100%) rename pkg/{hair => hs-vere}/app/vere/Main.hs (100%) rename pkg/{hair => hs-vere}/package.yaml (91%) diff --git a/pkg/hair/notes/BehnSketch.hs.txt b/pkg/hair/notes/BehnSketch.hs.txt deleted file mode 100644 index 1fb89ccfc..000000000 --- a/pkg/hair/notes/BehnSketch.hs.txt +++ /dev/null @@ -1,184 +0,0 @@ -{- - TODO When is `u3_behn_io_init` called? --} - -data Pier -data Timer - -data Wen = Wen Noun Noun Noun - -data TimeVal = TimeVal - { tv_sec :: time_t -- seconds - , tv_usec :: suseconds_t -- microseconds - } - -data Event - = Wake - | Born - -data Wire - = Blip -- Empty path - | Behn - | Sen Text -- "an instance string" - -newtype Knot = Knot Text - -newtype Wire = Wire [Knot] - -data Duct = [Wire] - -data Blip = Blip Behn (Maybe Void) - - -{- - alm -- is timer active? - tim -- timer - data -- associated pier --} -data Behn = Behn - { _alm :: TVar Bool - , _tim :: TVar Timer - , _data :: TVar Pier - } - -makeLenses ''Behn - --------------------------------------------------------------------------------- - -newTimer :: IO Timer -newTimer = undefined - -init :: Pier -> IO () -init p = - timer <- newTimer - atomically $ do - writeTVar (p ^. teh.alm) False - writeTVar (p ^. teh.tim) timer - writeTVar (p ^. teh.data) p - -exit :: Pier -> IO () -exit _ = pure () - -doze :: Pier -> Maybe Wen -> IO () -doze pir mWen = do - (active, timer) <- do - (,) <$> readTVarIO (pir ^. teh.alm) - <*> readTVarIO (pir ^. teh.tim) - - if active - then stopTimer timer -- TODO Race condition - else pure () - - case mWen of - Nothing -> pure () - Just (Wen x y z) -> do - timeVal <- getTimeOfDay - let now = u3_time_in_tv timeVal - let gap = u3_time_gap_ms(y, z) - writeTVar (p ^. teh.alm) True - startTimer timer gap $ do - u3_pier *pir_u = tim_u->data; - u3_behn* teh_u = pir_u->teh_u; - writeTVar (p ^. teh.alm) False; - pierWork pir [Blip Behn] Wake - -bake :: Pier -> IO () -bake = do - sen <- readTVarIO (u3A ^. sen) - pierWork pir [Blip Behn (Sen sen)] Born - -/* u3_behn_ef_bake(): notify %behn that we're live -*/ -void -u3_behn_ef_bake(u3_pier *pir_u) -{ - u3_noun pax = u3nq(u3_blip, c3__behn, u3k(u3A->sen), u3_nul); - - u3_pier_work(pir_u, pax, u3nc(c3__born, u3_nul)); -} - - -{- - u3_time_in_tv timeVal - u3_time_gap_ms(y, z) - u3nt(u3_blip, c3__behn, u3_nul), - u3nc(c3__wake, u3_nul)); --} - - --------------------------------------------------------------------------------- - -/* u3_behn(): initialize time timer. -*/ -void -u3_behn_io_init(u3_pier *pir_u) -{ - u3_behn* teh_u = pir_u->teh_u; - teh_u->alm = c3n; - - uv_timer_init(u3L, &teh_u->tim_u); - teh_u->tim_u.data = pir_u; -} - -/* u3_behn_io_exit(): terminate timer. -*/ -void -u3_behn_io_exit(u3_pier *pir_u) -{ -} - -/* _behn_time_cb(): timer callback. -*/ -static void -_behn_time_cb(uv_timer_t* tim_u) -{ - u3_pier *pir_u = tim_u->data; - u3_behn* teh_u = pir_u->teh_u; - teh_u->alm = c3n; - - { - u3_pier_work - (pir_u, - u3nt(u3_blip, c3__behn, u3_nul), - u3nc(c3__wake, u3_nul)); - } -} - -/* u3_behn_ef_doze(): set or cancel timer -*/ -void -u3_behn_ef_doze(u3_pier *pir_u, u3_noun wen) -{ - u3_behn* teh_u = pir_u->teh_u; - - if ( c3y == teh_u->alm ) { - uv_timer_stop(&teh_u->tim_u); - teh_u->alm = c3n; - } - - if ( (u3_nul != wen) && - (c3y == u3du(wen)) && - (c3y == u3ud(u3t(wen))) ) - { - struct timeval tim_tv; - gettimeofday(&tim_tv, 0); - - u3_noun now = u3_time_in_tv(&tim_tv); - c3_d gap_d = u3_time_gap_ms(now, u3k(u3t(wen))); - - teh_u->alm = c3y; - uv_timer_start(&teh_u->tim_u, _behn_time_cb, gap_d, 0); - } - - u3z(wen); -} - -/* u3_behn_ef_bake(): notify %behn that we're live -*/ -void -u3_behn_ef_bake(u3_pier *pir_u) -{ - u3_noun pax = u3nq(u3_blip, c3__behn, u3k(u3A->sen), u3_nul); - - u3_pier_work(pir_u, pax, u3nc(c3__born, u3_nul)); -} diff --git a/pkg/hair/notes/Sketch.hs.txt b/pkg/hair/notes/Sketch.hs.txt deleted file mode 100644 index 96a6d9ffc..000000000 --- a/pkg/hair/notes/Sketch.hs.txt +++ /dev/null @@ -1,65 +0,0 @@ -module Main where - -import ClassyPrelude hiding (atomically, newTVarIO) -import Control.Lens -import Control.Concurrent -import Control.Concurrent.STM -import Control.Concurrent.STM.TBMQueue - --------------------------------------------------------------------------------- - -newtype Cpu st ev fx = Cpu { runCpu :: st -> ev -> (st, fx) } - -data CpuApi ev st fx = CpuApi - { caHalt :: IO () - , caInput :: TBMQueue ev - , caOutput :: TBMQueue (st, fx) - } - --------------------------------------------------------------------------------- - -dummyCpu :: Cpu () () () -dummyCpu = Cpu $ (\() () -> ((), ())) - -runCpuIO :: Cpu st ev fx - -> TVar st - -> TBMQueue ev - -> TBMQueue (st, fx) - -> IO () -runCpuIO cpu vSt inp out = - forever $ atomically $ do - ev <- readTBMQueue inp >>= maybe (error "No more input") pure - st <- readTVar vSt - runCpu cpu st ev & \(st', fx) -> do - writeTVar vSt st' - writeTBMQueue out (st', fx) - -runCpuThread :: Cpu st ev fx - -> st - -> IO (CpuApi ev st fx) -runCpuThread cpu init = do - inp <- newTBMQueueIO 1 - out <- newTBMQueueIO 16 - vSt <- newTVarIO init - tid <- forkIO (runCpuIO cpu vSt inp out) - - let kill = do atomically (closeTBMQueue inp >> closeTBMQueue out) - killThread tid - - pure (CpuApi kill inp out) - --------------------------------------------------------------------------------- - -{- - - When an event comes in: - - process the event - - persist the event - - run the effects - - - Take a snapshot at any time. --} - -main :: IO () -main = do - cpuProc <- runCpuThread dummyCpu () - caHalt cpuProc diff --git a/pkg/hair/notes/c/ames.c b/pkg/hair/notes/c/ames.c deleted file mode 100644 index a7c2540be..000000000 --- a/pkg/hair/notes/c/ames.c +++ /dev/null @@ -1,563 +0,0 @@ -/* vere/ames.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -/* _ames_alloc(): libuv buffer allocator. -*/ -static void -_ames_alloc(uv_handle_t* had_u, - size_t len_i, - uv_buf_t* buf - ) -{ - // we allocate 2K, which gives us plenty of space - // for a single ames packet (max size 1060 bytes) - // - void* ptr_v = c3_malloc(2048); - *buf = uv_buf_init(ptr_v, 2048); -} - -/* _ames_free(): contrasting free. -*/ -static void -_ames_free(void* ptr_v) -{ -// u3l_log("free %p\n", ptr_v); - free(ptr_v); -} - -/* _ames_pact_free(): free packet struct. -*/ -static void -_ames_pact_free(u3_pact* pac_u) -{ - free(pac_u->hun_y); - free(pac_u->dns_c); - free(pac_u); -} - -/* _ames_send_cb(): send callback. -*/ -static void -_ames_send_cb(uv_udp_send_t* req_u, c3_i sas_i) -{ - u3_pact* pac_u = (u3_pact*)req_u; - -#if 0 - if ( 0 != sas_i ) { - u3l_log("ames: send_cb: %s\n", uv_strerror(sas_i)); - } -#endif - - _ames_pact_free(pac_u); -} - -/* _ames_send(): send buffer to address on port. -*/ -static void -_ames_send(u3_pact* pac_u) -{ - // XX revisit - u3_pier* pir_u = u3_pier_stub(); - u3_ames* sam_u = pir_u->sam_u; - - if ( !pac_u->hun_y ) { - _ames_pact_free(pac_u); - return; - } - - struct sockaddr_in add_u; - - memset(&add_u, 0, sizeof(add_u)); - add_u.sin_family = AF_INET; - add_u.sin_addr.s_addr = htonl(pac_u->pip_w); - add_u.sin_port = htons(pac_u->por_s); - - uv_buf_t buf_u = uv_buf_init((c3_c*)pac_u->hun_y, pac_u->len_w); - - c3_i sas_i; - - if ( 0 != (sas_i = uv_udp_send(&pac_u->snd_u, - &sam_u->wax_u, - &buf_u, 1, - (const struct sockaddr*)&add_u, - _ames_send_cb)) ) { - u3l_log("ames: send: %s\n", uv_strerror(sas_i)); - } -} - -/* _ames_czar_port(): udp port for galaxy. -*/ -static c3_s -_ames_czar_port(c3_y imp_y) -{ - if ( c3n == u3_Host.ops_u.net ) { - return 31337 + imp_y; - } - else { - return 13337 + imp_y; - } -} - -/* _ames_czar_gone(): galaxy address resolution failed. -*/ -static void -_ames_czar_gone(u3_pact* pac_u, time_t now) -{ - // XX revisit - u3_pier* pir_u = u3_pier_stub(); - u3_ames* sam_u = pir_u->sam_u; - - u3l_log("ames: czar at %s: not found (b)\n", pac_u->dns_c); - if ( (0 == sam_u->imp_w[pac_u->imp_y]) || - (0xffffffff == sam_u->imp_w[pac_u->imp_y]) ) { - sam_u->imp_w[pac_u->imp_y] = 0xffffffff; - } /* else keep existing ip for 5 more minutes */ - sam_u->imp_t[pac_u->imp_y] = now; - - _ames_pact_free(pac_u); -} - -/* _ames_czar_cb(): galaxy address resolution callback. -*/ -static void -_ames_czar_cb(uv_getaddrinfo_t* adr_u, - c3_i sas_i, - struct addrinfo* aif_u) -{ - // XX revisit - u3_pier* pir_u = u3_pier_stub(); - u3_ames* sam_u = pir_u->sam_u; - - u3_pact* pac_u = (u3_pact*)adr_u->data; - time_t now = time(0); - - struct addrinfo* rai_u = aif_u; - - while ( 1 ) { - if ( !rai_u ) { - _ames_czar_gone(pac_u, now); - break; - } - - if ( (AF_INET == rai_u->ai_family) ) { - struct sockaddr_in* add_u = (struct sockaddr_in *)rai_u->ai_addr; - c3_w old_w = sam_u->imp_w[pac_u->imp_y]; - - sam_u->imp_w[pac_u->imp_y] = ntohl(add_u->sin_addr.s_addr); - sam_u->imp_t[pac_u->imp_y] = now; - -#if 1 - if ( sam_u->imp_w[pac_u->imp_y] != old_w - && sam_u->imp_w[pac_u->imp_y] != 0xffffffff ) { - u3_noun wad = u3i_words(1, &sam_u->imp_w[pac_u->imp_y]); - u3_noun nam = u3dc("scot", c3__if, wad); - c3_c* nam_c = u3r_string(nam); - - u3l_log("ames: czar %s: ip %s\n", pac_u->dns_c, nam_c); - - free(nam_c); u3z(nam); - } -#endif - - _ames_send(pac_u); - break; - } - - rai_u = rai_u->ai_next; - } - - free(adr_u); - uv_freeaddrinfo(aif_u); -} - - -/* _ames_czar(): galaxy address resolution. -*/ -static void -_ames_czar(u3_pact* pac_u, c3_c* bos_c) -{ - // XX revisit - u3_pier* pir_u = u3_pier_stub(); - u3_ames* sam_u = pir_u->sam_u; - - pac_u->por_s = _ames_czar_port(pac_u->imp_y); - - if ( c3n == u3_Host.ops_u.net ) { - pac_u->pip_w = 0x7f000001; - _ames_send(pac_u); - return; - } - - // if we don't have a galaxy domain, no-op - // - if ( 0 == bos_c ) { - u3_noun nam = u3dc("scot", 'p', pac_u->imp_y); - c3_c* nam_c = u3r_string(nam); - u3l_log("ames: no galaxy domain for %s, no-op\r\n", nam_c); - - free(nam_c); - u3z(nam); - return; - } - - time_t now = time(0); - - // backoff - if ( (0xffffffff == sam_u->imp_w[pac_u->imp_y]) && - (now - sam_u->imp_t[pac_u->imp_y]) < 300 ) { - _ames_pact_free(pac_u); - return; - } - - if ( (0 == sam_u->imp_w[pac_u->imp_y]) || - (now - sam_u->imp_t[pac_u->imp_y]) > 300 ) { /* 5 minute TTL */ - u3_noun nam = u3dc("scot", 'p', pac_u->imp_y); - c3_c* nam_c = u3r_string(nam); - // XX remove extra byte for '~' - pac_u->dns_c = c3_malloc(1 + strlen(bos_c) + 1 + strlen(nam_c)); - - snprintf(pac_u->dns_c, 256, "%s.%s", nam_c + 1, bos_c); - // u3l_log("czar %s, dns %s\n", nam_c, pac_u->dns_c); - - free(nam_c); - u3z(nam); - - { - uv_getaddrinfo_t* adr_u = c3_malloc(sizeof(*adr_u)); - adr_u->data = pac_u; - - c3_i sas_i; - - if ( 0 != (sas_i = uv_getaddrinfo(u3L, adr_u, - _ames_czar_cb, - pac_u->dns_c, 0, 0)) ) { - u3l_log("ames: %s\n", uv_strerror(sas_i)); - _ames_czar_gone(pac_u, now); - return; - } - } - } - else { - pac_u->pip_w = sam_u->imp_w[pac_u->imp_y]; - _ames_send(pac_u); - return; - } -} - -/* _ames_lane_ipv4(): IPv4 address/ from lane. -*/ -u3_noun -_ames_lane_ip(u3_noun lan, c3_s* por_s, c3_w* pip_w) -{ - switch ( u3h(lan) ) { - case c3__if: { - *por_s= (c3_s) u3h(u3t(u3t(lan))); - *pip_w = u3r_word(0, u3t(u3t(u3t(lan)))); - - return c3y; - } break; - case c3__is: { - u3_noun pq_lan = u3h(u3t(u3t(lan))); - - if ( u3_nul == pq_lan ) return c3n; - else return _ames_lane_ip(u3t(pq_lan), por_s, pip_w); - } break; - case c3__ix: { - *por_s = (c3_s) u3h(u3t(u3t(lan))); - *pip_w = u3r_word(0, u3t(u3t(u3t(lan)))); - - return c3y; - } break; - } - return c3n; -} - -/* u3_ames_ef_bake(): notify %ames that we're live. -*/ -void -u3_ames_ef_bake(u3_pier* pir_u) -{ - u3_noun pax = u3nq(u3_blip, c3__newt, u3k(u3A->sen), u3_nul); - - u3_pier_plan(pax, u3nc(c3__barn, u3_nul)); -} - -/* u3_ames_ef_send(): send packet to network (v4). -*/ -void -u3_ames_ef_send(u3_pier* pir_u, u3_noun lan, u3_noun pac) -{ - u3_ames* sam_u = pir_u->sam_u; - - if ( u3_Host.ops_u.fuz_w && ((rand() % 100) < u3_Host.ops_u.fuz_w) ) { - u3z(lan); u3z(pac); - return; - } - - u3_pact* pac_u = c3_calloc(sizeof(*pac_u)); - - if ( c3y == _ames_lane_ip(lan, &pac_u->por_s, &pac_u->pip_w) ) { - pac_u->len_w = u3r_met(3, pac); - pac_u->hun_y = c3_malloc(pac_u->len_w); - - u3r_bytes(0, pac_u->len_w, pac_u->hun_y, pac); - - if ( 0 == pac_u->pip_w ) { - pac_u->pip_w = 0x7f000001; - pac_u->por_s = pir_u->por_s; - } - - if ( (0 == (pac_u->pip_w >> 16)) && (1 == (pac_u->pip_w >> 8)) ) { - pac_u->imp_y = (pac_u->pip_w & 0xff); - - _ames_czar(pac_u, sam_u->dns_c); - } - else if ( (c3y == u3_Host.ops_u.net) || (0x7f000001 == pac_u->pip_w) ) { - _ames_send(pac_u); - } - else { - // networking disabled - _ames_pact_free(pac_u); - } - } - else { - _ames_pact_free(pac_u); - } - - u3z(lan); u3z(pac); -} - -/* _ames_recv_cb(): receive callback. -*/ -static void -_ames_recv_cb(uv_udp_t* wax_u, - ssize_t nrd_i, - const uv_buf_t * buf_u, - const struct sockaddr* adr_u, - unsigned flg_i) -{ - // u3l_log("ames: rx %p\r\n", buf_u.base); - - if ( 0 == nrd_i ) { - _ames_free(buf_u->base); - } - else { - { - u3_noun msg = u3i_bytes((c3_w)nrd_i, (c3_y*)buf_u->base); - - // u3l_log("ames: plan\r\n"); -#if 0 - u3z(msg); -#else - struct sockaddr_in* add_u = (struct sockaddr_in *)adr_u; - c3_s por_s = ntohs(add_u->sin_port); - c3_w pip_w = ntohl(add_u->sin_addr.s_addr); - - u3_pier_plan - (u3nt(u3_blip, c3__ames, u3_nul), - u3nt(c3__hear, - u3nq(c3__if, u3k(u3A->now), por_s, u3i_words(1, &pip_w)), - msg)); -#endif - } - _ames_free(buf_u->base); - } -} - -/* _ames_io_start(): initialize ames I/O. -*/ -static void -_ames_io_start(u3_pier* pir_u) -{ - u3_ames* sam_u = pir_u->sam_u; - c3_s por_s = pir_u->por_s; - u3_noun who = u3i_chubs(2, pir_u->who_d); - u3_noun rac = u3do("clan:title", u3k(who)); - - if ( c3__czar == rac ) { - u3_noun imp = u3dc("scot", 'p', u3k(who)); - c3_c* imp_c = u3r_string(imp); - c3_y num_y = (c3_y)pir_u->who_d[0]; - - por_s = _ames_czar_port(num_y); - - if ( c3y == u3_Host.ops_u.net ) { - u3l_log("ames: czar: %s on %d\n", imp_c, por_s); - } - else { - u3l_log("ames: czar: %s on %d (localhost only)\n", imp_c, por_s); - } - - u3z(imp); - free(imp_c); - } - - int ret; - if ( 0 != (ret = uv_udp_init(u3L, &sam_u->wax_u)) ) { - u3l_log("ames: init: %s\n", uv_strerror(ret)); - c3_assert(0); - } - - // Bind and stuff. - { - struct sockaddr_in add_u; - c3_i add_i = sizeof(add_u); - - memset(&add_u, 0, sizeof(add_u)); - add_u.sin_family = AF_INET; - add_u.sin_addr.s_addr = _(u3_Host.ops_u.net) ? - htonl(INADDR_ANY) : - htonl(INADDR_LOOPBACK); - add_u.sin_port = htons(por_s); - - int ret; - if ( (ret = uv_udp_bind(&sam_u->wax_u, - (const struct sockaddr*) & add_u, 0)) != 0 ) { - u3l_log("ames: bind: %s\n", - uv_strerror(ret)); - if (UV_EADDRINUSE == ret){ - u3l_log(" ...perhaps you've got two copies of vere running?\n"); - } - u3_pier_exit(pir_u); - } - - uv_udp_getsockname(&sam_u->wax_u, (struct sockaddr *)&add_u, &add_i); - c3_assert(add_u.sin_port); - - sam_u->por_s = ntohs(add_u.sin_port); - } - - // u3l_log("ames: on localhost, UDP %d.\n", sam_u->por_s); - uv_udp_recv_start(&sam_u->wax_u, _ames_alloc, _ames_recv_cb); - - sam_u->liv = c3y; - u3z(rac); - u3z(who); -} - -/* _cttp_mcut_char(): measure/cut character. -*/ -static c3_w -_cttp_mcut_char(c3_c* buf_c, c3_w len_w, c3_c chr_c) -{ - if ( buf_c ) { - buf_c[len_w] = chr_c; - } - return len_w + 1; -} - -/* _cttp_mcut_cord(): measure/cut cord. -*/ -static c3_w -_cttp_mcut_cord(c3_c* buf_c, c3_w len_w, u3_noun san) -{ - c3_w ten_w = u3r_met(3, san); - - if ( buf_c ) { - u3r_bytes(0, ten_w, (c3_y *)(buf_c + len_w), san); - } - u3z(san); - return (len_w + ten_w); -} - -/* _cttp_mcut_path(): measure/cut cord list. -*/ -static c3_w -_cttp_mcut_path(c3_c* buf_c, c3_w len_w, c3_c sep_c, u3_noun pax) -{ - u3_noun axp = pax; - - while ( u3_nul != axp ) { - u3_noun h_axp = u3h(axp); - - len_w = _cttp_mcut_cord(buf_c, len_w, u3k(h_axp)); - axp = u3t(axp); - - if ( u3_nul != axp ) { - len_w = _cttp_mcut_char(buf_c, len_w, sep_c); - } - } - u3z(pax); - return len_w; -} - -/* _cttp_mcut_host(): measure/cut host. -*/ -static c3_w -_cttp_mcut_host(c3_c* buf_c, c3_w len_w, u3_noun hot) -{ - len_w = _cttp_mcut_path(buf_c, len_w, '.', u3kb_flop(u3k(hot))); - u3z(hot); - return len_w; -} - -/* u3_ames_ef_turf(): initialize ames I/O on domain(s). -*/ -void -u3_ames_ef_turf(u3_pier* pir_u, u3_noun tuf) -{ - u3_ames* sam_u = pir_u->sam_u; - - if ( u3_nul != tuf ) { - // XX save all for fallback, not just first - u3_noun hot = u3k(u3h(tuf)); - c3_w len_w = _cttp_mcut_host(0, 0, u3k(hot)); - - sam_u->dns_c = c3_malloc(1 + len_w); - _cttp_mcut_host(sam_u->dns_c, 0, hot); - sam_u->dns_c[len_w] = 0; - - u3z(tuf); - } - else if ( (c3n == pir_u->fak_o) && (0 == sam_u->dns_c) ) { - u3l_log("ames: turf: no domains\n"); - } - - if ( c3n == sam_u->liv ) { - _ames_io_start(pir_u); - } -} - -/* u3_ames_io_init(): initialize ames I/O. -*/ -void -u3_ames_io_init(u3_pier* pir_u) -{ - u3_ames* sam_u = pir_u->sam_u; - sam_u->liv = c3n; -} - -/* u3_ames_io_talk(): start receiving ames traffic. -*/ -void -u3_ames_io_talk(u3_pier* pir_u) -{ -} - -/* u3_ames_io_exit(): terminate ames I/O. -*/ -void -u3_ames_io_exit(u3_pier* pir_u) -{ - u3_ames* sam_u = pir_u->sam_u; - - if ( c3y == sam_u->liv ) { - // XX remove had_u/wax_u union, cast and close wax_u - uv_close(&sam_u->had_u, 0); - } -} diff --git a/pkg/hair/notes/c/behn.c b/pkg/hair/notes/c/behn.c deleted file mode 100644 index 6da833eab..000000000 --- a/pkg/hair/notes/c/behn.c +++ /dev/null @@ -1,90 +0,0 @@ -/* vere/behn.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -/* u3_behn(): initialize time timer. -*/ -void -u3_behn_io_init(u3_pier *pir_u) -{ - u3_behn* teh_u = pir_u->teh_u; - teh_u->alm = c3n; - - uv_timer_init(u3L, &teh_u->tim_u); - teh_u->tim_u.data = pir_u; -} - -/* u3_behn_io_exit(): terminate timer. -*/ -void -u3_behn_io_exit(u3_pier *pir_u) -{ -} - -/* _behn_time_cb(): timer callback. -*/ -static void -_behn_time_cb(uv_timer_t* tim_u) -{ - u3_pier *pir_u = tim_u->data; - u3_behn* teh_u = pir_u->teh_u; - teh_u->alm = c3n; - - { - u3_pier_work - (pir_u, - u3nt(u3_blip, c3__behn, u3_nul), - u3nc(c3__wake, u3_nul)); - } -} - -/* u3_behn_ef_doze(): set or cancel timer -*/ -void -u3_behn_ef_doze(u3_pier *pir_u, u3_noun wen) -{ - u3_behn* teh_u = pir_u->teh_u; - - if ( c3y == teh_u->alm ) { - uv_timer_stop(&teh_u->tim_u); - teh_u->alm = c3n; - } - - if ( (u3_nul != wen) && - (c3y == u3du(wen)) && - (c3y == u3ud(u3t(wen))) ) - { - struct timeval tim_tv; - gettimeofday(&tim_tv, 0); - - u3_noun now = u3_time_in_tv(&tim_tv); - c3_d gap_d = u3_time_gap_ms(now, u3k(u3t(wen))); - - teh_u->alm = c3y; - uv_timer_start(&teh_u->tim_u, _behn_time_cb, gap_d, 0); - } - - u3z(wen); -} - -/* u3_behn_ef_bake(): notify %behn that we're live -*/ -void -u3_behn_ef_bake(u3_pier *pir_u) -{ - u3_noun pax = u3nq(u3_blip, c3__behn, u3k(u3A->sen), u3_nul); - - u3_pier_work(pir_u, pax, u3nc(c3__born, u3_nul)); -} diff --git a/pkg/hair/notes/c/cttp.c b/pkg/hair/notes/c/cttp.c deleted file mode 100644 index 36ff32440..000000000 --- a/pkg/hair/notes/c/cttp.c +++ /dev/null @@ -1,989 +0,0 @@ -/* vere/cttp.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - - -// XX deduplicate with _http_vec_to_atom -/* _cttp_vec_to_atom(): convert h2o_iovec_t to atom (cord) -*/ -static u3_noun -_cttp_vec_to_atom(h2o_iovec_t vec_u) -{ - return u3i_bytes(vec_u.len, (const c3_y*)vec_u.base); -} - -/* _cttp_bods_free(): free body structure. -*/ -static void -_cttp_bods_free(u3_hbod* bod_u) -{ - while ( bod_u ) { - u3_hbod* nex_u = bod_u->nex_u; - - free(bod_u); - bod_u = nex_u; - } -} - -/* _cttp_bod_new(): create a data buffer -*/ -static u3_hbod* -_cttp_bod_new(c3_w len_w, c3_c* hun_c) -{ - u3_hbod* bod_u = c3_malloc(1 + len_w + sizeof(*bod_u)); - bod_u->hun_y[len_w] = 0; - bod_u->len_w = len_w; - memcpy(bod_u->hun_y, (const c3_y*)hun_c, len_w); - - bod_u->nex_u = 0; - return bod_u; -} - -/* _cttp_bod_from_hed(): create a data buffer from a header -*/ -static u3_hbod* -_cttp_bod_from_hed(u3_hhed* hed_u) -{ - c3_w len_w = hed_u->nam_w + 2 + hed_u->val_w + 2; - u3_hbod* bod_u = c3_malloc(1 + len_w + sizeof(*bod_u)); - bod_u->hun_y[len_w] = 0; - - memcpy(bod_u->hun_y, hed_u->nam_c, hed_u->nam_w); - memcpy(bod_u->hun_y + hed_u->nam_w, ": ", 2); - memcpy(bod_u->hun_y + hed_u->nam_w + 2, hed_u->val_c, hed_u->val_w); - memcpy(bod_u->hun_y + hed_u->nam_w + 2 + hed_u->val_w, "\r\n", 2); - - bod_u->len_w = len_w; - bod_u->nex_u = 0; - - return bod_u; -} - -/* _cttp_bods_to_octs: translate body buffer into octet-stream noun. -*/ -static u3_noun -_cttp_bods_to_octs(u3_hbod* bod_u) -{ - c3_w len_w; - c3_y* buf_y; - u3_noun cos; - - { - u3_hbod* bid_u = bod_u; - - len_w = 0; - while ( bid_u ) { - len_w += bid_u->len_w; - bid_u = bid_u->nex_u; - } - } - buf_y = c3_malloc(1 + len_w); - buf_y[len_w] = 0; - - { - c3_y* ptr_y = buf_y; - - while ( bod_u ) { - memcpy(ptr_y, bod_u->hun_y, bod_u->len_w); - ptr_y += bod_u->len_w; - bod_u = bod_u->nex_u; - } - } - cos = u3i_bytes(len_w, buf_y); - free(buf_y); - return u3nc(len_w, cos); -} - -/* _cttp_bod_from_octs(): translate octet-stream noun into body. -*/ -static u3_hbod* -_cttp_bod_from_octs(u3_noun oct) -{ - c3_w len_w; - - if ( !_(u3a_is_cat(u3h(oct))) ) { // 2GB max - u3m_bail(c3__fail); return 0; - } - len_w = u3h(oct); - - { - u3_hbod* bod_u = c3_malloc(1 + len_w + sizeof(*bod_u)); - bod_u->hun_y[len_w] = 0; - bod_u->len_w = len_w; - u3r_bytes(0, len_w, bod_u->hun_y, u3t(oct)); - - bod_u->nex_u = 0; - - u3z(oct); - return bod_u; - } -} - -/* _cttp_bods_to_vec(): translate body buffers to array of h2o_iovec_t -*/ -static h2o_iovec_t* -_cttp_bods_to_vec(u3_hbod* bod_u, c3_w* tot_w) -{ - h2o_iovec_t* vec_u; - c3_w len_w; - - { - u3_hbod* bid_u = bod_u; - len_w = 0; - - while( bid_u ) { - len_w++; - bid_u = bid_u->nex_u; - } - } - - if ( 0 == len_w ) { - *tot_w = len_w; - return 0; - } - - vec_u = c3_malloc(sizeof(h2o_iovec_t) * len_w); - len_w = 0; - - while( bod_u ) { - vec_u[len_w] = h2o_iovec_init(bod_u->hun_y, bod_u->len_w); - len_w++; - bod_u = bod_u->nex_u; - } - - *tot_w = len_w; - - return vec_u; -} - -// XX deduplicate with _http_heds_free -/* _cttp_heds_free(): free header linked list -*/ -static void -_cttp_heds_free(u3_hhed* hed_u) -{ - while ( hed_u ) { - u3_hhed* nex_u = hed_u->nex_u; - - free(hed_u->nam_c); - free(hed_u->val_c); - free(hed_u); - hed_u = nex_u; - } -} - -// XX deduplicate with _http_hed_new -/* _cttp_hed_new(): create u3_hhed from nam/val cords -*/ -static u3_hhed* -_cttp_hed_new(u3_atom nam, u3_atom val) -{ - c3_w nam_w = u3r_met(3, nam); - c3_w val_w = u3r_met(3, val); - u3_hhed* hed_u = c3_malloc(sizeof(*hed_u)); - - hed_u->nam_c = c3_malloc(1 + nam_w); - hed_u->val_c = c3_malloc(1 + val_w); - hed_u->nam_c[nam_w] = 0; - hed_u->val_c[val_w] = 0; - hed_u->nex_u = 0; - hed_u->nam_w = nam_w; - hed_u->val_w = val_w; - - u3r_bytes(0, nam_w, (c3_y*)hed_u->nam_c, nam); - u3r_bytes(0, val_w, (c3_y*)hed_u->val_c, val); - - return hed_u; -} - -// XX vv similar to _http_heds_from_noun -/* _cttp_heds_math(): create headers from +math -*/ -static u3_hhed* -_cttp_heds_math(u3_noun mah) -{ - u3_noun hed = u3kdi_tap(mah); - u3_noun deh = hed; - - u3_hhed* hed_u = 0; - - while ( u3_nul != hed ) { - u3_noun nam = u3h(u3h(hed)); - u3_noun lit = u3t(u3h(hed)); - - while ( u3_nul != lit ) { - u3_hhed* nex_u = _cttp_hed_new(nam, u3h(lit)); - nex_u->nex_u = hed_u; - - hed_u = nex_u; - lit = u3t(lit); - } - - hed = u3t(hed); - } - - u3z(deh); - return hed_u; -} - -// XX deduplicate with _http_heds_to_noun -/* _cttp_heds_to_noun(): convert h2o_header_t to (list (pair @t @t)) -*/ -static u3_noun -_cttp_heds_to_noun(h2o_header_t* hed_u, c3_d hed_d) -{ - u3_noun hed = u3_nul; - c3_d dex_d = hed_d; - - h2o_header_t deh_u; - - while ( 0 < dex_d ) { - deh_u = hed_u[--dex_d]; - hed = u3nc(u3nc(_cttp_vec_to_atom(*deh_u.name), - _cttp_vec_to_atom(deh_u.value)), hed); - } - - return hed; -} - -/* _cttp_cres_free(): free a u3_cres. -*/ -static void -_cttp_cres_free(u3_cres* res_u) -{ - _cttp_bods_free(res_u->bod_u); - free(res_u); -} - -/* _cttp_cres_new(): create a response -*/ -static void -_cttp_cres_new(u3_creq* ceq_u, c3_w sas_w) -{ - ceq_u->res_u = c3_calloc(sizeof(*ceq_u->res_u)); - ceq_u->res_u->sas_w = sas_w; -} - -/* _cttp_cres_fire_body(): attach response body buffer -*/ -static void -_cttp_cres_fire_body(u3_cres* res_u, u3_hbod* bod_u) -{ - c3_assert(!bod_u->nex_u); - - if ( !(res_u->bod_u) ) { - res_u->bod_u = res_u->dob_u = bod_u; - } - else { - res_u->dob_u->nex_u = bod_u; - res_u->dob_u = bod_u; - } -} - -/* _cttp_mcut_char(): measure/cut character. -*/ -static c3_w -_cttp_mcut_char(c3_c* buf_c, c3_w len_w, c3_c chr_c) -{ - if ( buf_c ) { - buf_c[len_w] = chr_c; - } - return len_w + 1; -} - -/* _cttp_mcut_cord(): measure/cut cord. -*/ -static c3_w -_cttp_mcut_cord(c3_c* buf_c, c3_w len_w, u3_noun san) -{ - c3_w ten_w = u3r_met(3, san); - - if ( buf_c ) { - u3r_bytes(0, ten_w, (c3_y *)(buf_c + len_w), san); - } - u3z(san); - return (len_w + ten_w); -} - -/* _cttp_mcut_path(): measure/cut cord list. -*/ -static c3_w -_cttp_mcut_path(c3_c* buf_c, c3_w len_w, c3_c sep_c, u3_noun pax) -{ - u3_noun axp = pax; - - while ( u3_nul != axp ) { - u3_noun h_axp = u3h(axp); - - len_w = _cttp_mcut_cord(buf_c, len_w, u3k(h_axp)); - axp = u3t(axp); - - if ( u3_nul != axp ) { - len_w = _cttp_mcut_char(buf_c, len_w, sep_c); - } - } - u3z(pax); - return len_w; -} - -/* _cttp_mcut_host(): measure/cut host. -*/ -static c3_w -_cttp_mcut_host(c3_c* buf_c, c3_w len_w, u3_noun hot) -{ - len_w = _cttp_mcut_path(buf_c, len_w, '.', u3kb_flop(u3k(hot))); - u3z(hot); - return len_w; -} - -/* _cttp_mcut_pork(): measure/cut path/extension. -*/ -static c3_w -_cttp_mcut_pork(c3_c* buf_c, c3_w len_w, u3_noun pok) -{ - u3_noun h_pok = u3h(pok); - u3_noun t_pok = u3t(pok); - - len_w = _cttp_mcut_path(buf_c, len_w, '/', u3k(t_pok)); - if ( u3_nul != h_pok ) { - len_w = _cttp_mcut_char(buf_c, len_w, '.'); - len_w = _cttp_mcut_cord(buf_c, len_w, u3k(u3t(h_pok))); - } - u3z(pok); - return len_w; -} - -/* _cttp_mcut_quay(): measure/cut query. -*/ -static c3_w -_cttp_mcut_quay(c3_c* buf_c, c3_w len_w, u3_noun quy) -{ - if ( u3_nul == quy ) { - return len_w; - } - else { - u3_noun i_quy = u3h(quy); - u3_noun pi_quy = u3h(i_quy); - u3_noun qi_quy = u3t(i_quy); - u3_noun t_quy = u3t(quy); - - len_w = _cttp_mcut_char(buf_c, len_w, '&'); - len_w = _cttp_mcut_cord(buf_c, len_w, u3k(pi_quy)); - len_w = _cttp_mcut_char(buf_c, len_w, '='); - len_w = _cttp_mcut_cord(buf_c, len_w, u3k(qi_quy)); - - len_w = _cttp_mcut_quay(buf_c, len_w, u3k(t_quy)); - } - u3z(quy); - return len_w; -} - -/* _cttp_mcut_url(): measure/cut purl, producing relative URL. -*/ -static c3_w -_cttp_mcut_url(c3_c* buf_c, c3_w len_w, u3_noun pul) -{ - u3_noun q_pul = u3h(u3t(pul)); - u3_noun r_pul = u3t(u3t(pul)); - - len_w = _cttp_mcut_char(buf_c, len_w, '/'); - len_w = _cttp_mcut_pork(buf_c, len_w, u3k(q_pul)); - - if ( u3_nul != r_pul ) { - len_w = _cttp_mcut_char(buf_c, len_w, '?'); - len_w = _cttp_mcut_quay(buf_c, len_w, u3k(r_pul)); - } - u3z(pul); - return len_w; -} - -/* _cttp_creq_port(): stringify port -*/ -static c3_c* -_cttp_creq_port(c3_s por_s) -{ - c3_c* por_c = c3_malloc(8); - snprintf(por_c, 7, "%d", 0xffff & por_s); - return por_c; -} - -/* _cttp_creq_url(): construct url from noun. -*/ -static c3_c* -_cttp_creq_url(u3_noun pul) -{ - c3_w len_w = _cttp_mcut_url(0, 0, u3k(pul)); - c3_c* url_c = c3_malloc(1 + len_w); - - _cttp_mcut_url(url_c, 0, pul); - url_c[len_w] = 0; - - return url_c; -} - -/* _cttp_creq_host(): construct host from noun. -*/ -static c3_c* -_cttp_creq_host(u3_noun hot) -{ - c3_w len_w = _cttp_mcut_host(0, 0, u3k(hot)); - c3_c* hot_c = c3_malloc(1 + len_w); - - _cttp_mcut_host(hot_c, 0, hot); - hot_c[len_w] = 0; - - return hot_c; -} - -/* _cttp_creq_ip(): stringify ip -*/ -static c3_c* -_cttp_creq_ip(c3_w ipf_w) -{ - c3_c* ipf_c = c3_malloc(17); - snprintf(ipf_c, 16, "%d.%d.%d.%d", (ipf_w >> 24), - ((ipf_w >> 16) & 255), - ((ipf_w >> 8) & 255), - (ipf_w & 255)); - return ipf_c; -} - -/* _cttp_creq_find(): find a request by number in the client -*/ -static u3_creq* -_cttp_creq_find(c3_l num_l) -{ - u3_creq* ceq_u = u3_Host.ctp_u.ceq_u; - - // XX glories of linear search - // - while ( ceq_u ) { - if ( num_l == ceq_u->num_l ) { - return ceq_u; - } - ceq_u = ceq_u->nex_u; - } - return 0; -} - -/* _cttp_creq_link(): link request to client -*/ -static void -_cttp_creq_link(u3_creq* ceq_u) -{ - ceq_u->nex_u = u3_Host.ctp_u.ceq_u; - - if ( 0 != ceq_u->nex_u ) { - ceq_u->nex_u->pre_u = ceq_u; - } - u3_Host.ctp_u.ceq_u = ceq_u; -} - -/* _cttp_creq_unlink(): unlink request from client -*/ -static void -_cttp_creq_unlink(u3_creq* ceq_u) -{ - if ( ceq_u->pre_u ) { - ceq_u->pre_u->nex_u = ceq_u->nex_u; - - if ( 0 != ceq_u->nex_u ) { - ceq_u->nex_u->pre_u = ceq_u->pre_u; - } - } - else { - u3_Host.ctp_u.ceq_u = ceq_u->nex_u; - - if ( 0 != ceq_u->nex_u ) { - ceq_u->nex_u->pre_u = 0; - } - } -} - -/* _cttp_creq_free(): free a u3_creq. -*/ -static void -_cttp_creq_free(u3_creq* ceq_u) -{ - _cttp_creq_unlink(ceq_u); - - _cttp_heds_free(ceq_u->hed_u); - // Note: ceq_u->bod_u is covered here - _cttp_bods_free(ceq_u->rub_u); - - if ( ceq_u->res_u ) { - _cttp_cres_free(ceq_u->res_u); - } - - free(ceq_u->hot_c); - free(ceq_u->por_c); - free(ceq_u->url_c); - free(ceq_u->vec_u); - free(ceq_u); -} - -/* _cttp_creq_new(): create a request from a +hiss noun -*/ -static u3_creq* -_cttp_creq_new(c3_l num_l, u3_noun hes) -{ - u3_creq* ceq_u = c3_calloc(sizeof(*ceq_u)); - - u3_noun pul = u3h(hes); // +purl - u3_noun hat = u3h(pul); // +hart - u3_noun sec = u3h(hat); - u3_noun por = u3h(u3t(hat)); - u3_noun hot = u3t(u3t(hat)); // +host - u3_noun moh = u3t(hes); // +moth - u3_noun met = u3h(moh); // +meth - u3_noun mah = u3h(u3t(moh)); // +math - u3_noun bod = u3t(u3t(moh)); - - ceq_u->sat_e = u3_csat_init; - ceq_u->num_l = num_l; - ceq_u->sec = sec; - - if ( c3y == u3h(hot) ) { - ceq_u->hot_c = _cttp_creq_host(u3k(u3t(hot))); - } else { - ceq_u->ipf_w = u3r_word(0, u3t(hot)); - ceq_u->ipf_c = _cttp_creq_ip(ceq_u->ipf_w); - } - - if ( u3_nul != por ) { - ceq_u->por_s = u3t(por); - ceq_u->por_c = _cttp_creq_port(ceq_u->por_s); - } - - ceq_u->met_m = met; - ceq_u->url_c = _cttp_creq_url(u3k(pul)); - ceq_u->hed_u = _cttp_heds_math(u3k(mah)); - - if ( u3_nul != bod ) { - ceq_u->bod_u = _cttp_bod_from_octs(u3k(u3t(bod))); - } - - _cttp_creq_link(ceq_u); - - u3z(hes); - return ceq_u; -} - -/* _cttp_creq_fire_body(): attach body to request buffers. -*/ -static void -_cttp_creq_fire_body(u3_creq* ceq_u, u3_hbod *rub_u) -{ - c3_assert(!rub_u->nex_u); - - if ( !(ceq_u->rub_u) ) { - ceq_u->rub_u = ceq_u->bur_u = rub_u; - } - else { - ceq_u->bur_u->nex_u = rub_u; - ceq_u->bur_u = rub_u; - } -} - -/* _cttp_creq_fire_str(): attach string to request buffers. -*/ -static void -_cttp_creq_fire_str(u3_creq* ceq_u, c3_c* str_c) -{ - _cttp_creq_fire_body(ceq_u, _cttp_bod_new(strlen(str_c), str_c)); -} - -/* _cttp_creq_fire_heds(): attach output headers. -*/ -static void -_cttp_creq_fire_heds(u3_creq* ceq_u, u3_hhed* hed_u) -{ - while ( hed_u ) { - _cttp_creq_fire_body(ceq_u, _cttp_bod_from_hed(hed_u)); - hed_u = hed_u->nex_u; - } -} - -/* _cttp_creq_fire(): load request data for into buffers. -*/ -static void -_cttp_creq_fire(u3_creq* ceq_u) -{ - switch ( ceq_u->met_m ) { - default: c3_assert(0); - case c3__get: _cttp_creq_fire_str(ceq_u, "GET "); break; - case c3__put: _cttp_creq_fire_str(ceq_u, "PUT "); break; - case c3__post: _cttp_creq_fire_str(ceq_u, "POST "); break; - case c3__head: _cttp_creq_fire_str(ceq_u, "HEAD "); break; - case c3__conn: _cttp_creq_fire_str(ceq_u, "CONNECT "); break; - case c3__delt: _cttp_creq_fire_str(ceq_u, "DELETE "); break; - case c3__opts: _cttp_creq_fire_str(ceq_u, "OPTIONS "); break; - case c3__trac: _cttp_creq_fire_str(ceq_u, "TRACE "); break; - } - _cttp_creq_fire_str(ceq_u, ceq_u->url_c); - _cttp_creq_fire_str(ceq_u, " HTTP/1.1\r\n"); - - { - c3_c* hot_c = ceq_u->hot_c ? ceq_u->hot_c : ceq_u->ipf_c; - c3_c* hos_c; - c3_w len_w; - - if ( ceq_u->por_c ) { - len_w = 6 + strlen(hot_c) + 1 + strlen(ceq_u->por_c) + 3; - hos_c = c3_malloc(len_w); - len_w = snprintf(hos_c, len_w, "Host: %s:%s\r\n", hot_c, ceq_u->por_c); - } - else { - len_w = 6 + strlen(hot_c) + 3; - hos_c = c3_malloc(len_w); - len_w = snprintf(hos_c, len_w, "Host: %s\r\n", hot_c); - } - - _cttp_creq_fire_body(ceq_u, _cttp_bod_new(len_w, hos_c)); - free(hos_c); - } - - _cttp_creq_fire_heds(ceq_u, ceq_u->hed_u); - - if ( !ceq_u->bod_u ) { - _cttp_creq_fire_body(ceq_u, _cttp_bod_new(2, "\r\n")); - } - else { - c3_c len_c[41]; - c3_w len_w = snprintf(len_c, 40, "Content-Length: %u\r\n\r\n", - ceq_u->bod_u->len_w); - - _cttp_creq_fire_body(ceq_u, _cttp_bod_new(len_w, len_c)); - _cttp_creq_fire_body(ceq_u, ceq_u->bod_u); - } -} - -/* _cttp_creq_quit(): cancel a u3_creq -*/ -static void -_cttp_creq_quit(u3_creq* ceq_u) -{ - if ( u3_csat_addr == ceq_u->sat_e ) { - ceq_u->sat_e = u3_csat_quit; - return; // wait to be called again on address resolution - } - - if ( ceq_u->cli_u ) { - h2o_http1client_cancel(ceq_u->cli_u); - } - - _cttp_creq_free(ceq_u); -} - -/* _cttp_httr(): dispatch http response to %eyre -*/ -static void -_cttp_httr(c3_l num_l, c3_w sas_w, u3_noun mes, u3_noun uct) -{ - u3_noun htr = u3nt(sas_w, mes, uct); - u3_noun pox = u3nt(u3_blip, c3__http, u3_nul); - - u3_pier_plan(pox, u3nt(c3__they, num_l, htr)); -} - -/* _cttp_creq_quit(): dispatch error response -*/ -static void -_cttp_creq_fail(u3_creq* ceq_u, const c3_c* err_c) -{ - // XX anything other than a 504? - c3_w cod_w = 504; - - u3l_log("http: fail (%d, %d): %s\r\n", ceq_u->num_l, cod_w, err_c); - - // XX include err_c as response body? - _cttp_httr(ceq_u->num_l, cod_w, u3_nul, u3_nul); - _cttp_creq_free(ceq_u); -} - -/* _cttp_creq_quit(): dispatch response -*/ -static void -_cttp_creq_respond(u3_creq* ceq_u) -{ - u3_cres* res_u = ceq_u->res_u; - - _cttp_httr(ceq_u->num_l, res_u->sas_w, res_u->hed, - ( !res_u->bod_u ) ? u3_nul : - u3nc(u3_nul, _cttp_bods_to_octs(res_u->bod_u))); - - _cttp_creq_free(ceq_u); -} - -// XX research: may be called with closed client? -/* _cttp_creq_on_body(): cb invoked by h2o upon receiving a response body -*/ -static c3_i -_cttp_creq_on_body(h2o_http1client_t* cli_u, const c3_c* err_c) -{ - u3_creq* ceq_u = (u3_creq *)cli_u->data; - - if ( 0 != err_c && h2o_http1client_error_is_eos != err_c ) { - _cttp_creq_fail(ceq_u, err_c); - return -1; - } - - h2o_buffer_t* buf_u = cli_u->sock->input; - - if ( buf_u->size ) { - _cttp_cres_fire_body(ceq_u->res_u, - _cttp_bod_new(buf_u->size, buf_u->bytes)); - h2o_buffer_consume(&cli_u->sock->input, buf_u->size); - } - - if ( h2o_http1client_error_is_eos == err_c ) { - _cttp_creq_respond(ceq_u); - } - - return 0; -} - -/* _cttp_creq_on_head(): cb invoked by h2o upon receiving response headers -*/ -static h2o_http1client_body_cb -_cttp_creq_on_head(h2o_http1client_t* cli_u, const c3_c* err_c, c3_i ver_i, - c3_i sas_i, h2o_iovec_t sas_u, h2o_header_t* hed_u, - size_t hed_t, c3_i len_i) -{ - u3_creq* ceq_u = (u3_creq *)cli_u->data; - - if ( 0 != err_c && h2o_http1client_error_is_eos != err_c ) { - _cttp_creq_fail(ceq_u, err_c); - return 0; - } - - _cttp_cres_new(ceq_u, (c3_w)sas_i); - ceq_u->res_u->hed = _cttp_heds_to_noun(hed_u, hed_t); - - if ( h2o_http1client_error_is_eos == err_c ) { - _cttp_creq_respond(ceq_u); - return 0; - } - - return _cttp_creq_on_body; -} - -/* _cttp_creq_on_connect(): cb invoked by h2o upon successful connection -*/ -static h2o_http1client_head_cb -_cttp_creq_on_connect(h2o_http1client_t* cli_u, const c3_c* err_c, - h2o_iovec_t** vec_p, size_t* vec_t, c3_i* hed_i) -{ - u3_creq* ceq_u = (u3_creq *)cli_u->data; - - if ( 0 != err_c ) { - _cttp_creq_fail(ceq_u, err_c); - return 0; - } - - { - c3_w len_w; - ceq_u->vec_u = _cttp_bods_to_vec(ceq_u->rub_u, &len_w); - *vec_t = len_w; - *vec_p = ceq_u->vec_u; - *hed_i = c3__head == ceq_u->met_m; - } - - return _cttp_creq_on_head; -} - -/* _cttp_creq_connect(): establish connection -*/ -static void -_cttp_creq_connect(u3_creq* ceq_u) -{ - c3_assert(u3_csat_ripe == ceq_u->sat_e); - c3_assert(ceq_u->ipf_c); - - h2o_iovec_t ipf_u = h2o_iovec_init(ceq_u->ipf_c, strlen(ceq_u->ipf_c)); - c3_s por_s = ceq_u->por_s ? ceq_u->por_s : - ( c3y == ceq_u->sec ) ? 443 : 80; - - // connect by IP - h2o_http1client_connect(&ceq_u->cli_u, ceq_u, u3_Host.ctp_u.ctx_u, ipf_u, - por_s, c3y == ceq_u->sec, _cttp_creq_on_connect); - - // set hostname for TLS handshake - if ( ceq_u->hot_c && c3y == ceq_u->sec ) { - c3_w len_w = 1 + strlen(ceq_u->hot_c); - c3_c* hot_c = c3_malloc(len_w); - strncpy(hot_c, ceq_u->hot_c, len_w); - - free(ceq_u->cli_u->ssl.server_name); - ceq_u->cli_u->ssl.server_name = hot_c; - } - - _cttp_creq_fire(ceq_u); -} - -/* _cttp_creq_resolve_cb(): cb upon IP address resolution -*/ -static void -_cttp_creq_resolve_cb(uv_getaddrinfo_t* adr_u, - c3_i sas_i, - struct addrinfo* aif_u) -{ - u3_creq* ceq_u = adr_u->data; - - if ( u3_csat_quit == ceq_u->sat_e ) { - _cttp_creq_quit(ceq_u);; - } - else if ( 0 != sas_i ) { - _cttp_creq_fail(ceq_u, uv_strerror(sas_i)); - } - else { - // XX traverse struct a la _ames_czar_cb - ceq_u->ipf_w = ntohl(((struct sockaddr_in *)aif_u->ai_addr)->sin_addr.s_addr); - ceq_u->ipf_c = _cttp_creq_ip(ceq_u->ipf_w); - - ceq_u->sat_e = u3_csat_ripe; - _cttp_creq_connect(ceq_u); - } - - free(adr_u); - uv_freeaddrinfo(aif_u); -} - -/* _cttp_creq_resolve(): resolve hostname to IP address -*/ -static void -_cttp_creq_resolve(u3_creq* ceq_u) -{ - c3_assert(u3_csat_addr == ceq_u->sat_e); - c3_assert(ceq_u->hot_c); - - uv_getaddrinfo_t* adr_u = c3_malloc(sizeof(*adr_u)); - adr_u->data = ceq_u; - - struct addrinfo hin_u; - memset(&hin_u, 0, sizeof(struct addrinfo)); - - hin_u.ai_family = PF_INET; - hin_u.ai_socktype = SOCK_STREAM; - hin_u.ai_protocol = IPPROTO_TCP; - - // XX is this necessary? - c3_c* por_c = ceq_u->por_c ? ceq_u->por_c : - ( c3y == ceq_u->sec ) ? "443" : "80"; - - c3_i sas_i; - - if ( 0 != (sas_i = uv_getaddrinfo(u3L, adr_u, _cttp_creq_resolve_cb, - ceq_u->hot_c, por_c, &hin_u)) ) { - _cttp_creq_fail(ceq_u, uv_strerror(sas_i)); - } -} - -/* _cttp_creq_start(): start a request -*/ -static void -_cttp_creq_start(u3_creq* ceq_u) -{ - if ( ceq_u->ipf_c ) { - ceq_u->sat_e = u3_csat_ripe; - _cttp_creq_connect(ceq_u); - } else { - ceq_u->sat_e = u3_csat_addr; - _cttp_creq_resolve(ceq_u); - } -} - -/* _cttp_init_tls: initialize OpenSSL context -*/ -static SSL_CTX* -_cttp_init_tls() -{ - // XX require 1.1.0 and use TLS_client_method() - SSL_CTX* tls_u = SSL_CTX_new(SSLv23_client_method()); - // XX use SSL_CTX_set_max_proto_version() and SSL_CTX_set_min_proto_version() - SSL_CTX_set_options(tls_u, SSL_OP_NO_SSLv2 | - SSL_OP_NO_SSLv3 | - // SSL_OP_NO_TLSv1 | // XX test - SSL_OP_NO_COMPRESSION); - - SSL_CTX_set_verify(tls_u, SSL_VERIFY_PEER, 0); - SSL_CTX_set_default_verify_paths(tls_u); - SSL_CTX_set_session_cache_mode(tls_u, SSL_SESS_CACHE_OFF); - SSL_CTX_set_cipher_list(tls_u, - "ECDH+AESGCM:DH+AESGCM:ECDH+AES256:DH+AES256:" - "ECDH+AES128:DH+AES:ECDH+3DES:DH+3DES:RSA+AESGCM:" - "RSA+AES:RSA+3DES:!aNULL:!MD5:!DSS"); - - return tls_u; -} - -/* _cttp_init_h2o: initialize h2o client ctx and timeout -*/ -static h2o_http1client_ctx_t* -_cttp_init_h2o() -{ - h2o_timeout_t* tim_u = c3_malloc(sizeof(*tim_u)); - - h2o_timeout_init(u3L, tim_u, 300 * 1000); - - h2o_http1client_ctx_t* ctx_u = c3_calloc(sizeof(*ctx_u)); - ctx_u->loop = u3L; - ctx_u->io_timeout = tim_u; - - return ctx_u; -}; - -/* u3_cttp_ef_thus(): send %thus effect (outgoing request) to cttp. -*/ -void -u3_cttp_ef_thus(c3_l num_l, - u3_noun cuq) -{ - u3_creq* ceq_u; - - if ( u3_nul == cuq ) { - ceq_u =_cttp_creq_find(num_l); - - if ( ceq_u ) { - _cttp_creq_quit(ceq_u); - } - } - else { - ceq_u = _cttp_creq_new(num_l, u3k(u3t(cuq))); - _cttp_creq_start(ceq_u); - } - u3z(cuq); -} - -/* u3_cttp_io_init(): initialize http client I/O. -*/ -void -u3_cttp_io_init() -{ - u3_Host.ctp_u.tls_u = _cttp_init_tls(); - u3_Host.ctp_u.ctx_u = _cttp_init_h2o(); - u3_Host.ctp_u.ctx_u->ssl_ctx = u3_Host.ctp_u.tls_u; - u3_Host.ctp_u.ceq_u = 0; -} - -/* u3_cttp_io_exit(): shut down cttp. -*/ -void -u3_cttp_io_exit(void) -{ - SSL_CTX_free(u3_Host.ctp_u.tls_u); - free(u3_Host.ctp_u.ctx_u->io_timeout); - free(u3_Host.ctp_u.ctx_u); -} diff --git a/pkg/hair/notes/c/daemon.c b/pkg/hair/notes/c/daemon.c deleted file mode 100644 index 293f9c6c9..000000000 --- a/pkg/hair/notes/c/daemon.c +++ /dev/null @@ -1,735 +0,0 @@ -/* vere/main.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#define U3_GLOBAL -#define C3_GLOBAL -#include "all.h" -#include "vere/vere.h" - -/* Require unsigned char - */ -STATIC_ASSERT(( 0 == CHAR_MIN && UCHAR_MAX == CHAR_MAX ), - "unsigned char required"); - -/* _main_readw(): parse a word from a string. -*/ -static u3_noun -_main_readw(const c3_c* str_c, c3_w max_w, c3_w* out_w) -{ - c3_c* end_c; - c3_w par_w = strtoul(str_c, &end_c, 0); - - if ( *str_c != '\0' && *end_c == '\0' && par_w < max_w ) { - *out_w = par_w; - return c3y; - } - else return c3n; -} - -/* _main_presig(): prefix optional sig. -*/ -c3_c* -_main_presig(c3_c* txt_c) -{ - c3_c* new_c = malloc(2 + strlen(txt_c)); - - if ( '~' == *txt_c ) { - strcpy(new_c, txt_c); - } else { - new_c[0] = '~'; - strcpy(new_c + 1, txt_c); - } - return new_c; -} - -/* _main_getopt(): extract option map from command line. -*/ -static u3_noun -_main_getopt(c3_i argc, c3_c** argv) -{ - c3_i ch_i; - c3_w arg_w; - - u3_Host.ops_u.abo = c3n; - u3_Host.ops_u.bat = c3n; - u3_Host.ops_u.can = c3n; - u3_Host.ops_u.dem = c3n; - u3_Host.ops_u.dry = c3n; - u3_Host.ops_u.etn = c3n; - u3_Host.ops_u.gab = c3n; - u3_Host.ops_u.git = c3n; - - // always disable hashboard - // XX temporary, remove once hashes are added - // - u3_Host.ops_u.has = c3y; - - u3_Host.ops_u.net = c3y; - u3_Host.ops_u.nuu = c3n; - u3_Host.ops_u.pro = c3n; - u3_Host.ops_u.qui = c3n; - u3_Host.ops_u.rep = c3n; - u3_Host.ops_u.tex = c3n; - u3_Host.ops_u.tra = c3n; - u3_Host.ops_u.veb = c3n; - u3_Host.ops_u.kno_w = DefaultKernel; - - while ( -1 != (ch_i=getopt(argc, argv, - "G:J:B:K:A:H:w:u:e:E:f:F:k:m:p:LjabcCdgqstvxPDRS")) ) - { - switch ( ch_i ) { - case 'J': { - u3_Host.ops_u.lit_c = strdup(optarg); - break; - } - case 'B': { - u3_Host.ops_u.pil_c = strdup(optarg); - break; - } - case 'G': { - u3_Host.ops_u.gen_c = strdup(optarg); - break; - } - case 'A': { - u3_Host.ops_u.arv_c = strdup(optarg); - break; - } - case 'H': { - u3_Host.ops_u.dns_c = strdup(optarg); - break; - } - case 'e': { - u3_Host.ops_u.eth_c = strdup(optarg); - break; - } - case 'E': { - u3_Host.ops_u.ets_c = strdup(optarg); - break; - } - case 'F': { - u3_Host.ops_u.fak_c = _main_presig(optarg); - u3_Host.ops_u.net = c3n; - break; - } - case 'w': { - u3_Host.ops_u.who_c = _main_presig(optarg); - u3_Host.ops_u.nuu = c3y; - break; - } - case 'u': { - u3_Host.ops_u.url_c = strdup(optarg); - break; - } - case 'x': { - u3_Host.ops_u.tex = c3y; - break; - } - case 'f': { - if ( c3n == _main_readw(optarg, 100, &u3_Host.ops_u.fuz_w) ) { - return c3n; - } - break; - } - case 'K': { - if ( c3n == _main_readw(optarg, 256, &u3_Host.ops_u.kno_w) ) { - return c3n; - } - break; - } - case 'k': { - u3_Host.ops_u.key_c = strdup(optarg); - break; - } - case 'm': { - u3_Host.ops_u.sap_c = strdup(optarg); - break; - } - case 'p': { - if ( c3n == _main_readw(optarg, 65536, &arg_w) ) { - return c3n; - } else u3_Host.ops_u.por_s = arg_w; - break; - } - case 'R': { - u3_Host.ops_u.rep = c3y; - return c3y; - } - case 'L': { u3_Host.ops_u.net = c3n; break; } - case 'j': { u3_Host.ops_u.tra = c3y; break; } - case 'a': { u3_Host.ops_u.abo = c3y; break; } - case 'b': { u3_Host.ops_u.bat = c3y; break; } - case 'c': { u3_Host.ops_u.nuu = c3y; break; } - case 'C': { u3_Host.ops_u.can = c3y; break; } - case 'd': { u3_Host.ops_u.dem = c3y; break; } - case 'g': { u3_Host.ops_u.gab = c3y; break; } - case 'P': { u3_Host.ops_u.pro = c3y; break; } - case 'D': { u3_Host.ops_u.dry = c3y; break; } - case 'q': { u3_Host.ops_u.qui = c3y; break; } - case 'v': { u3_Host.ops_u.veb = c3y; break; } - case 's': { u3_Host.ops_u.git = c3y; break; } - case 'S': { u3_Host.ops_u.has = c3y; break; } - case 't': { u3_Host.ops_u.etn = c3y; break; } - case '?': default: { - return c3n; - } - } - } - -#if defined(U3_OS_bsd) - if (u3_Host.ops_u.pro == c3y) { - fprintf(stderr, "profiling isn't yet supported on BSD\r\n"); - return c3n; - } -#endif - - if ( 0 != u3_Host.ops_u.fak_c ) { - if ( 28 < strlen(u3_Host.ops_u.fak_c) ) { - fprintf(stderr, "fake comets are disallowed\r\n"); - return c3n; - } - - u3_Host.ops_u.who_c = strdup(u3_Host.ops_u.fak_c); - u3_Host.ops_u.has = c3y; /* no battery hashing on fake ships. */ - u3_Host.ops_u.net = c3n; /* no networking on fake ships. */ - u3_Host.ops_u.nuu = c3y; - } - - if ( argc != (optind + 1) && u3_Host.ops_u.who_c != 0 ) { - u3_Host.dir_c = strdup(1 + u3_Host.ops_u.who_c); - } - - if ( argc != (optind + 1) ) { - return u3_Host.dir_c ? c3y : c3n; - } else { - { - c3_c* ash_c; - - if ( (ash_c = strrchr(argv[optind], '/')) && (ash_c[1] == 0) ) { - *ash_c = 0; - } - } - - u3_Host.dir_c = strdup(argv[optind]); - } - - if ( c3y == u3_Host.ops_u.bat ) { - u3_Host.ops_u.dem = c3y; - u3_Host.ops_u.nuu = c3y; - } - - // make -c optional, catch invalid boot of existing pier - // - { - struct stat s; - if ( 0 != stat(u3_Host.dir_c, &s) ) { - if ( c3n == u3_Host.ops_u.nuu ) { - u3_Host.ops_u.nuu = c3y; - } - } - else if ( c3y == u3_Host.ops_u.nuu ) { - fprintf(stderr, "tried to create, but %s already exists\n", u3_Host.dir_c); - fprintf(stderr, "normal usage: %s %s\n", argv[0], u3_Host.dir_c); - exit(1); - } - } - - c3_t imp_t = ((0 != u3_Host.ops_u.who_c) && - (4 == strlen(u3_Host.ops_u.who_c))); - - if ( u3_Host.ops_u.gen_c != 0 && u3_Host.ops_u.nuu == c3n ) { - fprintf(stderr, "-G only makes sense when bootstrapping a new instance\n"); - return c3n; - } - - if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.who_c != 0) { - fprintf(stderr, "-w only makes sense when creating a new ship\n"); - return c3n; - } - - if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.pil_c != 0) { - fprintf(stderr, "-B only makes sense when creating a new ship\n"); - return c3n; - } - - if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.dns_c != 0) { - fprintf(stderr, "-H only makes sense when bootstrapping a new instance\n"); - return c3n; - } - - if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.pil_c != 0) { - fprintf(stderr, "-B only makes sense when bootstrapping a new instance\n"); - return c3n; - } - - if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.key_c != 0) { - fprintf(stderr, "-k only makes sense when bootstrapping a new instance\n"); - return c3n; - } - - if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.url_c != 0 ) { - fprintf(stderr, "-u only makes sense when bootstrapping a new instance\n"); - return c3n; - } - - if ( u3_Host.ops_u.nuu != c3y && u3_Host.ops_u.sap_c != 0 ) { - fprintf(stderr, "-m only makes sense when bootstrapping a new instance\n"); - return c3n; - } - - if ( u3_Host.ops_u.fak_c != 0 && u3_Host.ops_u.sap_c != 0 ) { - fprintf(stderr, "-m and -F cannot be used together\n"); - return c3n; - } - - if ( u3_Host.ops_u.ets_c != 0 && u3_Host.ops_u.sap_c != 0 ) { - fprintf(stderr, "-m and -E cannot be used together\n"); - return c3n; - } - if ( u3_Host.ops_u.can == c3y && u3_Host.ops_u.sap_c != 0 ) { - fprintf(stderr, "-m and -C cannot be used together\n"); - return c3n; - } - if ( u3_Host.ops_u.can == c3y && u3_Host.ops_u.ets_c != 0 ) { - fprintf(stderr, "-C and -E cannot be used together\n"); - return c3n; - } - - if ( u3_Host.ops_u.eth_c == 0 && imp_t ) { - u3_Host.ops_u.eth_c = "http://eth-mainnet.urbit.org:8545"; - } - - if ( u3_Host.ops_u.sap_c == 0 && u3_Host.ops_u.can == c3n ) { - - u3_Host.ops_u.sap_c = - "https://bootstrap.urbit.org/urbit-" URBIT_VERSION ".snap"; - } - - if ( u3_Host.ops_u.url_c != 0 && u3_Host.ops_u.pil_c != 0 ) { - fprintf(stderr, "-B and -u cannot be used together\n"); - return c3n; - } - else if ( u3_Host.ops_u.nuu == c3y - && u3_Host.ops_u.url_c == 0 - && u3_Host.ops_u.git == c3n ) { - u3_Host.ops_u.url_c = - "https://bootstrap.urbit.org/urbit-" URBIT_VERSION ".pill"; - } - else if ( u3_Host.ops_u.nuu == c3y - && u3_Host.ops_u.url_c == 0 - && u3_Host.ops_u.arv_c == 0 ) { - - fprintf(stderr, "-s only makes sense with -A\n"); - return c3n; - } - - if ( u3_Host.ops_u.pil_c != 0 ) { - struct stat s; - if ( stat(u3_Host.ops_u.pil_c, &s) != 0 ) { - fprintf(stderr, "pill %s not found\n", u3_Host.ops_u.pil_c); - return c3n; - } - } - - if ( u3_Host.ops_u.key_c != 0 ) { - struct stat s; - if ( stat(u3_Host.ops_u.key_c, &s) != 0 ) { - fprintf(stderr, "keyfile %s not found\n", u3_Host.ops_u.key_c); - return c3n; - } - } - - return c3y; -} - -/* u3_ve_usage(): print usage and exit. -*/ -static void -u3_ve_usage(c3_i argc, c3_c** argv) -{ - c3_c *use_c[] = { - "Urbit: a personal server operating function\n", - "https://urbit.org\n", - "Version " URBIT_VERSION "\n", - "\n", - "Usage: %s [options...] ship_name\n", - "where ship_name is a @p phonetic representation of an urbit address\n", - "without the leading '~', and options is some subset of the following:\n", - "\n", - // XX find a way to re-enable - // "-A dir Use dir for initial galaxy sync\n", - "-B pill Bootstrap from this pill\n", - "-b Batch create\n", - "-c pier Create a new urbit in pier/\n", - "-D Recompute from events\n", - "-d Daemon mode\n", - "-e url Ethereum gateway\n", - "-F ship Fake keys; also disables networking\n", - "-f Fuzz testing\n", - "-g Set GC flag\n", - "-j file Create json trace file\n", - "-K stage Start at Hoon kernel version stage\n", - "-k keys Private key file\n", - "-L local networking only\n", - "-P Profiling\n", - "-p ames_port Set the ames port to bind to\n", - "-q Quiet\n", - "-R Report urbit build info\n", - "-S Disable battery hashing\n", - // XX find a way to re-enable - // "-s Pill URL from arvo git hash\n", - "-u url URL from which to download pill\n", - "-v Verbose\n", - "-w name Boot as ~name\n", - "-x Exit immediately\n", - "\n", - "Development Usage:\n", - " To create a development ship, use a fakezod:\n", - " %s -F zod -A /path/to/arvo/folder -B /path/to/pill -c zod\n", - "\n", - " For more information about developing on urbit, see:\n", - " https://github.com/urbit/urbit/blob/master/CONTRIBUTING.md\n", - "\n", - "Simple Usage: \n", - " %s -c to create a comet (anonymous urbit)\n", - " %s -w -k if you own a planet\n", - " %s to restart an existing urbit\n", - 0 - }; - - c3_i i; - for ( i=0; use_c[i]; i++ ) { - fprintf(stderr, use_c[i], argv[0]); - } - exit(1); -} - -#if 0 -/* u3_ve_panic(): panic and exit. -*/ -static void -u3_ve_panic(c3_i argc, c3_c** argv) -{ - fprintf(stderr, "%s: gross system failure\n", argv[0]); - exit(1); -} -#endif - -/* u3_ve_sysopt(): apply option map to system state. -*/ -static void -u3_ve_sysopt() -{ - u3_Local = strdup(u3_Host.dir_c); -} - -static void -report(void) -{ - printf("urbit %s\n", URBIT_VERSION); - printf("---------\nLibraries\n---------\n"); - printf("gmp: %s\n", gmp_version); - printf("sigsegv: %d.%d\n", - (libsigsegv_version >> 8) & 0xff, - libsigsegv_version & 0xff); - printf("openssl: %s\n", SSLeay_version(SSLEAY_VERSION)); - printf("curses: %s\n", curses_version()); - printf("libuv: %s\n", uv_version_string()); - printf("libh2o: %d.%d.%d\n", - H2O_LIBRARY_VERSION_MAJOR, - H2O_LIBRARY_VERSION_MINOR, - H2O_LIBRARY_VERSION_PATCH); - printf("lmdb: %d.%d.%d\n", - MDB_VERSION_MAJOR, - MDB_VERSION_MINOR, - MDB_VERSION_PATCH); - printf("curl: %d.%d.%d\n", - LIBCURL_VERSION_MAJOR, - LIBCURL_VERSION_MINOR, - LIBCURL_VERSION_PATCH); - printf("argon2: 0x%x\n", ARGON2_VERSION_NUMBER); -} - -static void -_stop_exit(c3_i int_i) -{ - // explicit fprintf to avoid allocation in u3l_log - // - fprintf(stderr, "\r\n[received keyboard stop signal, exiting]\r\n"); - u3_daemon_bail(); -} - -/* - This is set to the the write-end of a pipe when Urbit is started in - daemon mode. It's meant to be used as a signal to the parent process - that the child process has finished booting. -*/ -static c3_i _child_process_booted_signal_fd = -1; - -/* - This should be called whenever the ship has been booted enough to - handle commands from automation code. Specifically, once the Eyre's - `chis` interface is up and running. - - In daemon mode, this signals to the parent process that it can - exit. Otherwise, it does nothing. - - Once we've sent a signal with `write`, we close the file descriptor - and overwrite the global to make it impossible to accidentally do - this twice. -*/ -static void _on_boot_completed_cb() { - c3_c buf[2] = {0,0}; - - if ( -1 == _child_process_booted_signal_fd ) { - return; - } - - if ( 0 == write(_child_process_booted_signal_fd, buf, 1) ) { - c3_assert(!"_on_boot_completed_cb: Can't write to parent FD"); - } - - close(_child_process_booted_signal_fd); - _child_process_booted_signal_fd = -1; -} - -/* - In daemon mode, run the urbit as a background process, but don't - exit from the parent process until the ship is finished booting. - - We use a pipe to communicate between the child and the parent. The - parent waits for the child to write something to the pipe and - then exits. If the pipe is closed with nothing written to it, get - the exit status from the child process and also exit with that status. - - We want the child to write to the pipe once it's booted, so we put - `_on_boot_completed_cb` into `u3_Host.bot_f`, which is NULL in - non-daemon mode. That gets called once the `chis` service is - available. - - In both processes, we are good fork() citizens, and close all unused - file descriptors. Closing `pipefd[1]` in the parent process is - especially important, since the pipe needs to be closed if the child - process dies. When the pipe is closed, the read fails, and that's - how we know that something went wrong. - - There are some edge cases around `WEXITSTATUS` that are not handled - here, but I don't think it matters. -*/ -static void -_fork_into_background_process() -{ - c3_i pipefd[2]; - - if ( 0 != pipe(pipefd) ) { - c3_assert(!"Failed to create pipe"); - } - - pid_t childpid = fork(); - - if ( 0 == childpid ) { - close(pipefd[0]); - _child_process_booted_signal_fd = pipefd[1]; - u3_Host.bot_f = _on_boot_completed_cb; - return; - } - - close(pipefd[1]); - close(0); - close(1); - close(2); - - c3_c buf[2] = {0,0}; - if ( 1 == read(pipefd[0], buf, 1) ) { - exit(0); - } - - c3_i status; - wait(&status); - exit(WEXITSTATUS(status)); -} - -c3_i -main(c3_i argc, - c3_c** argv) -{ - // Parse options. - // - if ( c3n == _main_getopt(argc, argv) ) { - u3_ve_usage(argc, argv); - return 1; - } - - // Set `u3_Host.wrk_c` to the worker executable path. - c3_i worker_exe_len = 1 + strlen(argv[0]) + strlen("-worker"); - u3_Host.wrk_c = c3_malloc(worker_exe_len); - snprintf(u3_Host.wrk_c, worker_exe_len, "%s-worker", argv[0]); - - // Set TERMINFO_DIRS environment variable - c3_i terminfo_len = 1 + strlen(argv[0]) + strlen("-terminfo"); - c3_c terminfo_dir[terminfo_len]; - snprintf(terminfo_dir, terminfo_len, "%s-terminfo", argv[0]); - setenv("TERMINFO_DIRS", terminfo_dir, 1); - - if ( c3y == u3_Host.ops_u.dem ) { - _fork_into_background_process(); - } - - if ( c3y == u3_Host.ops_u.rep ) { - report(); - return 0; - } - -#if 0 - if ( 0 == getuid() ) { - chroot(u3_Host.dir_c); - u3_Host.dir_c = "/"; - } -#endif - u3_ve_sysopt(); - - // Block profiling signal, which should be delivered to exactly one thread. - // - // XX review, may be unnecessary due to similar in u3m_init() - // - if ( _(u3_Host.ops_u.pro) ) { - sigset_t set; - - sigemptyset(&set); - sigaddset(&set, SIGPROF); - if ( 0 != pthread_sigmask(SIG_BLOCK, &set, NULL) ) { - u3l_log("boot: thread mask SIGPROF: %s\r\n", strerror(errno)); - exit(1); - } - } - - // Handle SIGTSTP as if it was SIGTERM. - // - // Configured here using signal() so as to be immediately available. - // - signal(SIGTSTP, _stop_exit); - - printf("~\n"); - // printf("welcome.\n"); - printf("urbit %s\n", URBIT_VERSION); - - // prints the absolute path of the pier - // - c3_c* abs_c = realpath(u3_Host.dir_c, 0); - - // if the ship is being booted, we use realpath(). Otherwise, we use getcwd() - // with a memory-allocation loop - // - if (abs_c == NULL) { - c3_i mprint_i = 1000; - abs_c = c3_malloc(mprint_i); - - // allocates more memory as needed if the path is too large - // - while ( abs_c != getcwd(abs_c, mprint_i) ) { - free(abs_c); - mprint_i *= 2; - abs_c = c3_malloc(mprint_i); - } - printf("boot: home is %s/%s\n", abs_c, u3_Host.dir_c); - free(abs_c); - } else { - printf("boot: home is %s\n", abs_c); - free(abs_c); - } - // printf("vere: hostname is %s\n", u3_Host.ops_u.nam_c); - - if ( c3y == u3_Host.ops_u.dem && c3n == u3_Host.ops_u.bat ) { - printf("boot: running as daemon\n"); - } - - // Seed prng. Don't panic -- just for fuzz testing. - // - srand(getpid()); - - // Instantiate process globals. - { - /* Boot the image and checkpoint. Set flags. - */ - { - /* Set pier directory. - */ - u3C.dir_c = u3_Host.dir_c; - - /* Logging that doesn't interfere with console output. - */ - u3C.stderr_log_f = u3_term_io_log; - - /* Set GC flag. - */ - if ( _(u3_Host.ops_u.gab) ) { - u3C.wag_w |= u3o_debug_ram; - } - - /* Set profile flag. - */ - if ( _(u3_Host.ops_u.pro) ) { - u3C.wag_w |= u3o_debug_cpu; - } - - /* Set verbose flag. - */ - if ( _(u3_Host.ops_u.veb) ) { - u3C.wag_w |= u3o_verbose; - } - - /* Set quiet flag. - */ - if ( _(u3_Host.ops_u.qui) ) { - u3C.wag_w |= u3o_quiet; - } - - /* Set dry-run flag. - */ - if ( _(u3_Host.ops_u.dry) ) { - u3C.wag_w |= u3o_dryrun; - } - - /* Set hashboard flag - */ - if ( _(u3_Host.ops_u.has) ) { - u3C.wag_w |= u3o_hashless; - } - - /* Set tracing flag - */ - if ( _(u3_Host.ops_u.tra) ) { - u3C.wag_w |= u3o_trace; - u3_Host.tra_u.nid_w = 0; - u3_Host.tra_u.fil_u = NULL; - u3_Host.tra_u.con_w = 0; - u3_Host.tra_u.fun_w = 0; - } - } - - /* Initialize OpenSSL for client and server - */ - SSL_library_init(); - SSL_load_error_strings(); - - u3_daemon_commence(); - } - return 0; -} diff --git a/pkg/hair/notes/c/dawn.c b/pkg/hair/notes/c/dawn.c deleted file mode 100644 index 80a3856aa..000000000 --- a/pkg/hair/notes/c/dawn.c +++ /dev/null @@ -1,525 +0,0 @@ -/* vere/dawn.c -** -** ethereum-integrated pre-boot validation -*/ -#include -#include - -#include "all.h" -#include "vere/vere.h" - -/* _dawn_oct_to_buf(): +octs to uv_buf_t -*/ -static uv_buf_t -_dawn_oct_to_buf(u3_noun oct) -{ - if ( c3n == u3a_is_cat(u3h(oct)) ) { - exit(1); - } - - c3_w len_w = u3h(oct); - c3_y* buf_y = c3_malloc(1 + len_w); - buf_y[len_w] = 0; - - u3r_bytes(0, len_w, buf_y, u3t(oct)); - - u3z(oct); - return uv_buf_init((void*)buf_y, len_w); -} - -/* _dawn_buf_to_oct(): uv_buf_t to +octs -*/ -static u3_noun -_dawn_buf_to_oct(uv_buf_t buf_u) -{ - u3_noun len = u3i_words(1, (c3_w*)&buf_u.len); - - if ( c3n == u3a_is_cat(len) ) { - exit(1); - } - - return u3nc(len, u3i_bytes(buf_u.len, (const c3_y*)buf_u.base)); -} - - -/* _dawn_curl_alloc(): allocate a response buffer for curl -*/ -static size_t -_dawn_curl_alloc(void* dat_v, size_t uni_t, size_t mem_t, uv_buf_t* buf_u) -{ - size_t siz_t = uni_t * mem_t; - buf_u->base = c3_realloc(buf_u->base, 1 + siz_t + buf_u->len); - - memcpy(buf_u->base + buf_u->len, dat_v, siz_t); - buf_u->len += siz_t; - buf_u->base[buf_u->len] = 0; - - return siz_t; -} - -/* _dawn_post_json(): POST JSON to url_c -*/ -static uv_buf_t -_dawn_post_json(c3_c* url_c, uv_buf_t lod_u) -{ - CURL *curl; - CURLcode result; - long cod_l; - struct curl_slist* hed_u = 0; - - uv_buf_t buf_u = uv_buf_init(c3_malloc(1), 0); - - if ( !(curl = curl_easy_init()) ) { - u3l_log("failed to initialize libcurl\n"); - exit(1); - } - - hed_u = curl_slist_append(hed_u, "Accept: application/json"); - hed_u = curl_slist_append(hed_u, "Content-Type: application/json"); - hed_u = curl_slist_append(hed_u, "charsets: utf-8"); - - // XX require TLS, pin default cert? - - curl_easy_setopt(curl, CURLOPT_URL, url_c); - curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, _dawn_curl_alloc); - curl_easy_setopt(curl, CURLOPT_WRITEDATA, (void*)&buf_u); - curl_easy_setopt(curl, CURLOPT_HTTPHEADER, hed_u); - - // note: must be terminated! - curl_easy_setopt(curl, CURLOPT_POSTFIELDS, lod_u.base); - - result = curl_easy_perform(curl); - curl_easy_getinfo(curl, CURLINFO_RESPONSE_CODE, &cod_l); - - // XX retry? - if ( CURLE_OK != result ) { - u3l_log("failed to fetch %s: %s\n", - url_c, curl_easy_strerror(result)); - exit(1); - } - if ( 300 <= cod_l ) { - u3l_log("error fetching %s: HTTP %ld\n", url_c, cod_l); - exit(1); - } - - curl_easy_cleanup(curl); - curl_slist_free_all(hed_u); - - return buf_u; -} - -/* _dawn_get_jam(): GET a jammed noun from url_c -*/ -static u3_noun -_dawn_get_jam(c3_c* url_c) -{ - CURL *curl; - CURLcode result; - long cod_l; - - uv_buf_t buf_u = uv_buf_init(c3_malloc(1), 0); - - if ( !(curl = curl_easy_init()) ) { - u3l_log("failed to initialize libcurl\n"); - exit(1); - } - - // XX require TLS, pin default cert? - - curl_easy_setopt(curl, CURLOPT_URL, url_c); - curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, _dawn_curl_alloc); - curl_easy_setopt(curl, CURLOPT_WRITEDATA, (void*)&buf_u); - - result = curl_easy_perform(curl); - curl_easy_getinfo(curl, CURLINFO_RESPONSE_CODE, &cod_l); - - // XX retry? - if ( CURLE_OK != result ) { - u3l_log("failed to fetch %s: %s\n", - url_c, curl_easy_strerror(result)); - exit(1); - } - if ( 300 <= cod_l ) { - u3l_log("error fetching %s: HTTP %ld\n", url_c, cod_l); - exit(1); - } - - curl_easy_cleanup(curl); - - // throw away the length from the octs - // - u3_noun octs = _dawn_buf_to_oct(buf_u); - u3_noun jammed = u3k(u3t(octs)); - u3z(octs); - - return u3ke_cue(jammed); -} - -/* _dawn_eth_rpc(): ethereum JSON RPC with request/response as +octs -*/ -static u3_noun -_dawn_eth_rpc(c3_c* url_c, u3_noun oct) -{ - return _dawn_buf_to_oct(_dawn_post_json(url_c, _dawn_oct_to_buf(oct))); -} - -/* _dawn_fail(): pre-boot validation failed -*/ -static void -_dawn_fail(u3_noun who, u3_noun rac, u3_noun sas) -{ - u3_noun how = u3dc("scot", 'p', u3k(who)); - c3_c* how_c = u3r_string(u3k(how)); - - c3_c* rac_c; - - switch (rac) { - default: c3_assert(0); - case c3__czar: { - rac_c = "galaxy"; - break; - } - case c3__king: { - rac_c = "star"; - break; - } - case c3__duke: { - rac_c = "planet"; - break; - } - case c3__earl: { - rac_c = "moon"; - break; - } - case c3__pawn: { - rac_c = "comet"; - break; - } - } - - u3l_log("boot: invalid keys for %s '%s'\r\n", rac_c, how_c); - - // XX deconstruct sas, print helpful error messages - u3m_p("pre-boot error", u3t(sas)); - - u3z(how); - free(how_c); - exit(1); -} - -/* _dawn_need_unit(): produce a value or print error and exit -*/ -static u3_noun -_dawn_need_unit(u3_noun nit, c3_c* msg_c) -{ - if ( u3_nul == nit ) { - u3l_log("%s\r\n", msg_c); - exit(1); - } - else { - u3_noun pro = u3k(u3t(nit)); - u3z(nit); - return pro; - } -} - -/* _dawn_purl(): ethereum gateway url as (unit purl) -*/ -static u3_noun -_dawn_purl(u3_noun rac) -{ - u3_noun url; - - if ( 0 == u3_Host.ops_u.eth_c ) { - if ( c3__czar == rac ) { - u3l_log("boot: galaxy requires ethereum gateway via -e\r\n"); - exit(1); - } - - url = u3_nul; - } - else { - // XX call de-purl directly - // - u3_noun par = u3v_wish("auru:de-purl:html"); - u3_noun lur = u3i_string(u3_Host.ops_u.eth_c); - u3_noun rul = u3dc("rush", u3k(lur), u3k(par)); - - if ( u3_nul == rul ) { - if ( c3__czar == rac ) { - u3l_log("boot: galaxy requires ethereum gateway via -e\r\n"); - exit(1); - } - - url = u3_nul; - } - else { - // XX revise for de-purl - // auru:de-purl:html parses to (pair user purl) - // we need (unit purl) - // - url = u3nc(u3_nul, u3k(u3t(u3t(rul)))); - } - - u3z(par); u3z(lur); u3z(rul); - } - - return url; -} - -/* _dawn_turf(): override contract domains with -H -*/ -static u3_noun -_dawn_turf(c3_c* dns_c) -{ - u3_noun tuf; - - u3_noun par = u3v_wish("thos:de-purl:html"); - u3_noun dns = u3i_string(dns_c); - u3_noun rul = u3dc("rush", u3k(dns), u3k(par)); - - if ( (u3_nul == rul) || (c3n == u3h(u3t(rul))) ) { - u3l_log("boot: invalid domain specified with -H %s\r\n", dns_c); - exit(1); - } - else { - u3l_log("boot: overriding network domains with %s\r\n", dns_c); - u3_noun dom = u3t(u3t(rul)); - tuf = u3nc(u3k(dom), u3_nul); - } - - u3z(par); u3z(dns); u3z(rul); - - return tuf; -} - -/* u3_dawn_vent(): validated boot event -*/ -u3_noun -u3_dawn_vent(u3_noun seed) -{ - u3_noun url, bok, pon, zar, tuf, sap; - - u3_noun ship = u3h(seed); - u3_noun rank = u3do("clan:title", u3k(ship)); - - // load snapshot from file - // - if ( 0 != u3_Host.ops_u.ets_c ) { - u3l_log("boot: loading azimuth snapshot\r\n"); - u3_noun raw_snap = u3ke_cue(u3m_file(u3_Host.ops_u.ets_c)); - sap = u3nc(u3_nul, raw_snap); - } - // load snapshot from HTTP URL - // - else if ( 0 != u3_Host.ops_u.sap_c ) { - u3l_log("boot: downloading azimuth snapshot from %s\r\n", - u3_Host.ops_u.sap_c); - u3_noun raw_snap = _dawn_get_jam(u3_Host.ops_u.sap_c); - sap = u3nc(u3_nul, raw_snap); - } - // no snapshot - // - else { - u3l_log("boot: no azimuth snapshot specified\n"); - sap = u3_nul; - } - - url = _dawn_purl(rank); - - // XX require https? - // - c3_c* url_c = ( 0 != u3_Host.ops_u.eth_c ) ? - u3_Host.ops_u.eth_c : - "https://mainnet.infura.io/v3/196a7f37c7d54211b4a07904ec73ad87"; - - // pin block number - // - if ( c3y == u3_Host.ops_u.etn ) { - u3l_log("boot: extracting block from snapshot\r\n"); - - bok = _dawn_need_unit(u3do("bloq:snap:dawn", u3k(u3t(sap))), - "boot: failed to extract " - "block from snapshot"); - } - else { - u3l_log("boot: retrieving latest block\r\n"); - - u3_noun oct = u3v_wish("bloq:give:dawn"); - u3_noun kob = _dawn_eth_rpc(url_c, u3k(oct)); - - bok = _dawn_need_unit(u3do("bloq:take:dawn", u3k(kob)), - "boot: block retrieval failed"); - u3z(oct); u3z(kob); - } - - { - // +point:azimuth: on-chain state - // - u3_noun pot; - - if ( c3y == u3_Host.ops_u.etn ) { - u3l_log("boot: extracting public keys from snapshot\r\n"); - - pot = _dawn_need_unit(u3dc("point:snap:dawn", u3k(ship), u3k(u3t(sap))), - "boot: failed to extract " - "public keys from snapshot"); - } - else if ( c3__pawn == rank ) { - // irrelevant, just bunt +point - // - pot = u3v_wish("*point:azimuth"); - } - else { - u3_noun who; - - if ( c3__earl == rank ) { - who = u3do("^sein:title", u3k(ship)); - - { - u3_noun seg = u3dc("scot", 'p', u3k(who)); - c3_c* seg_c = u3r_string(seg); - - u3l_log("boot: retrieving %s's public keys (for %s)\r\n", - seg_c, u3_Host.ops_u.who_c); - free(seg_c); - u3z(seg); - } - } - else { - who = u3k(ship); - u3l_log("boot: retrieving %s's public keys\r\n", - u3_Host.ops_u.who_c); - } - - { - u3_noun oct = u3dc("point:give:dawn", u3k(bok), u3k(who)); - u3_noun luh = _dawn_eth_rpc(url_c, u3k(oct)); - - pot = _dawn_need_unit(u3dc("point:take:dawn", u3k(ship), u3k(luh)), - "boot: failed to retrieve public keys"); - u3z(oct); u3z(luh); - } - - u3z(who); - } - - // +live:dawn: network state - // XX actually make request - // - u3_noun liv = u3_nul; - // u3_noun liv = _dawn_get_json(parent, /some/url) - - u3l_log("boot: verifying keys\r\n"); - - // (each sponsor=ship error=@tas) - // - u3_noun sas = u3dt("veri:dawn", u3k(seed), u3k(pot), u3k(liv)); - - if ( c3n == u3h(sas) ) { - // bails, won't return - _dawn_fail(ship, rank, sas); - return u3_none; - } - - // ship: sponsor - // produced by +veri:dawn to avoid coupling to +point structure - // XX reconsider - // - pon = u3k(u3t(sas)); - - u3z(pot); u3z(liv); u3z(sas); - } - - // (map ship [=life =pass]): galaxy table - // - if ( c3y == u3_Host.ops_u.etn ) { - u3l_log("boot: extracting galaxy table from snapshot\r\n"); - - zar = _dawn_need_unit(u3do("czar:snap:dawn", u3k(u3t(sap))), - "boot: failed to extract " - "galaxy table from snapshot"); - } - else { - u3l_log("boot: retrieving galaxy table\r\n"); - - u3_noun oct = u3do("czar:give:dawn", u3k(bok)); - u3_noun raz = _dawn_eth_rpc(url_c, u3k(oct)); - - zar = _dawn_need_unit(u3do("czar:take:dawn", u3k(raz)), - "boot: failed to retrieve galaxy table"); - u3z(oct); u3z(raz); - } - - // (list turf): ames domains - // - if ( 0 != u3_Host.ops_u.dns_c ) { - tuf = _dawn_turf(u3_Host.ops_u.dns_c); - } - else if ( c3y == u3_Host.ops_u.etn ) { - u3l_log("boot: extracting network domains from snapshot\r\n"); - - tuf = _dawn_need_unit(u3do("turf:snap:dawn", u3k(u3t(sap))), - "boot: failed to extract " - "network domains from snapshot"); - } - else { - u3l_log("boot: retrieving network domains\r\n"); - - u3_noun oct = u3do("turf:give:dawn", u3k(bok)); - u3_noun fut = _dawn_eth_rpc(url_c, u3k(oct)); - - tuf = _dawn_need_unit(u3do("turf:take:dawn", u3k(fut)), - "boot: failed to retrieve network domains"); - u3z(oct); u3z(fut); - } - - u3z(rank); - - // [%dawn seed sponsor galaxies domains block eth-url snap] - // - return u3nc(c3__dawn, u3nq(seed, pon, zar, u3nq(tuf, bok, url, sap))); -} - -/* _dawn_come(): mine a comet under a list of stars -*/ -static u3_noun -_dawn_come(u3_noun stars) -{ - u3_noun seed; - { - c3_w eny_w[16]; - u3_noun eny; - - c3_rand(eny_w); - eny = u3i_words(16, eny_w); - - u3l_log("boot: mining a comet. May take up to an hour.\r\n"); - u3l_log("If you want to boot faster, get an Azimuth point.\r\n"); - - seed = u3dc("come:dawn", u3k(stars), u3k(eny)); - u3z(eny); - } - - { - u3_noun who = u3dc("scot", 'p', u3k(u3h(seed))); - c3_c* who_c = u3r_string(who); - - u3l_log("boot: found comet %s\r\n", who_c); - free(who_c); - u3z(who); - } - - u3z(stars); - - return seed; -} - -/* u3_dawn_come(): mine a comet under a list of stars we download -*/ -u3_noun -u3_dawn_come() -{ - return _dawn_come( - _dawn_get_jam("https://bootstrap.urbit.org/comet-stars.jam")); -} diff --git a/pkg/hair/notes/c/foil.c b/pkg/hair/notes/c/foil.c deleted file mode 100644 index 4bd4a401a..000000000 --- a/pkg/hair/notes/c/foil.c +++ /dev/null @@ -1,170 +0,0 @@ -/* vere/foil.c -** -** This file is in the public domain. -*/ - -#include "all.h" - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "vere/vere.h" - - /* assumptions: - ** all measurements are in chubs (double-words, c3_d, uint64_t). - ** little-endian addressing is ASSUMED. - ** - ** framing: - ** the last two chubs of a frame: - ** - ** { - ** 64-bit frame length - ** { - ** (high 32 bits) mug of frame - ** (low 32 bits) mug of current address - ** } - ** } - ** - ** we can scan for one of these frames with very low probability - ** of a false positive. we always write to and read from the end - ** of a file. a frame position points to its end. - ** - ** protocol: - ** once the callback is called, all results are fully fsynced. - ** all callbacks are optional and can be passed 0. - */ - -/* _foil_fail(): fail with error. -*/ -static void -_foil_fail(const c3_c* why_c, c3_i err_i) -{ - if ( err_i ) { - u3l_log("%s: error: %s\r\n", why_c, uv_strerror(err_i)); - c3_assert(0); - } else { - u3l_log("%s: file error\r\n", why_c); - } - exit(1); -} - -/* _foil_close(): close file, blockingly. -*/ -static void -_foil_close(uv_file fil_f) -{ - c3_i err_i; - uv_fs_t ruq_u; - - if ( 0 != (err_i = uv_fs_close(u3L, &ruq_u, fil_f, 0)) ) { - _foil_fail("uv_fs_close", err_i); - } -} - -/* _foil_path(): allocate path. -*/ -static c3_c* -_foil_path(u3_dire* dir_u, - const c3_c* nam_c) -{ - c3_w len_w = strlen(dir_u->pax_c); - c3_c* pax_c; - - pax_c = c3_malloc(1 + len_w + 1 + strlen(nam_c)); - strcpy(pax_c, dir_u->pax_c); - pax_c[len_w] = '/'; - strcpy(pax_c + len_w + 1, nam_c); - - return pax_c; -} - -/* u3_foil_folder(): load directory, blockingly. null if nonexistent. -*/ -u3_dire* -u3_foil_folder(const c3_c* pax_c) -{ - u3_dire* dir_u; - uv_fs_t ruq_u; - uv_dirent_t den_u; - c3_i err_i; - - /* open directory, synchronously - */ - { - err_i = uv_fs_scandir(u3L, &ruq_u, pax_c, 0, 0); - - if ( err_i < 0 ) { - if ( UV_ENOENT != err_i ) { - _foil_fail(pax_c, err_i); - return 0; - } - else { - if ( 0 != (err_i = uv_fs_mkdir(u3L, &ruq_u, pax_c, 0700, 0)) ) { - _foil_fail(pax_c, err_i); - return 0; - } - else { - uv_fs_req_cleanup(&ruq_u); - return u3_foil_folder(pax_c); - } - } - } - dir_u = c3_malloc(sizeof *dir_u); - dir_u->all_u = 0; - dir_u->pax_c = c3_malloc(1 + strlen(pax_c)); - strcpy(dir_u->pax_c, pax_c); - } - - /* create entries for all files - */ - while ( UV_EOF != uv_fs_scandir_next(&ruq_u, &den_u) ) { - if ( UV_DIRENT_FILE == den_u.type ) { - u3_dent* det_u = c3_malloc(sizeof(*det_u)); - - det_u->nam_c = c3_malloc(1 + strlen(den_u.name)); - strcpy(det_u->nam_c, den_u.name); - - det_u->nex_u = dir_u->all_u; - dir_u->all_u = det_u; - } - } - - /* clean up request - */ - { - uv_fs_req_cleanup(&ruq_u); - } - - /* open directory file for reading, to fsync - */ - { - if ( 0 > (err_i = uv_fs_open(u3L, - &ruq_u, - pax_c, - O_RDONLY, - 0600, - 0)) ) - { - _foil_fail("open directory", err_i); - return 0; - } - dir_u->fil_u = ruq_u.result; - - uv_fs_req_cleanup(&ruq_u); - } - return dir_u; -} diff --git a/pkg/hair/notes/c/hash_tests.c b/pkg/hair/notes/c/hash_tests.c deleted file mode 100644 index a362fec10..000000000 --- a/pkg/hair/notes/c/hash_tests.c +++ /dev/null @@ -1,105 +0,0 @@ -#include "all.h" - -/* _setup(): prepare for tests. -*/ -static void -_setup(void) -{ - u3m_init(); - u3m_pave(c3y, c3n); -} - -/* _test_mug(): spot check u3r_mug hashes. -*/ -static void -_test_mug(void) -{ - if ( 0x4d441035 != u3r_mug_string("Hello, world!") ) { - fprintf(stderr, "fail (a)\r\n"); - exit(1); - } - - if ( 0x4d441035 != u3r_mug(u3i_string("Hello, world!")) ) { - fprintf(stderr, "fail (b)\r\n"); - exit(1); - } - - if ( 0x79ff04e8 != u3r_mug_bytes(0, 0) ) { - fprintf(stderr, "fail (c)\r\n"); - exit(1); - } - - if ( 0x64dfda5c != u3r_mug(u3i_string("xxxxxxxxxxxxxxxxxxxxxxxxxxxx")) ) { - fprintf(stderr, "fail (d)\r\n"); - exit(1); - } - - if ( 0x389ca03a != u3r_mug_cell(0, 0) ) { - fprintf(stderr, "fail (e)\r\n"); - exit(1); - } - - if ( 0x389ca03a != u3r_mug_cell(1, 1) ) { - fprintf(stderr, "fail (f)\r\n"); - exit(1); - } - - if ( 0x5258a6c0 != u3r_mug_cell(0, u3qc_bex(32)) ) { - fprintf(stderr, "fail (g)\r\n"); - exit(1); - } - - if ( 0x2ad39968 != u3r_mug_cell(u3qa_dec(u3qc_bex(128)), 1) ) { - fprintf(stderr, "fail (h)\r\n"); - exit(1); - } - - { - // stick some zero bytes in a string - // - u3_noun str = u3kc_lsh(3, 1, - u3kc_mix(u3qc_bex(212), - u3i_string("abcdefjhijklmnopqrstuvwxyz"))); - - c3_w byt_w = u3r_met(3, str); - c3_w wor_w = u3r_met(5, str); - c3_y* str_y = c3_malloc(byt_w); - c3_w* str_w = c3_malloc(4 * wor_w); - c3_d str_d = 0; - - u3r_bytes(0, byt_w, str_y, str); - u3r_words(0, wor_w, str_w, str); - - str_d |= str_w[0]; - str_d |= ((c3_d)str_w[1] << 32ULL); - - if ( 0x34d08717 != u3r_mug(str) ) { - fprintf(stderr, "fail (i) (1) \r\n"); - exit(1); - } - if ( 0x34d08717 != u3r_mug_bytes(str_y, byt_w) ) { - fprintf(stderr, "fail (i) (2)\r\n"); - exit(1); - } - if ( 0x34d08717 != u3r_mug_words(str_w, wor_w) ) { - fprintf(stderr, "fail (i) (3)\r\n"); - exit(1); - } - if ( u3r_mug_words(str_w, 2) != u3r_mug_chub(str_d) ) { - fprintf(stderr, "fail (i) (4)\r\n"); - exit(1); - } - } -} - -/* main(): run all test cases. -*/ -int -main(int argc, char* argv[]) -{ - _setup(); - - _test_mug(); - - return 0; -} diff --git a/pkg/hair/notes/c/hashtable_tests.c b/pkg/hair/notes/c/hashtable_tests.c deleted file mode 100644 index 8955a000d..000000000 --- a/pkg/hair/notes/c/hashtable_tests.c +++ /dev/null @@ -1,144 +0,0 @@ -#include "all.h" - -static void _setup(void); -static void _test_cache_replace_value(void); -static void _test_cache_trimming(void); -static void _test_no_cache(void); -static void _test_skip_slot(void); - -// defined in noun/hashtable.c -c3_w _ch_skip_slot(c3_w mug_w, c3_w lef_w); - - -/* main(): run all test cases. -*/ -int -main(int argc, char* argv[]) -{ - _setup(); - - _test_no_cache(); - _test_skip_slot(); - _test_cache_trimming(); - _test_cache_replace_value(); - - return 0; -} - -/* _setup(): prepare for tests. -*/ -static void -_setup(void) -{ - u3m_init(); - u3m_pave(c3y, c3n); -} - -/* _test_no_cache(): test a hashtable without caching. -*/ -static void -_test_no_cache(void) -{ - c3_w i_w; - c3_w max_w = 1000; - - u3p(u3h_root) har_p = u3h_new(); - - for ( i_w = 0; i_w < max_w; i_w++ ) { - u3h_put(har_p, i_w, i_w + max_w); - } - - for ( i_w = 0; i_w < max_w; i_w++ ) { - c3_assert(i_w + max_w == u3h_get(har_p, i_w)); - } - printf("test_no_cache: ok\n"); -} - -/* _test_skip_slot(): -*/ -static void -_test_skip_slot(void) -{ - // root table - { - c3_w mug_w = 0x17 << 25; - c3_w res_w = _ch_skip_slot(mug_w, 25); - c3_assert((0x18 << 25) == res_w); - } - - { - c3_w mug_w = 63 << 25; // 6 bits, all ones - c3_w res_w = _ch_skip_slot(mug_w, 25); - c3_assert(0 == res_w); - } - - // child nodes - { - c3_w mug_w = 17 << 20; - c3_w res_w = _ch_skip_slot(mug_w, 20); - c3_assert((18 << 20) == res_w); - } - - { - c3_w mug_w = 31 << 20; // 5 bits, all ones - c3_w res_w = _ch_skip_slot(mug_w, 20); - c3_assert((1 << 25) == res_w); - } - - fprintf(stderr, "test_skip_slot: ok\n"); -} - -/* _test_cache_trimming(): ensure a caching hashtable removes stale items. -*/ -static void -_test_cache_trimming(void) -{ - c3_w max_w = 620; - c3_w i_w; - - //u3p(u3h_root) har_p = u3h_new_cache(max_w / 2); - u3p(u3h_root) har_p = u3h_new_cache(max_w / 10 ); - u3h_root* har_u = u3to(u3h_root, har_p); - - for ( i_w = 0; i_w < max_w; i_w++ ) { - u3h_put(har_p, i_w, i_w + max_w); - } - - if ( ( max_w + max_w - 1) != u3h_get(har_p, max_w - 1) ) { - fprintf(stderr, "fail\r\n"); - exit(1); - } - if ( ( max_w / 10 ) != har_u->use_w ) { - fprintf(stderr, "fail\r\n"); - exit(1); - } - fprintf(stderr, "test_cache_trimming: ok\n"); -} - -static void -_test_cache_replace_value(void) -{ - c3_w max_w = 100; - c3_w i_w; - - u3p(u3h_root) har_p = u3h_new_cache(max_w); - u3h_root* har_u = u3to(u3h_root, har_p); - - for ( i_w = 0; i_w < max_w; i_w++ ) { - u3h_put(har_p, i_w, i_w + max_w); - } - - for ( i_w = 0; i_w < max_w; i_w++ ) { - u3h_put(har_p, i_w, i_w + max_w + 1); - } - - if ( (2 * max_w) != u3h_get(har_p, max_w - 1) ) { - fprintf(stderr, "fail\r\n"); - exit(1); - } - if ( max_w != har_u->use_w ) { - fprintf(stderr, "fail\r\n"); - exit(1); - } - fprintf(stderr, "test_cache_replace_value: ok\r\n"); -} diff --git a/pkg/hair/notes/c/http.c b/pkg/hair/notes/c/http.c deleted file mode 100644 index 11dbe0bdd..000000000 --- a/pkg/hair/notes/c/http.c +++ /dev/null @@ -1,2908 +0,0 @@ -/* vere/http.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -typedef struct _u3_h2o_serv { - h2o_globalconf_t fig_u; // h2o global config - h2o_context_t ctx_u; // h2o ctx - h2o_accept_ctx_t cep_u; // h2o accept ctx - h2o_hostconf_t* hos_u; // h2o host config - h2o_handler_t* han_u; // h2o request handler -} u3_h2o_serv; - -static void _proxy_serv_free(u3_prox* lis_u); -static void _proxy_serv_close(u3_prox* lis_u); -static u3_prox* _proxy_serv_new(u3_http* htp_u, c3_s por_s, c3_o sec); -static u3_prox* _proxy_serv_start(u3_prox* lis_u); - -static void _http_serv_free(u3_http* htp_u); -static void _http_serv_start_all(void); -static void _http_form_free(void); - -static const c3_i TCP_BACKLOG = 16; - -// XX temporary, add to u3_http_ef_form -// -#define PROXY_DOMAIN "arvo.network" - -/* _http_vec_to_meth(): convert h2o_iovec_t to meth -*/ -static u3_weak -_http_vec_to_meth(h2o_iovec_t vec_u) -{ - return ( 0 == strncmp(vec_u.base, "GET", vec_u.len) ) ? c3__get : - ( 0 == strncmp(vec_u.base, "PUT", vec_u.len) ) ? c3__put : - ( 0 == strncmp(vec_u.base, "POST", vec_u.len) ) ? c3__post : - ( 0 == strncmp(vec_u.base, "HEAD", vec_u.len) ) ? c3__head : - ( 0 == strncmp(vec_u.base, "CONNECT", vec_u.len) ) ? c3__conn : - ( 0 == strncmp(vec_u.base, "DELETE", vec_u.len) ) ? c3__delt : - ( 0 == strncmp(vec_u.base, "OPTIONS", vec_u.len) ) ? c3__opts : - ( 0 == strncmp(vec_u.base, "TRACE", vec_u.len) ) ? c3__trac : - // TODO ?? - // ( 0 == strncmp(vec_u.base, "PATCH", vec_u.len) ) ? c3__patc : - u3_none; -} - -/* _http_vec_to_atom(): convert h2o_iovec_t to atom (cord) -*/ -static u3_noun -_http_vec_to_atom(h2o_iovec_t vec_u) -{ - return u3i_bytes(vec_u.len, (const c3_y*)vec_u.base); -} - -/* _http_vec_to_octs(): convert h2o_iovec_t to (unit octs) -*/ -static u3_noun -_http_vec_to_octs(h2o_iovec_t vec_u) -{ - if ( 0 == vec_u.len ) { - return u3_nul; - } - - // XX correct size_t -> atom? - return u3nt(u3_nul, u3i_chubs(1, (const c3_d*)&vec_u.len), - _http_vec_to_atom(vec_u)); -} - -/* _http_vec_from_octs(): convert (unit octs) to h2o_iovec_t -*/ -static h2o_iovec_t -_http_vec_from_octs(u3_noun oct) -{ - if ( u3_nul == oct ) { - return h2o_iovec_init(0, 0); - } - - // 2GB max - if ( c3n == u3a_is_cat(u3h(u3t(oct))) ) { - u3m_bail(c3__fail); - } - - c3_w len_w = u3h(u3t(oct)); - c3_y* buf_y = c3_malloc(1 + len_w); - buf_y[len_w] = 0; - - u3r_bytes(0, len_w, buf_y, u3t(u3t(oct))); - - u3z(oct); - return h2o_iovec_init(buf_y, len_w); -} - -/* _http_heds_to_noun(): convert h2o_header_t to (list (pair @t @t)) -*/ -static u3_noun -_http_heds_to_noun(h2o_header_t* hed_u, c3_d hed_d) -{ - u3_noun hed = u3_nul; - c3_d dex_d = hed_d; - - h2o_header_t deh_u; - - while ( 0 < dex_d ) { - deh_u = hed_u[--dex_d]; - hed = u3nc(u3nc(_http_vec_to_atom(*deh_u.name), - _http_vec_to_atom(deh_u.value)), hed); - } - - return hed; -} - -/* _http_heds_free(): free header linked list -*/ -static void -_http_heds_free(u3_hhed* hed_u) -{ - while ( hed_u ) { - u3_hhed* nex_u = hed_u->nex_u; - - free(hed_u->nam_c); - free(hed_u->val_c); - free(hed_u); - hed_u = nex_u; - } -} - -/* _http_hed_new(): create u3_hhed from nam/val cords -*/ -static u3_hhed* -_http_hed_new(u3_atom nam, u3_atom val) -{ - c3_w nam_w = u3r_met(3, nam); - c3_w val_w = u3r_met(3, val); - u3_hhed* hed_u = c3_malloc(sizeof(*hed_u)); - - hed_u->nam_c = c3_malloc(1 + nam_w); - hed_u->val_c = c3_malloc(1 + val_w); - hed_u->nam_c[nam_w] = 0; - hed_u->val_c[val_w] = 0; - hed_u->nex_u = 0; - hed_u->nam_w = nam_w; - hed_u->val_w = val_w; - - u3r_bytes(0, nam_w, (c3_y*)hed_u->nam_c, nam); - u3r_bytes(0, val_w, (c3_y*)hed_u->val_c, val); - - return hed_u; -} - -/* _http_heds_from_noun(): convert (list (pair @t @t)) to u3_hhed -*/ -static u3_hhed* -_http_heds_from_noun(u3_noun hed) -{ - u3_noun deh = hed; - u3_noun i_hed; - - u3_hhed* hed_u = 0; - - while ( u3_nul != hed ) { - i_hed = u3h(hed); - u3_hhed* nex_u = _http_hed_new(u3h(i_hed), u3t(i_hed)); - nex_u->nex_u = hed_u; - - hed_u = nex_u; - hed = u3t(hed); - } - - u3z(deh); - return hed_u; -} - -/* _http_req_find(): find http request in connection by sequence. -*/ -static u3_hreq* -_http_req_find(u3_hcon* hon_u, c3_w seq_l) -{ - u3_hreq* req_u = hon_u->req_u; - - // XX glories of linear search - // - while ( req_u ) { - if ( seq_l == req_u->seq_l ) { - return req_u; - } - req_u = req_u->nex_u; - } - return 0; -} - -/* _http_req_link(): link http request to connection -*/ -static void -_http_req_link(u3_hcon* hon_u, u3_hreq* req_u) -{ - req_u->hon_u = hon_u; - req_u->seq_l = hon_u->seq_l++; - req_u->nex_u = hon_u->req_u; - - if ( 0 != req_u->nex_u ) { - req_u->nex_u->pre_u = req_u; - } - hon_u->req_u = req_u; -} - -/* _http_req_unlink(): remove http request from connection -*/ -static void -_http_req_unlink(u3_hreq* req_u) -{ - if ( 0 != req_u->pre_u ) { - req_u->pre_u->nex_u = req_u->nex_u; - - if ( 0 != req_u->nex_u ) { - req_u->nex_u->pre_u = req_u->pre_u; - } - } - else { - req_u->hon_u->req_u = req_u->nex_u; - - if ( 0 != req_u->nex_u ) { - req_u->nex_u->pre_u = 0; - } - } -} - -/* _http_req_to_duct(): translate srv/con/req to duct -*/ -static u3_noun -_http_req_to_duct(u3_hreq* req_u) -{ - return u3nt(u3_blip, c3__http, - u3nq(u3dc("scot", c3_s2('u','v'), req_u->hon_u->htp_u->sev_l), - u3dc("scot", c3_s2('u','d'), req_u->hon_u->coq_l), - u3dc("scot", c3_s2('u','d'), req_u->seq_l), - u3_nul)); -} - -/* _http_req_kill(): kill http request in %eyre. -*/ -static void -_http_req_kill(u3_hreq* req_u) -{ - u3_noun pox = _http_req_to_duct(req_u); - u3_pier_plan(pox, u3nc(c3__thud, u3_nul)); -} - -/* _http_req_done(): request finished, deallocation callback -*/ -static void -_http_req_done(void* ptr_v) -{ - u3_hreq* req_u = (u3_hreq*)ptr_v; - - // client canceled request - if ( u3_rsat_plan == req_u->sat_e ) { - _http_req_kill(req_u); - } - - if ( 0 != req_u->tim_u ) { - uv_close((uv_handle_t*)req_u->tim_u, (uv_close_cb)free); - req_u->tim_u = 0; - } - - _http_req_unlink(req_u); -} - -/* _http_req_timer_cb(): request timeout callback -*/ -static void -_http_req_timer_cb(uv_timer_t* tim_u) -{ - u3_hreq* req_u = tim_u->data; - - if ( u3_rsat_plan == req_u->sat_e ) { - _http_req_kill(req_u); - req_u->sat_e = u3_rsat_ripe; - - c3_c* msg_c = "gateway timeout"; - h2o_send_error_generic(req_u->rec_u, 504, msg_c, msg_c, 0); - } -} - -/* _http_req_new(): receive http request. -*/ -static u3_hreq* -_http_req_new(u3_hcon* hon_u, h2o_req_t* rec_u) -{ - u3_hreq* req_u = h2o_mem_alloc_shared(&rec_u->pool, sizeof(*req_u), - _http_req_done); - req_u->rec_u = rec_u; - req_u->sat_e = u3_rsat_init; - req_u->tim_u = 0; - req_u->pre_u = 0; - - _http_req_link(hon_u, req_u); - - return req_u; -} - -/* _http_req_dispatch(): dispatch http request to %eyre -*/ -static void -_http_req_dispatch(u3_hreq* req_u, u3_noun req) -{ - c3_assert(u3_rsat_init == req_u->sat_e); - req_u->sat_e = u3_rsat_plan; - - u3_noun pox = _http_req_to_duct(req_u); - u3_noun typ = _(req_u->hon_u->htp_u->lop) ? c3__chis : c3__this; - - u3_pier_plan(pox, u3nq(typ, - req_u->hon_u->htp_u->sec, - u3nc(c3y, u3i_words(1, &req_u->hon_u->ipf_w)), - req)); -} - -typedef struct _u3_hgen { - h2o_generator_t neg_u; - h2o_iovec_t bod_u; - u3_hhed* hed_u; -} u3_hgen; - -/* _http_hgen_dispose(): dispose response generator and buffers -*/ -static void -_http_hgen_dispose(void* ptr_v) -{ - u3_hgen* gen_u = (u3_hgen*)ptr_v; - _http_heds_free(gen_u->hed_u); - free(gen_u->bod_u.base); -} - -/* _http_req_respond(): write httr to h2o_req_t->res and send -*/ -static void -_http_req_respond(u3_hreq* req_u, u3_noun sas, u3_noun hed, u3_noun bod) -{ - // XX ideally - //c3_assert(u3_rsat_plan == req_u->sat_e); - - if ( u3_rsat_plan != req_u->sat_e ) { - //u3l_log("duplicate response\n"); - return; - } - - req_u->sat_e = u3_rsat_ripe; - - uv_timer_stop(req_u->tim_u); - - h2o_req_t* rec_u = req_u->rec_u; - - rec_u->res.status = sas; - rec_u->res.reason = (sas < 200) ? "weird" : - (sas < 300) ? "ok" : - (sas < 400) ? "moved" : - (sas < 500) ? "missing" : - "hosed"; - - u3_hhed* hed_u = _http_heds_from_noun(u3k(hed)); - - u3_hgen* gen_u = h2o_mem_alloc_shared(&rec_u->pool, sizeof(*gen_u), - _http_hgen_dispose); - gen_u->neg_u = (h2o_generator_t){0, 0}; - gen_u->hed_u = hed_u; - - while ( 0 != hed_u ) { - h2o_add_header_by_str(&rec_u->pool, &rec_u->res.headers, - hed_u->nam_c, hed_u->nam_w, 0, 0, - hed_u->val_c, hed_u->val_w); - hed_u = hed_u->nex_u; - } - - gen_u->bod_u = _http_vec_from_octs(u3k(bod)); - rec_u->res.content_length = gen_u->bod_u.len; - - h2o_start_response(rec_u, &gen_u->neg_u); - h2o_send(rec_u, &gen_u->bod_u, 1, H2O_SEND_STATE_FINAL); - - { - u3_h2o_serv* h2o_u = req_u->hon_u->htp_u->h2o_u; - - if ( 0 != h2o_u->ctx_u.shutdown_requested ) { - rec_u->http1_is_persistent = 0; - } - } - - u3z(sas); u3z(hed); u3z(bod); -} - -/* _http_rec_to_httq(): convert h2o_req_t to httq -*/ -static u3_weak -_http_rec_to_httq(h2o_req_t* rec_u) -{ - u3_noun med = _http_vec_to_meth(rec_u->method); - - if ( u3_none == med ) { - return u3_none; - } - - u3_noun url = _http_vec_to_atom(rec_u->path); - u3_noun hed = _http_heds_to_noun(rec_u->headers.entries, - rec_u->headers.size); - - // restore host header - hed = u3nc(u3nc(u3i_string("host"), - _http_vec_to_atom(rec_u->authority)), - hed); - - u3_noun bod = _http_vec_to_octs(rec_u->entity); - - return u3nq(med, url, hed, bod); -} - -typedef struct _h2o_uv_sock { // see private st_h2o_uv_socket_t - h2o_socket_t sok_u; // socket - uv_stream_t* han_u; // client stream handler (u3_hcon) -} h2o_uv_sock; - -/* _http_rec_accept(); handle incoming http request from h2o. -*/ -static c3_i -_http_rec_accept(h2o_handler_t* han_u, h2o_req_t* rec_u) -{ - u3_weak req = _http_rec_to_httq(rec_u); - - if ( u3_none == req ) { - if ( (u3C.wag_w & u3o_verbose) ) { - u3l_log("strange %.*s request\n", (int)rec_u->method.len, - rec_u->method.base); - } - c3_c* msg_c = "bad request"; - h2o_send_error_generic(rec_u, 400, msg_c, msg_c, 0); - } - else { - h2o_uv_sock* suv_u = (h2o_uv_sock*)rec_u->conn-> - callbacks->get_socket(rec_u->conn); - u3_hcon* hon_u = (u3_hcon*)suv_u->han_u; - - // sanity check - c3_assert( hon_u->sok_u == &suv_u->sok_u ); - - u3_hreq* req_u = _http_req_new(hon_u, rec_u); - - req_u->tim_u = c3_malloc(sizeof(*req_u->tim_u)); - req_u->tim_u->data = req_u; - uv_timer_init(u3L, req_u->tim_u); - uv_timer_start(req_u->tim_u, _http_req_timer_cb, 900 * 1000, 0); - - _http_req_dispatch(req_u, req); - } - - return 0; -} - -/* _http_conn_find(): find http connection in server by sequence. -*/ -static u3_hcon* -_http_conn_find(u3_http *htp_u, c3_w coq_l) -{ - u3_hcon* hon_u = htp_u->hon_u; - - // XX glories of linear search - // - while ( hon_u ) { - if ( coq_l == hon_u->coq_l ) { - return hon_u; - } - hon_u = hon_u->nex_u; - } - return 0; -} - -/* _http_conn_link(): link http request to connection -*/ -static void -_http_conn_link(u3_http* htp_u, u3_hcon* hon_u) -{ - hon_u->htp_u = htp_u; - hon_u->coq_l = htp_u->coq_l++; - hon_u->nex_u = htp_u->hon_u; - - if ( 0 != hon_u->nex_u ) { - hon_u->nex_u->pre_u = hon_u; - } - htp_u->hon_u = hon_u; -} - -/* _http_conn_unlink(): remove http request from connection -*/ -static void -_http_conn_unlink(u3_hcon* hon_u) -{ - if ( 0 != hon_u->pre_u ) { - hon_u->pre_u->nex_u = hon_u->nex_u; - - if ( 0 != hon_u->nex_u ) { - hon_u->nex_u->pre_u = hon_u->pre_u; - } - } - else { - hon_u->htp_u->hon_u = hon_u->nex_u; - - if ( 0 != hon_u->nex_u ) { - hon_u->nex_u->pre_u = 0; - } - } -} - -/* _http_conn_free(): free http connection on close. -*/ -static void -_http_conn_free(uv_handle_t* han_t) -{ - u3_hcon* hon_u = (u3_hcon*)han_t; - u3_http* htp_u = hon_u->htp_u; - u3_h2o_serv* h2o_u = htp_u->h2o_u; - - c3_assert( 0 == hon_u->req_u ); - -#if 0 - { - c3_w len_w = 0; - - u3_hcon* noh_u = htp_u->hon_u; - - while ( 0 != noh_u ) { - len_w++; - noh_u = noh_u->nex_u; - } - - u3l_log("http conn free %d of %u server %d\n", hon_u->coq_l, len_w, htp_u->sev_l); - } -#endif - - _http_conn_unlink(hon_u); - -#if 0 - { - c3_w len_w = 0; - - u3_hcon* noh_u = htp_u->hon_u; - - while ( 0 != noh_u ) { - len_w++; - noh_u = noh_u->nex_u; - } - - u3l_log("http conn free %u remaining\n", len_w); - } -#endif - - if ( (0 == htp_u->hon_u) && (0 != h2o_u->ctx_u.shutdown_requested) ) { -#if 0 - u3l_log("http conn free %d free server %d\n", hon_u->coq_l, htp_u->sev_l); -#endif - _http_serv_free(htp_u); - } - - free(hon_u); -} - -/* _http_conn_new(): create and accept http connection. -*/ -static u3_hcon* -_http_conn_new(u3_http* htp_u) -{ - u3_hcon* hon_u = c3_malloc(sizeof(*hon_u)); - hon_u->seq_l = 1; - hon_u->ipf_w = 0; - hon_u->req_u = 0; - hon_u->sok_u = 0; - hon_u->con_u = 0; - hon_u->pre_u = 0; - - _http_conn_link(htp_u, hon_u); - -#if 0 - u3l_log("http conn neww %d server %d\n", hon_u->coq_l, htp_u->sev_l); -#endif - - return hon_u; -} - -/* _http_serv_find(): find http server by sequence. -*/ -static u3_http* -_http_serv_find(c3_l sev_l) -{ - u3_http* htp_u = u3_Host.htp_u; - - // XX glories of linear search - // - while ( htp_u ) { - if ( sev_l == htp_u->sev_l ) { - return htp_u; - } - htp_u = htp_u->nex_u; - } - return 0; -} - -/* _http_serv_link(): link http server to global state. -*/ -static void -_http_serv_link(u3_http* htp_u) -{ - // XX link elsewhere initially, relink on start? - - if ( 0 != u3_Host.htp_u ) { - htp_u->sev_l = 1 + u3_Host.htp_u->sev_l; - } - else { - htp_u->sev_l = u3A->sev_l; - } - - htp_u->nex_u = u3_Host.htp_u; - u3_Host.htp_u = htp_u; -} - -/* _http_serv_unlink(): remove http server from global state. -*/ -static void -_http_serv_unlink(u3_http* htp_u) -{ - // XX link elsewhere initially, relink on start? - - if ( u3_Host.htp_u == htp_u ) { - u3_Host.htp_u = htp_u->nex_u; - } - else { - u3_http* pre_u = u3_Host.htp_u; - - // XX glories of linear search - // - while ( pre_u ) { - if ( pre_u->nex_u == htp_u ) { - pre_u->nex_u = htp_u->nex_u; - } - else pre_u = pre_u->nex_u; - } - } -} - -/* _http_h2o_context_dispose(): h2o_context_dispose, inlined and cleaned up. -*/ -static void -_http_h2o_context_dispose(h2o_context_t* ctx) -{ - h2o_globalconf_t *config = ctx->globalconf; - size_t i, j; - - for (i = 0; config->hosts[i] != NULL; ++i) { - h2o_hostconf_t *hostconf = config->hosts[i]; - for (j = 0; j != hostconf->paths.size; ++j) { - h2o_pathconf_t *pathconf = hostconf->paths.entries + j; - h2o_context_dispose_pathconf_context(ctx, pathconf); - } - h2o_context_dispose_pathconf_context(ctx, &hostconf->fallback_path); - } - - free(ctx->_pathconfs_inited.entries); - free(ctx->_module_configs); - - h2o_timeout_dispose(ctx->loop, &ctx->zero_timeout); - h2o_timeout_dispose(ctx->loop, &ctx->hundred_ms_timeout); - h2o_timeout_dispose(ctx->loop, &ctx->handshake_timeout); - h2o_timeout_dispose(ctx->loop, &ctx->http1.req_timeout); - h2o_timeout_dispose(ctx->loop, &ctx->http2.idle_timeout); - - // NOTE: linked in http2/connection, never unlinked - h2o_timeout_unlink(&ctx->http2._graceful_shutdown_timeout); - - h2o_timeout_dispose(ctx->loop, &ctx->http2.graceful_shutdown_timeout); - h2o_timeout_dispose(ctx->loop, &ctx->proxy.io_timeout); - h2o_timeout_dispose(ctx->loop, &ctx->one_sec_timeout); - - h2o_filecache_destroy(ctx->filecache); - ctx->filecache = NULL; - - /* clear storage */ - for (i = 0; i != ctx->storage.size; ++i) { - h2o_context_storage_item_t *item = ctx->storage.entries + i; - if (item->dispose != NULL) { - item->dispose(item->data); - } - } - - free(ctx->storage.entries); - - h2o_multithread_unregister_receiver(ctx->queue, &ctx->receivers.hostinfo_getaddr); - h2o_multithread_destroy_queue(ctx->queue); - - if (ctx->_timestamp_cache.value != NULL) { - h2o_mem_release_shared(ctx->_timestamp_cache.value); - } - - // NOTE: explicit uv_run removed -} - -/* _http_serv_really_free(): free http server. -*/ -static void -_http_serv_really_free(u3_http* htp_u) -{ - c3_assert( 0 == htp_u->hon_u ); - - if ( 0 != htp_u->h2o_u ) { - u3_h2o_serv* h2o_u = htp_u->h2o_u; - - if ( 0 != h2o_u->cep_u.ssl_ctx ) { - SSL_CTX_free(h2o_u->cep_u.ssl_ctx); - } - - h2o_config_dispose(&h2o_u->fig_u); - - // XX h2o_cleanup_thread if not restarting? - - free(htp_u->h2o_u); - htp_u->h2o_u = 0; - } - - _http_serv_unlink(htp_u); - free(htp_u); -} - -/* http_serv_free_cb(): timer callback for freeing http server. -*/ -static void -http_serv_free_cb(uv_timer_t* tim_u) -{ - u3_http* htp_u = tim_u->data; - - _http_serv_really_free(htp_u); - - uv_close((uv_handle_t*)tim_u, (uv_close_cb)free); -} - -/* _http_serv_free(): begin to free http server. -*/ -static void -_http_serv_free(u3_http* htp_u) -{ -#if 0 - u3l_log("http serv free %d\n", htp_u->sev_l); -#endif - - c3_assert( 0 == htp_u->hon_u ); - - if ( 0 == htp_u->h2o_u ) { - _http_serv_really_free(htp_u); - } - else { - u3_h2o_serv* h2o_u = htp_u->h2o_u; - - _http_h2o_context_dispose(&h2o_u->ctx_u); - - // NOTE: free deferred to allow timers to be closed - // this is a heavy-handed workaround for the lack of - // close callbacks in h2o_timer_t - // it's unpredictable how many event-loop turns will - // be required to finish closing the underlying uv_timer_t - // and we can't free until that's done (or we have UB) - // testing reveals 5s to be a long enough deferral - uv_timer_t* tim_u = c3_malloc(sizeof(*tim_u)); - - tim_u->data = htp_u; - - uv_timer_init(u3L, tim_u); - uv_timer_start(tim_u, http_serv_free_cb, 5000, 0); - } -} - -/* _http_serv_close_cb(): http server uv_close callback. -*/ -static void -_http_serv_close_cb(uv_handle_t* han_u) -{ - u3_http* htp_u = (u3_http*)han_u; - htp_u->liv = c3n; - - // otherwise freed by the last linked connection - if ( 0 == htp_u->hon_u ) { - _http_serv_free(htp_u); - } - - // restart if all linked servers have been shutdown - { - htp_u = u3_Host.htp_u; - c3_o res = c3y; - - while ( 0 != htp_u ) { - if ( c3y == htp_u->liv ) { - res = c3n; - } - htp_u = htp_u->nex_u; - } - - if ( (c3y == res) && (0 != u3_Host.fig_u.for_u) ) { - _http_serv_start_all(); - } - } -} - -/* _http_serv_close(): close http server gracefully. -*/ -static void -_http_serv_close(u3_http* htp_u) -{ - u3_h2o_serv* h2o_u = htp_u->h2o_u; - h2o_context_request_shutdown(&h2o_u->ctx_u); - -#if 0 - u3l_log("http serv close %d %p\n", htp_u->sev_l, &htp_u->wax_u); -#endif - - uv_close((uv_handle_t*)&htp_u->wax_u, _http_serv_close_cb); - - if ( 0 != htp_u->rox_u ) { - // XX close soft - _proxy_serv_close(htp_u->rox_u); - htp_u->rox_u = 0; - } -} - -/* _http_serv_new(): create new http server. -*/ -static u3_http* -_http_serv_new(c3_s por_s, c3_o sec, c3_o lop) -{ - u3_http* htp_u = c3_malloc(sizeof(*htp_u)); - - htp_u->coq_l = 1; - htp_u->por_s = por_s; - htp_u->sec = sec; - htp_u->lop = lop; - htp_u->liv = c3y; - htp_u->h2o_u = 0; - htp_u->rox_u = 0; - htp_u->hon_u = 0; - htp_u->nex_u = 0; - - _http_serv_link(htp_u); - - return htp_u; -} - -/* _http_serv_accept(): accept new http connection. -*/ -static void -_http_serv_accept(u3_http* htp_u) -{ - u3_hcon* hon_u = _http_conn_new(htp_u); - - uv_tcp_init(u3L, &hon_u->wax_u); - - c3_i sas_i; - - if ( 0 != (sas_i = uv_accept((uv_stream_t*)&htp_u->wax_u, - (uv_stream_t*)&hon_u->wax_u)) ) { - if ( (u3C.wag_w & u3o_verbose) ) { - u3l_log("http: accept: %s\n", uv_strerror(sas_i)); - } - - uv_close((uv_handle_t*)&hon_u->wax_u, _http_conn_free); - return; - } - - hon_u->sok_u = h2o_uv_socket_create((uv_stream_t*)&hon_u->wax_u, - _http_conn_free); - - h2o_accept(&((u3_h2o_serv*)htp_u->h2o_u)->cep_u, hon_u->sok_u); - - // capture h2o connection (XX fragile) - hon_u->con_u = (h2o_conn_t*)hon_u->sok_u->data; - - struct sockaddr_in adr_u; - h2o_socket_getpeername(hon_u->sok_u, (struct sockaddr*)&adr_u); - hon_u->ipf_w = ( adr_u.sin_family != AF_INET ) ? - 0 : ntohl(adr_u.sin_addr.s_addr); -} - -/* _http_serv_listen_cb(): uv_connection_cb for uv_listen -*/ -static void -_http_serv_listen_cb(uv_stream_t* str_u, c3_i sas_i) -{ - u3_http* htp_u = (u3_http*)str_u; - - if ( 0 != sas_i ) { - u3l_log("http: listen_cb: %s\n", uv_strerror(sas_i)); - } - else { - _http_serv_accept(htp_u); - } -} - -/* _http_serv_init_h2o(): initialize h2o ctx and handlers for server. -*/ -static u3_h2o_serv* -_http_serv_init_h2o(SSL_CTX* tls_u, c3_o log, c3_o red) -{ - u3_h2o_serv* h2o_u = c3_calloc(sizeof(*h2o_u)); - - h2o_config_init(&h2o_u->fig_u); - h2o_u->fig_u.server_name = h2o_iovec_init( - H2O_STRLIT("urbit/vere-" URBIT_VERSION)); - - // XX default pending vhost/custom-domain design - // XX revisit the effect of specifying the port - h2o_u->hos_u = h2o_config_register_host(&h2o_u->fig_u, - h2o_iovec_init(H2O_STRLIT("default")), - 65535); - - h2o_u->cep_u.ctx = (h2o_context_t*)&h2o_u->ctx_u; - h2o_u->cep_u.hosts = h2o_u->fig_u.hosts; - h2o_u->cep_u.ssl_ctx = tls_u; - - h2o_u->han_u = h2o_create_handler(&h2o_u->hos_u->fallback_path, - sizeof(*h2o_u->han_u)); - if ( c3y == red ) { - // XX h2o_redirect_register - h2o_u->han_u->on_req = _http_rec_accept; - } - else { - h2o_u->han_u->on_req = _http_rec_accept; - } - - if ( c3y == log ) { - // XX move this to post serv_start and put the port in the name -#if 0 - c3_c* pax_c = u3_Host.dir_c; - u3_noun now = u3dc("scot", c3__da, u3k(u3A->now)); - c3_c* now_c = u3r_string(now); - c3_c* nam_c = ".access.log"; - c3_w len_w = 1 + strlen(pax_c) + 1 + strlen(now_c) + strlen(nam_c); - - c3_c* paf_c = c3_malloc(len_w); - snprintf(paf_c, len_w, "%s/%s%s", pax_c, now_c, nam_c); - - h2o_access_log_filehandle_t* fil_u = - h2o_access_log_open_handle(paf_c, 0, H2O_LOGCONF_ESCAPE_APACHE); - - h2o_access_log_register(&h2o_u->hos_u->fallback_path, fil_u); - - free(paf_c); - free(now_c); - u3z(now); -#endif - } - - // XX h2o_compress_register - - h2o_context_init(&h2o_u->ctx_u, u3L, &h2o_u->fig_u); - - return h2o_u; -} - -/* _http_serv_start(): start http server. -*/ -static void -_http_serv_start(u3_http* htp_u) -{ - struct sockaddr_in adr_u; - memset(&adr_u, 0, sizeof(adr_u)); - - adr_u.sin_family = AF_INET; - adr_u.sin_addr.s_addr = ( c3y == htp_u->lop ) ? - htonl(INADDR_LOOPBACK) : - INADDR_ANY; - - uv_tcp_init(u3L, &htp_u->wax_u); - - /* Try ascending ports. - */ - while ( 1 ) { - c3_i sas_i; - - adr_u.sin_port = htons(htp_u->por_s); - - if ( 0 != (sas_i = uv_tcp_bind(&htp_u->wax_u, - (const struct sockaddr*)&adr_u, 0)) || - 0 != (sas_i = uv_listen((uv_stream_t*)&htp_u->wax_u, - TCP_BACKLOG, _http_serv_listen_cb)) ) { - if ( (UV_EADDRINUSE == sas_i) || (UV_EACCES == sas_i) ) { - if ( (c3y == htp_u->sec) && (443 == htp_u->por_s) ) { - htp_u->por_s = 8443; - } - else if ( (c3n == htp_u->sec) && (80 == htp_u->por_s) ) { - htp_u->por_s = 8080; - } - else { - htp_u->por_s++; - } - - continue; - } - - u3l_log("http: listen: %s\n", uv_strerror(sas_i)); - - if ( 0 != htp_u->rox_u ) { - _proxy_serv_free(htp_u->rox_u); - } - _http_serv_free(htp_u); - return; - } - - // XX this is weird - if ( 0 != htp_u->rox_u ) { - htp_u->rox_u = _proxy_serv_start(htp_u->rox_u); - } - - if ( 0 != htp_u->rox_u ) { - u3l_log("http: live (%s, %s) on %d (proxied on %d)\n", - (c3y == htp_u->sec) ? "secure" : "insecure", - (c3y == htp_u->lop) ? "loopback" : "public", - htp_u->por_s, - htp_u->rox_u->por_s); - } - else { - u3l_log("http: live (%s, %s) on %d\n", - (c3y == htp_u->sec) ? "secure" : "insecure", - (c3y == htp_u->lop) ? "loopback" : "public", - htp_u->por_s); - } - - break; - } -} - -//XX deduplicate these with cttp - -/* _cttp_mcut_char(): measure/cut character. -*/ -static c3_w -_cttp_mcut_char(c3_c* buf_c, c3_w len_w, c3_c chr_c) -{ - if ( buf_c ) { - buf_c[len_w] = chr_c; - } - return len_w + 1; -} - -/* _cttp_mcut_cord(): measure/cut cord. -*/ -static c3_w -_cttp_mcut_cord(c3_c* buf_c, c3_w len_w, u3_noun san) -{ - c3_w ten_w = u3r_met(3, san); - - if ( buf_c ) { - u3r_bytes(0, ten_w, (c3_y *)(buf_c + len_w), san); - } - u3z(san); - return (len_w + ten_w); -} - -/* _cttp_mcut_path(): measure/cut cord list. -*/ -static c3_w -_cttp_mcut_path(c3_c* buf_c, c3_w len_w, c3_c sep_c, u3_noun pax) -{ - u3_noun axp = pax; - - while ( u3_nul != axp ) { - u3_noun h_axp = u3h(axp); - - len_w = _cttp_mcut_cord(buf_c, len_w, u3k(h_axp)); - axp = u3t(axp); - - if ( u3_nul != axp ) { - len_w = _cttp_mcut_char(buf_c, len_w, sep_c); - } - } - u3z(pax); - return len_w; -} - -static uv_buf_t -_http_wain_to_buf(u3_noun wan) -{ - c3_w len_w = _cttp_mcut_path(0, 0, (c3_c)10, u3k(wan)); - c3_c* buf_c = c3_malloc(1 + len_w); - - _cttp_mcut_path(buf_c, 0, (c3_c)10, wan); - buf_c[len_w] = 0; - - return uv_buf_init(buf_c, len_w); -} - -/* _http_init_tls: initialize OpenSSL context -*/ -static SSL_CTX* -_http_init_tls(uv_buf_t key_u, uv_buf_t cer_u) -{ - // XX require 1.1.0 and use TLS_server_method() - SSL_CTX* tls_u = SSL_CTX_new(SSLv23_server_method()); - // XX use SSL_CTX_set_max_proto_version() and SSL_CTX_set_min_proto_version() - SSL_CTX_set_options(tls_u, SSL_OP_NO_SSLv2 | - SSL_OP_NO_SSLv3 | - // SSL_OP_NO_TLSv1 | // XX test - SSL_OP_NO_COMPRESSION); - - SSL_CTX_set_default_verify_paths(tls_u); - SSL_CTX_set_session_cache_mode(tls_u, SSL_SESS_CACHE_OFF); - SSL_CTX_set_cipher_list(tls_u, - "ECDH+AESGCM:DH+AESGCM:ECDH+AES256:DH+AES256:" - "ECDH+AES128:DH+AES:ECDH+3DES:DH+3DES:RSA+AESGCM:" - "RSA+AES:RSA+3DES:!aNULL:!MD5:!DSS"); - - // enable ALPN for HTTP 2 support -#if H2O_USE_ALPN - { - SSL_CTX_set_ecdh_auto(tls_u, 1); - h2o_ssl_register_alpn_protocols(tls_u, h2o_http2_alpn_protocols); - } -#endif - - { - BIO* bio_u = BIO_new_mem_buf(key_u.base, key_u.len); - EVP_PKEY* pky_u = PEM_read_bio_PrivateKey(bio_u, 0, 0, 0); - c3_i sas_i = SSL_CTX_use_PrivateKey(tls_u, pky_u); - - EVP_PKEY_free(pky_u); - BIO_free(bio_u); - - if( 0 == sas_i ) { - u3l_log("http: load private key failed:\n"); - ERR_print_errors_fp(u3_term_io_hija()); - u3_term_io_loja(1); - - SSL_CTX_free(tls_u); - - return 0; - } - } - - { - BIO* bio_u = BIO_new_mem_buf(cer_u.base, cer_u.len); - X509* xer_u = PEM_read_bio_X509_AUX(bio_u, 0, 0, 0); - c3_i sas_i = SSL_CTX_use_certificate(tls_u, xer_u); - - X509_free(xer_u); - - if( 0 == sas_i ) { - u3l_log("http: load certificate failed:\n"); - ERR_print_errors_fp(u3_term_io_hija()); - u3_term_io_loja(1); - - BIO_free(bio_u); - SSL_CTX_free(tls_u); - - return 0; - } - - // get any additional CA certs, ignoring errors - while ( 0 != (xer_u = PEM_read_bio_X509(bio_u, 0, 0, 0)) ) { - // XX require 1.0.2 or newer and use SSL_CTX_add0_chain_cert - SSL_CTX_add_extra_chain_cert(tls_u, xer_u); - } - - BIO_free(bio_u); - } - - return tls_u; -} - -/* _http_write_ports_file(): update .http.ports -*/ -static void -_http_write_ports_file(c3_c *pax_c) -{ - c3_c* nam_c = ".http.ports"; - c3_w len_w = 1 + strlen(pax_c) + 1 + strlen(nam_c); - - c3_c* paf_c = c3_malloc(len_w); - snprintf(paf_c, len_w, "%s/%s", pax_c, nam_c); - - c3_i por_i = open(paf_c, O_WRONLY | O_CREAT | O_TRUNC, 0666); - free(paf_c); - - u3_http* htp_u = u3_Host.htp_u; - - while ( 0 != htp_u ) { - // XX write proxy ports instead? - if ( 0 < htp_u->por_s ) { - dprintf(por_i, "%u %s %s\n", htp_u->por_s, - (c3y == htp_u->sec) ? "secure" : "insecure", - (c3y == htp_u->lop) ? "loopback" : "public"); - } - - htp_u = htp_u->nex_u; - } - - c3_sync(por_i); - close(por_i); -} - -/* _http_release_ports_file(): remove .http.ports -*/ -static void -_http_release_ports_file(c3_c *pax_c) -{ - c3_c* nam_c = ".http.ports"; - c3_w len_w = 1 + strlen(pax_c) + 1 + strlen(nam_c); - - c3_c* paf_c = c3_malloc(len_w); - snprintf(paf_c, len_w, "%s/%s", pax_c, nam_c); - - unlink(paf_c); - free(paf_c); -} - - -/* _http_czar_host(): galaxy hostname as (unit host:eyre) -*/ -static u3_noun -_http_czar_host(void) -{ - u3_noun dom = u3_nul; - return dom; - - // XX revisit -#if 0 - if ( (0 == u3_Host.ops_u.imp_c) || (c3n == u3_Host.ops_u.net) ) { - return dom; - } - - { - c3_c* dns_c = u3_Host.ops_u.dns_c; - c3_w len_w = strlen(dns_c); - c3_w dif_w; - c3_c* dom_c; - c3_c* dot_c; - - while ( 0 != len_w ) { - if ( 0 == (dot_c = strchr(dns_c, '.'))) { - len_w = 0; - dom = u3nc(u3i_string(dns_c), dom); - break; - } - else { - dif_w = dot_c - dns_c; - dom_c = c3_malloc(1 + dif_w); - strncpy(dom_c, dns_c, dif_w); - dom_c[dif_w] = 0; - - dom = u3nc(u3i_string(dom_c), dom); - - // increment to skip leading '.' - dns_c = dot_c + 1; - free(dom_c); - - // XX confirm that underflow is impossible here - len_w -= c3_min(dif_w, len_w); - } - } - } - - if ( u3_nul == dom ) { - return dom; - } - - // increment to skip '~' - dom = u3nc(u3i_string(u3_Host.ops_u.imp_c + 1), u3kb_flop(u3k(dom))); - - return u3nt(u3_nul, c3y, u3kb_flop(u3k(dom))); -#endif -} - -/* u3_http_ef_bake(): notify %eyre that we're live -*/ -void -u3_http_ef_bake(void) -{ - u3_noun ipf = u3_nul; - - { - struct ifaddrs* iad_u; - getifaddrs(&iad_u); - - struct ifaddrs* dia_u = iad_u; - - while ( iad_u ) { - struct sockaddr_in* adr_u = (struct sockaddr_in *)iad_u->ifa_addr; - - if ( (0 != adr_u) && (AF_INET == adr_u->sin_family) ) { - c3_w ipf_w = ntohl(adr_u->sin_addr.s_addr); - - if ( INADDR_LOOPBACK != ipf_w ) { - ipf = u3nc(u3nc(c3n, u3i_words(1, &ipf_w)), ipf); - } - } - - iad_u = iad_u->ifa_next; - } - - freeifaddrs(dia_u); - } - - u3_noun hot = _http_czar_host(); - - if ( u3_nul != hot ) { - ipf = u3nc(u3k(u3t(hot)), ipf); - u3z(hot); - } - - u3_noun pax = u3nq(u3_blip, c3__http, u3k(u3A->sen), u3_nul); - - u3_pier_plan(pax, u3nc(c3__born, ipf)); -} - -/* u3_http_ef_thou(): send %thou from %eyre as http response. -*/ -void -u3_http_ef_thou(c3_l sev_l, - c3_l coq_l, - c3_l seq_l, - u3_noun rep) -{ - u3_http* htp_u; - u3_hcon* hon_u; - u3_hreq* req_u; - c3_w bug_w = u3C.wag_w & u3o_verbose; - - if ( !(htp_u = _http_serv_find(sev_l)) ) { - if ( bug_w ) { - u3l_log("http: server not found: %x\r\n", sev_l); - } - } - else if ( !(hon_u = _http_conn_find(htp_u, coq_l)) ) { - if ( bug_w ) { - u3l_log("http: connection not found: %x/%d\r\n", sev_l, coq_l); - } - } - else if ( !(req_u = _http_req_find(hon_u, seq_l)) ) { - if ( bug_w ) { - u3l_log("http: request not found: %x/%d/%d\r\n", - sev_l, coq_l, seq_l); - } - } - else { - u3_noun p_rep, q_rep, r_rep; - - if ( c3n == u3r_trel(rep, &p_rep, &q_rep, &r_rep) ) { - u3l_log("http: strange response\n"); - } - else { - _http_req_respond(req_u, u3k(p_rep), u3k(q_rep), u3k(r_rep)); - } - } - - u3z(rep); -} - -/* _http_serv_start_all(): initialize and start servers based on saved config. -*/ -static void -_http_serv_start_all(void) -{ - u3_http* htp_u; - c3_s por_s; - - u3_noun sec = u3_nul; - u3_noun non = u3_none; - - u3_form* for_u = u3_Host.fig_u.for_u; - - c3_assert( 0 != for_u ); - - // if the SSL_CTX existed, it'll be freed with the servers - u3_Host.tls_u = 0; - - // HTTPS server. - if ( (0 != for_u->key_u.base) && (0 != for_u->cer_u.base) ) { - u3_Host.tls_u = _http_init_tls(for_u->key_u, for_u->cer_u); - - // Note: if tls_u is used for additional servers, - // its reference count must be incremented with SSL_CTX_up_ref - - if ( 0 != u3_Host.tls_u ) { - por_s = ( c3y == for_u->pro ) ? 8443 : 443; - htp_u = _http_serv_new(por_s, c3y, c3n); - htp_u->h2o_u = _http_serv_init_h2o(u3_Host.tls_u, for_u->log, for_u->red); - - if ( c3y == for_u->pro ) { - htp_u->rox_u = _proxy_serv_new(htp_u, 443, c3y); - } - - _http_serv_start(htp_u); - sec = u3nc(u3_nul, htp_u->por_s); - } - } - - // HTTP server. - { - por_s = ( c3y == for_u->pro ) ? 8080 : 80; - htp_u = _http_serv_new(por_s, c3n, c3n); - htp_u->h2o_u = _http_serv_init_h2o(0, for_u->log, for_u->red); - - if ( c3y == for_u->pro ) { - htp_u->rox_u = _proxy_serv_new(htp_u, 80, c3n); - } - - _http_serv_start(htp_u); - non = htp_u->por_s; - } - - // Loopback server. - { - por_s = 12321; - htp_u = _http_serv_new(por_s, c3n, c3y); - htp_u->h2o_u = _http_serv_init_h2o(0, for_u->log, for_u->red); - // never proxied - - _http_serv_start(htp_u); - } - - // send listening ports to %eyre - { - c3_assert( u3_none != non ); - - u3_noun pax = u3nq(u3_blip, c3__http, u3k(u3A->sen), u3_nul); - u3_pier_plan(pax, u3nt(c3__live, non, sec)); - } - - _http_write_ports_file(u3_Host.dir_c); - _http_form_free(); -} - -/* _http_serv_restart(): gracefully shutdown, then start servers. -*/ -static void -_http_serv_restart(void) -{ - u3_http* htp_u = u3_Host.htp_u; - - if ( 0 == htp_u ) { - _http_serv_start_all(); - } - else { - u3l_log("http: restarting servers to apply configuration\n"); - - while ( 0 != htp_u ) { - if ( c3y == htp_u->liv ) { - _http_serv_close(htp_u); - } - htp_u = htp_u->nex_u; - } - - _http_release_ports_file(u3_Host.dir_c); - } -} - -/* _http_form_free(): free and unlink saved config. -*/ -static void -_http_form_free(void) -{ - u3_form* for_u = u3_Host.fig_u.for_u; - - if ( 0 == for_u ) { - return; - } - - if ( 0 != for_u->key_u.base ) { - free(for_u->key_u.base); - } - - if ( 0 != for_u->cer_u.base ) { - free(for_u->cer_u.base); - } - - free(for_u); - u3_Host.fig_u.for_u = 0; -} - -/* u3_http_ef_form(): apply configuration, restart servers. -*/ -void -u3_http_ef_form(u3_noun fig) -{ - u3_noun sec, pro, log, red; - - if ( (c3n == u3r_qual(fig, &sec, &pro, &log, &red) ) || - // confirm sec is a valid (unit ^) - !( u3_nul == sec || ( c3y == u3du(sec) && - c3y == u3du(u3t(sec)) && - u3_nul == u3h(sec) ) ) || - // confirm valid flags ("loobeans") - !( c3y == pro || c3n == pro ) || - !( c3y == log || c3n == log ) || - !( c3y == red || c3n == red ) ) { - u3l_log("http: form: invalid card\n"); - u3z(fig); - return; - } - - u3_form* for_u = c3_malloc(sizeof(*for_u)); - for_u->pro = (c3_o)pro; - for_u->log = (c3_o)log; - for_u->red = (c3_o)red; - - if ( u3_nul != sec ) { - u3_noun key = u3h(u3t(sec)); - u3_noun cer = u3t(u3t(sec)); - - for_u->key_u = _http_wain_to_buf(u3k(key)); - for_u->cer_u = _http_wain_to_buf(u3k(cer)); - } - else { - for_u->key_u = uv_buf_init(0, 0); - for_u->cer_u = uv_buf_init(0, 0); - } - - u3z(fig); - _http_form_free(); - - u3_Host.fig_u.for_u = for_u; - - _http_serv_restart(); -} - -/* u3_http_io_init(): initialize http I/O. -*/ -void -u3_http_io_init(void) -{ -} - -/* u3_http_io_talk(): start http I/O. -*/ -void -u3_http_io_talk(void) -{ -} - -/* u3_http_io_exit(): shut down http. -*/ -void -u3_http_io_exit(void) -{ - // Note: nothing in this codepath can print to uH! - // it will seriously mess up your terminal - - // u3_http* htp_u; - - // for ( htp_u = u3_Host.htp_u; htp_u; htp_u = htp_u->nex_u ) { - // _http_serv_close_hard(htp_u); - // } - - // XX close u3_Host.fig_u.cli_u and con_u - - _http_release_ports_file(u3_Host.dir_c); -} - -/////////////////////////////////////////////////////////////////////////////// -/////////////////////////////////////////////////////////////////////////////// -/////////////////////////////////////////////////////////////////////////////// - -typedef enum { - u3_pars_good = 0, // success - u3_pars_fail = 1, // failure - u3_pars_moar = 2 // incomplete -} u3_proxy_pars; - -/* _proxy_alloc(): libuv buffer allocator -*/ -static void -_proxy_alloc(uv_handle_t* had_u, - size_t len_i, - uv_buf_t* buf) -{ - // len_i is always 64k, so we're ignoring it - // using fixed size 4K buffer for - // XX consider h2o_buffer_t, a pool, or something XX - void* ptr_v = c3_malloc(4096); - *buf = uv_buf_init(ptr_v, 4096); -} - -/* _proxy_warc_link(): link warc to global state. -*/ -static void -_proxy_warc_link(u3_warc* cli_u) -{ - cli_u->nex_u = u3_Host.fig_u.cli_u; - - if ( 0 != cli_u->nex_u ) { - cli_u->nex_u->pre_u = cli_u; - } - u3_Host.fig_u.cli_u = cli_u; -} - -/* _proxy_warc_unlink(): unlink warc from global state. -*/ -static void -_proxy_warc_unlink(u3_warc* cli_u) -{ - if ( 0 != cli_u->pre_u ) { - cli_u->pre_u->nex_u = cli_u->nex_u; - - if ( 0 != cli_u->nex_u ) { - cli_u->nex_u->pre_u = cli_u->pre_u; - } - } - else { - u3_Host.fig_u.cli_u = cli_u->nex_u; - - if ( 0 != cli_u->nex_u ) { - cli_u->nex_u->pre_u = 0; - } - } -} - -/* _proxy_warc_free(): free ward client -*/ -static void -_proxy_warc_free(u3_warc* cli_u) -{ - _proxy_warc_unlink(cli_u); - free(cli_u->non_u.base); - free(cli_u->hot_c); - free(cli_u); -} - -/* _proxy_warc_new(): allocate ship-specific proxy client -*/ -static u3_warc* -_proxy_warc_new(u3_http* htp_u, u3_atom sip, u3_atom non, c3_s por_s, c3_o sec) -{ - u3_warc* cli_u = c3_calloc(sizeof(*cli_u)); - cli_u->htp_u = htp_u; - cli_u->por_s = por_s; - cli_u->sec = sec; - - u3r_chubs(0, 2, cli_u->who_d, sip); - _proxy_warc_link(cli_u); - - { - c3_w len_w = u3r_met(3, non); - - c3_assert( 256 > len_w ); - - c3_y* non_y = c3_malloc(1 + len_w); - non_y[0] = (c3_y)len_w; - - u3r_bytes(0, len_w, non_y + 1, non); - - cli_u->non_u = uv_buf_init((c3_c*)non_y, 1 + len_w); - } - - u3z(non); - u3z(sip); - - return cli_u; -} - -/* _proxy_conn_link(): link con to listener or global state. -*/ -static void -_proxy_conn_link(u3_pcon* con_u) -{ - switch ( con_u->typ_e ) { - default: c3_assert(0); - - case u3_ptyp_ward: { - con_u->nex_u = u3_Host.fig_u.con_u; - - if ( 0 != con_u->nex_u ) { - con_u->nex_u->pre_u = con_u; - } - u3_Host.fig_u.con_u = con_u; - break; - } - - case u3_ptyp_prox: { - u3_prox* lis_u = con_u->src_u.lis_u; - con_u->nex_u = lis_u->con_u; - - if ( 0 != con_u->nex_u ) { - con_u->nex_u->pre_u = con_u; - } - lis_u->con_u = con_u; - break; - } - } -} - -/* _proxy_conn_unlink(): unlink con from listener or global state. -*/ -static void -_proxy_conn_unlink(u3_pcon* con_u) -{ - if ( 0 != con_u->pre_u ) { - con_u->pre_u->nex_u = con_u->nex_u; - - if ( 0 != con_u->nex_u ) { - con_u->nex_u->pre_u = con_u->pre_u; - } - } - else { - switch ( con_u->typ_e ) { - default: c3_assert(0); - - case u3_ptyp_ward: { - u3_Host.fig_u.con_u = con_u->nex_u; - - if ( 0 != con_u->nex_u ) { - con_u->nex_u->pre_u = 0; - } - break; - } - - case u3_ptyp_prox: { - u3_prox* lis_u = con_u->src_u.lis_u; - lis_u->con_u = con_u->nex_u; - - if ( 0 != con_u->nex_u ) { - con_u->nex_u->pre_u = 0; - } - break; - } - } - } -} - -/* _proxy_conn_free(): free proxy connection -*/ -static void -_proxy_conn_free(uv_handle_t* han_u) -{ - u3_pcon* con_u = han_u->data; - - if ( 0 != con_u->buf_u.base ) { - free(con_u->buf_u.base); - } - - if ( u3_ptyp_ward == con_u->typ_e ) { - _proxy_warc_free(con_u->src_u.cli_u); - } - - _proxy_conn_unlink(con_u); - - free(con_u); -} - -/* _proxy_conn_close(): close both sides of proxy connection -*/ -static void -_proxy_conn_close(u3_pcon* con_u) -{ - // XX revisit, this is called twice when con_u - // is a loopback connection and we're restarting - if ( uv_is_closing((uv_handle_t*)&con_u->don_u) ){ - return; - } - - if ( 0 != con_u->upt_u ) { - uv_close((uv_handle_t*)con_u->upt_u, (uv_close_cb)free); - } - - uv_close((uv_handle_t*)&con_u->don_u, _proxy_conn_free); -} - -/* _proxy_conn_new(): allocate proxy connection -*/ -static u3_pcon* -_proxy_conn_new(u3_proxy_type typ_e, void* src_u) -{ - u3_pcon* con_u = c3_malloc(sizeof(*con_u)); - con_u->upt_u = 0; - con_u->buf_u = uv_buf_init(0, 0); - con_u->nex_u = 0; - con_u->pre_u = 0; - - switch ( typ_e ) { - default: c3_assert(0); - - case u3_ptyp_prox: { - u3_prox* lis_u = (u3_prox*)src_u; - con_u->typ_e = typ_e; - con_u->src_u.lis_u = lis_u; - con_u->sec = lis_u->sec; - break; - } - - case u3_ptyp_ward: { - u3_warc* cli_u = (u3_warc*)src_u; - con_u->typ_e = typ_e; - con_u->src_u.cli_u = cli_u; - con_u->sec = cli_u->sec; - break; - } - } - - con_u->don_u.data = con_u; - - _proxy_conn_link(con_u); - - return con_u; -} - -typedef struct _proxy_write_ctx { - u3_pcon* con_u; - uv_stream_t* str_u; - c3_c* buf_c; -} proxy_write_ctx; - -/* _proxy_write_cb(): free uv_write_t and linked buffer. -*/ -static void -_proxy_write_cb(uv_write_t* wri_u, c3_i sas_i) -{ - if ( 0 != sas_i ) { - if ( 0 != wri_u->data ) { - proxy_write_ctx* ctx_u = wri_u->data; - - if ( ctx_u->str_u == (uv_stream_t*)ctx_u->con_u->upt_u ) { - u3l_log("proxy: write upstream: %s\n", uv_strerror(sas_i)); - } - else if ( ctx_u->str_u == (uv_stream_t*)&(ctx_u->con_u->don_u) ) { - u3l_log("proxy: write downstream: %s\n", uv_strerror(sas_i)); - } - else { - u3l_log("proxy: write: %s\n", uv_strerror(sas_i)); - } - } - else { - u3l_log("proxy: write: %s\n", uv_strerror(sas_i)); - } - } - - if ( 0 != wri_u->data ) { - proxy_write_ctx* ctx_u = wri_u->data; - free(ctx_u->buf_c); - free(ctx_u); - } - - free(wri_u); -} - -/* _proxy_write(): write buffer to proxy stream -*/ -static c3_i -_proxy_write(u3_pcon* con_u, uv_stream_t* str_u, uv_buf_t buf_u) -{ - uv_write_t* wri_u = c3_malloc(sizeof(*wri_u)); - - proxy_write_ctx* ctx_u = c3_malloc(sizeof(*ctx_u)); - ctx_u->con_u = con_u; - ctx_u->str_u = str_u; - ctx_u->buf_c = buf_u.base; - wri_u->data = ctx_u; - - c3_i sas_i; - if ( 0 != (sas_i = uv_write(wri_u, str_u, &buf_u, 1, _proxy_write_cb)) ) { - _proxy_conn_close(con_u); - _proxy_write_cb(wri_u, sas_i); - } - - return sas_i; -} - -/* _proxy_read_downstream_cb(): read from downstream, write upstream. -*/ -static void -_proxy_read_downstream_cb(uv_stream_t* don_u, - ssize_t siz_w, - const uv_buf_t* buf_u) -{ - u3_pcon* con_u = don_u->data; - - if ( 0 > siz_w ) { - if ( UV_EOF != siz_w ) { - u3l_log("proxy: read downstream: %s\n", uv_strerror(siz_w)); - } - _proxy_conn_close(con_u); - } - else { - _proxy_write(con_u, (uv_stream_t*)con_u->upt_u, - uv_buf_init(buf_u->base, siz_w)); - } -} - -/* _proxy_read_upstream_cb(): read from upstream, write downstream. -*/ -static void -_proxy_read_upstream_cb(uv_stream_t* upt_u, - ssize_t siz_w, - const uv_buf_t* buf_u) -{ - u3_pcon* con_u = upt_u->data; - - if ( 0 > siz_w ) { - if ( UV_EOF != siz_w ) { - u3l_log("proxy: read upstream: %s\n", uv_strerror(siz_w)); - } - _proxy_conn_close(con_u); - } - else { - _proxy_write(con_u, (uv_stream_t*)&(con_u->don_u), - uv_buf_init(buf_u->base, siz_w)); - } -} - -/* _proxy_fire(): send pending buffer upstream, setup full duplex. -*/ -static void -_proxy_fire(u3_pcon* con_u) -{ - if ( 0 != con_u->buf_u.base ) { - uv_buf_t fub_u = con_u->buf_u; - con_u->buf_u = uv_buf_init(0, 0); - - if ( 0 != _proxy_write(con_u, (uv_stream_t*)con_u->upt_u, fub_u) ) { - return; - } - } - - // XX set cooldown timers to close these? - - uv_read_start((uv_stream_t*)&con_u->don_u, - _proxy_alloc, _proxy_read_downstream_cb); - - uv_read_start((uv_stream_t*)con_u->upt_u, - _proxy_alloc, _proxy_read_upstream_cb); -} - -/* _proxy_loop_connect_cb(): callback for loopback proxy connect. -*/ -static void -_proxy_loop_connect_cb(uv_connect_t * upc_u, c3_i sas_i) -{ - u3_pcon* con_u = upc_u->data; - - if ( 0 != sas_i ) { - u3l_log("proxy: connect: %s\n", uv_strerror(sas_i)); - _proxy_conn_close(con_u); - } - else { - _proxy_fire(con_u); - } - - free(upc_u); -} - -/* _proxy_loop_connect(): connect to loopback. -*/ -static void -_proxy_loop_connect(u3_pcon* con_u) -{ - uv_tcp_t* upt_u = c3_malloc(sizeof(*upt_u)); - - con_u->upt_u = upt_u; - upt_u->data = con_u; - - uv_tcp_init(u3L, upt_u); - - struct sockaddr_in lop_u; - - memset(&lop_u, 0, sizeof(lop_u)); - lop_u.sin_family = AF_INET; - lop_u.sin_addr.s_addr = htonl(INADDR_LOOPBACK); - - // get the loopback port from the linked server - { - u3_http* htp_u; - - switch ( con_u->typ_e ) { - default: c3_assert(0); - - case u3_ptyp_ward: { - htp_u = con_u->src_u.cli_u->htp_u; - break; - } - - case u3_ptyp_prox: { - htp_u = con_u->src_u.lis_u->htp_u; - break; - } - } - - // XX make unpossible? - c3_assert( (0 != htp_u) && (0 != htp_u->por_s) ); - - lop_u.sin_port = htons(htp_u->por_s); - } - - uv_connect_t* upc_u = c3_malloc(sizeof(*upc_u)); - upc_u->data = con_u; - - c3_i sas_i; - - if ( 0 != (sas_i = uv_tcp_connect(upc_u, upt_u, - (const struct sockaddr*)&lop_u, - _proxy_loop_connect_cb)) ) { - u3l_log("proxy: connect: %s\n", uv_strerror(sas_i)); - free(upc_u); - _proxy_conn_close(con_u); - } -} - -/* _proxy_wcon_link(): link wcon to ward. -*/ -static void -_proxy_wcon_link(u3_wcon* won_u, u3_ward* rev_u) -{ - won_u->nex_u = rev_u->won_u; - rev_u->won_u = won_u; -} - -/* _proxy_wcon_unlink(): unlink wcon from ward. -*/ -static void -_proxy_wcon_unlink(u3_wcon* won_u) -{ - u3_ward* rev_u = won_u->rev_u; - - if ( rev_u->won_u == won_u ) { - rev_u->won_u = won_u->nex_u; - } - else { - u3_wcon* pre_u = rev_u->won_u; - - // XX glories of linear search - // - while ( 0 != pre_u ) { - if ( pre_u->nex_u == won_u ) { - pre_u->nex_u = won_u->nex_u; - } - else pre_u = pre_u->nex_u; - } - } -} - -/* _proxy_wcon_free(): free ward upstream candidate. -*/ -static void -_proxy_wcon_free(uv_handle_t* han_u) -{ - u3_wcon* won_u = han_u->data; - - // Note: not unlinked here, freed concurrent with u3_ward - free(won_u); -} - -/* _proxy_wcon_close(): close ward upstream candidate. -*/ -static void -_proxy_wcon_close(u3_wcon* won_u) -{ - uv_read_stop((uv_stream_t*)&won_u->upt_u); - uv_close((uv_handle_t*)&won_u->upt_u, _proxy_wcon_free); -} - -/* _proxy_wcon_new(): allocate ward upstream candidate. -*/ -static u3_wcon* -_proxy_wcon_new(u3_ward* rev_u) -{ - u3_wcon* won_u = c3_malloc(sizeof(*won_u)); - won_u->upt_u.data = won_u; - won_u->rev_u = rev_u; - won_u->nex_u = 0; - - _proxy_wcon_link(won_u, rev_u); - - return won_u; -} - -/* _proxy_ward_link(): link ward to listener. -*/ -static void -_proxy_ward_link(u3_pcon* con_u, u3_ward* rev_u) -{ - // XX link also to con_u as upstream? - c3_assert( u3_ptyp_prox == con_u->typ_e ); - - u3_prox* lis_u = con_u->src_u.lis_u; - - rev_u->nex_u = lis_u->rev_u; - - if ( 0 != rev_u->nex_u ) { - rev_u->nex_u->pre_u = rev_u; - } - lis_u->rev_u = rev_u; -} - -/* _proxy_ward_unlink(): unlink ward from listener. -*/ -static void -_proxy_ward_unlink(u3_ward* rev_u) -{ - if ( 0 != rev_u->pre_u ) { - rev_u->pre_u->nex_u = rev_u->nex_u; - - if ( 0 != rev_u->nex_u ) { - rev_u->nex_u->pre_u = rev_u->pre_u; - } - } - else { - c3_assert( u3_ptyp_prox == rev_u->con_u->typ_e ); - - u3_prox* lis_u = rev_u->con_u->src_u.lis_u; - lis_u->rev_u = rev_u->nex_u; - - if ( 0 != rev_u->nex_u ) { - rev_u->nex_u->pre_u = 0; - } - } -} - -/* _proxy_ward_free(): free reverse proxy listener -*/ -static void -_proxy_ward_free(uv_handle_t* han_u) -{ - u3_ward* rev_u = han_u->data; - - free(rev_u->non_u.base); - free(rev_u); -} - -/* _proxy_ward_close_timer(): close ward timer -*/ -static void -_proxy_ward_close_timer(uv_handle_t* han_u) -{ - u3_ward* rev_u = han_u->data; - - uv_close((uv_handle_t*)&rev_u->tim_u, _proxy_ward_free); -} - -/* _proxy_ward_close(): close ward (ship-specific listener) -*/ -static void -_proxy_ward_close(u3_ward* rev_u) -{ - _proxy_ward_unlink(rev_u); - - while ( 0 != rev_u->won_u ) { - _proxy_wcon_close(rev_u->won_u); - rev_u->won_u = rev_u->won_u->nex_u; - } - - uv_close((uv_handle_t*)&rev_u->tcp_u, _proxy_ward_close_timer); -} - -/* _proxy_ward_new(): allocate reverse proxy listener -*/ -static u3_ward* -_proxy_ward_new(u3_pcon* con_u, u3_atom sip) -{ - u3_ward* rev_u = c3_calloc(sizeof(*rev_u)); - rev_u->tcp_u.data = rev_u; - rev_u->tim_u.data = rev_u; - rev_u->con_u = con_u; - - u3r_chubs(0, 2, rev_u->who_d, sip); - _proxy_ward_link(con_u, rev_u); - - u3z(sip); - - return rev_u; -} - -/* _proxy_wcon_peek_read_cb(): authenticate connection by checking nonce. -*/ -static void -_proxy_wcon_peek_read_cb(uv_stream_t* upt_u, - ssize_t siz_w, - const uv_buf_t* buf_u) -{ - u3_wcon* won_u = upt_u->data; - u3_ward* rev_u = won_u->rev_u; - - if ( 0 > siz_w ) { - if ( UV_EOF != siz_w ) { - u3l_log("proxy: ward peek: %s\n", uv_strerror(siz_w)); - } - _proxy_wcon_close(won_u); - } - else { - uv_read_stop(upt_u); - - c3_w len_w = rev_u->non_u.len; - - if ( ((len_w + 1) != siz_w) || - (len_w != buf_u->base[0]) || - (0 != memcmp(rev_u->non_u.base, buf_u->base + 1, len_w)) ) { - // u3l_log("proxy: ward auth fail\n"); - _proxy_wcon_unlink(won_u); - _proxy_wcon_close(won_u); - } - else { - _proxy_wcon_unlink(won_u); - - u3_pcon* con_u = rev_u->con_u; - con_u->upt_u = (uv_tcp_t*)&won_u->upt_u; - con_u->upt_u->data = con_u; - - _proxy_fire(con_u); - _proxy_ward_close(rev_u); - } - } -} - -/* _proxy_wcon_peek(): peek at a new incoming connection -*/ -static void -_proxy_wcon_peek(u3_wcon* won_u) -{ - uv_read_start((uv_stream_t*)&won_u->upt_u, - _proxy_alloc, _proxy_wcon_peek_read_cb); -} - -/* _proxy_ward_accept(): accept new connection on ward -*/ -static void -_proxy_ward_accept(u3_ward* rev_u) -{ - u3_wcon* won_u = _proxy_wcon_new(rev_u); - - uv_tcp_init(u3L, &won_u->upt_u); - - c3_i sas_i; - - if ( 0 != (sas_i = uv_accept((uv_stream_t*)&rev_u->tcp_u, - (uv_stream_t*)&won_u->upt_u)) ) { - u3l_log("proxy: accept: %s\n", uv_strerror(sas_i)); - _proxy_wcon_close(won_u); - } - else { - _proxy_wcon_peek(won_u); - } -} - -/* _proxy_ward_listen_cb(): listen callback for ward -*/ -static void -_proxy_ward_listen_cb(uv_stream_t* tcp_u, c3_i sas_i) -{ - u3_ward* rev_u = (u3_ward*)tcp_u; - - if ( 0 != sas_i ) { - u3l_log("proxy: ward: %s\n", uv_strerror(sas_i)); - } - else { - _proxy_ward_accept(rev_u); - } -} - -/* _proxy_ward_timer_cb(): expiration timer for ward -*/ -static void -_proxy_ward_timer_cb(uv_timer_t* tim_u) -{ - u3_ward* rev_u = tim_u->data; - - if ( 0 != rev_u ) { - u3l_log("proxy: ward expired: %d\n", rev_u->por_s); - _proxy_ward_close(rev_u); - _proxy_conn_close(rev_u->con_u); - } -} - -/* _proxy_ward_plan(): notify ship of new ward -*/ -static void -_proxy_ward_plan(u3_ward* rev_u) -{ - u3_noun non; - - { - c3_w* non_w = c3_malloc(64); - c3_w len_w; - - c3_rand(non_w); - - non = u3i_words(16, non_w); - len_w = u3r_met(3, non); - - // the nonce is saved to authenticate u3_wcon - // and will be freed with u3_ward - // - rev_u->non_u = uv_buf_init((c3_c*)non_w, len_w); - } - - // XX confirm duct - u3_noun pax = u3nq(u3_blip, c3__http, c3__prox, - u3nc(u3k(u3A->sen), u3_nul)); - - u3_noun wis = u3nc(c3__wise, u3nq(u3i_chubs(2, rev_u->who_d), - rev_u->por_s, - u3k(rev_u->con_u->sec), - non)); - u3_pier_plan(pax, wis); -} - -/* _proxy_ward_start(): start ward (ship-specific listener). -*/ -static void -_proxy_ward_start(u3_pcon* con_u, u3_noun sip) -{ - u3_ward* rev_u = _proxy_ward_new(con_u, u3k(sip)); - - uv_tcp_init(u3L, &rev_u->tcp_u); - - struct sockaddr_in add_u; - c3_i add_i = sizeof(add_u); - memset(&add_u, 0, add_i); - add_u.sin_family = AF_INET; - add_u.sin_addr.s_addr = INADDR_ANY; - add_u.sin_port = 0; // first available - - c3_i sas_i; - - if ( 0 != (sas_i = uv_tcp_bind(&rev_u->tcp_u, - (const struct sockaddr*)&add_u, 0)) || - 0 != (sas_i = uv_listen((uv_stream_t*)&rev_u->tcp_u, - TCP_BACKLOG, _proxy_ward_listen_cb)) || - 0 != (sas_i = uv_tcp_getsockname(&rev_u->tcp_u, - (struct sockaddr*)&add_u, &add_i))) { - u3l_log("proxy: ward: %s\n", uv_strerror(sas_i)); - _proxy_ward_close(rev_u); - _proxy_conn_close(con_u); - } - else { - rev_u->por_s = ntohs(add_u.sin_port); - -#if 0 - { - u3_noun who = u3dc("scot", 'p', u3k(sip)); - c3_c* who_c = u3r_string(who); - u3l_log("\r\nward for %s started on %u\r\n", who_c, rev_u->por_s); - free(who_c); - u3z(who); - } -#endif - - _proxy_ward_plan(rev_u); - - // XX how long? - // - uv_timer_init(u3L, &rev_u->tim_u); - uv_timer_start(&rev_u->tim_u, _proxy_ward_timer_cb, 300 * 1000, 0); - } - - u3z(sip); -} - -/* _proxy_ward_connect_cb(): ward connection callback -*/ -static void -_proxy_ward_connect_cb(uv_connect_t * upc_u, c3_i sas_i) -{ - u3_pcon* con_u = upc_u->data; - - if ( 0 != sas_i ) { - u3l_log("proxy: ward connect: %s\n", uv_strerror(sas_i)); - _proxy_conn_close(con_u); - } - else { - // XX can con_u close before the loopback conn is established? - _proxy_loop_connect(con_u); - - u3_warc* cli_u = con_u->src_u.cli_u; - - // send %that nonce to ward for authentication - _proxy_write(con_u, (uv_stream_t*)&(con_u->don_u), cli_u->non_u); - - cli_u->non_u = uv_buf_init(0, 0); - } - - free(upc_u); -} - -/* _proxy_ward_connect(): connect to remote ward -*/ -static void -_proxy_ward_connect(u3_warc* cli_u) -{ - u3_pcon* con_u = _proxy_conn_new(u3_ptyp_ward, cli_u); - - uv_tcp_init(u3L, &con_u->don_u); - - struct sockaddr_in add_u; - - memset(&add_u, 0, sizeof(add_u)); - add_u.sin_family = AF_INET; - add_u.sin_addr.s_addr = htonl(cli_u->ipf_w); - add_u.sin_port = htons(cli_u->por_s); - - uv_connect_t* upc_u = c3_malloc(sizeof(*upc_u)); - upc_u->data = con_u; - - c3_i sas_i; - - if ( 0 != (sas_i = uv_tcp_connect(upc_u, &con_u->don_u, - (const struct sockaddr*)&add_u, - _proxy_ward_connect_cb)) ) { - u3l_log("proxy: ward connect: %s\n", uv_strerror(sas_i)); - free(upc_u); - _proxy_conn_close(con_u); - } -} - -/* _proxy_ward_resolve_cb(): ward IP address resolution callback -*/ -static void -_proxy_ward_resolve_cb(uv_getaddrinfo_t* adr_u, - c3_i sas_i, - struct addrinfo* aif_u) -{ - u3_warc* cli_u = adr_u->data; - - if ( 0 != sas_i ) { - u3l_log("proxy: ward: resolve: %s\n", uv_strerror(sas_i)); - _proxy_warc_free(cli_u); - } - else { - // XX traverse struct a la _ames_czar_cb - cli_u->ipf_w = ntohl(((struct sockaddr_in *)aif_u->ai_addr)->sin_addr.s_addr); - _proxy_ward_connect(cli_u); - } - - free(adr_u); - uv_freeaddrinfo(aif_u); -} - -/* _proxy_reverse_resolve(): resolve IP address of remote ward -*/ -static void -_proxy_ward_resolve(u3_warc* cli_u) -{ - uv_getaddrinfo_t* adr_u = c3_malloc(sizeof(*adr_u)); - adr_u->data = cli_u; - - struct addrinfo hin_u; - memset(&hin_u, 0, sizeof(struct addrinfo)); - - hin_u.ai_family = PF_INET; - hin_u.ai_socktype = SOCK_STREAM; - hin_u.ai_protocol = IPPROTO_TCP; - - // XX why the conditional? - // - if ( 0 == cli_u->hot_c ) { - u3_noun sip = u3dc("scot", 'p', u3i_chubs(2, cli_u->who_d)); - c3_c* sip_c = u3r_string(sip); - c3_w len_w = 1 + strlen(sip_c) + strlen(PROXY_DOMAIN); - cli_u->hot_c = c3_malloc(len_w); - // incremented to skip '~' - snprintf(cli_u->hot_c, len_w, "%s.%s", sip_c + 1, PROXY_DOMAIN); - - free(sip_c); - u3z(sip); - } - - c3_i sas_i; - - if ( 0 != (sas_i = uv_getaddrinfo(u3L, adr_u, _proxy_ward_resolve_cb, - cli_u->hot_c, 0, &hin_u)) ) { - u3l_log("proxy: ward: resolve: %s\n", uv_strerror(sas_i)); - _proxy_warc_free(cli_u); - } -} - -/* _proxy_parse_host(): parse plaintext buffer for Host header -*/ -static u3_proxy_pars -_proxy_parse_host(const uv_buf_t* buf_u, c3_c** hot_c) -{ - struct phr_header hed_u[H2O_MAX_HEADERS]; - size_t hed_t = H2O_MAX_HEADERS; - - { - // unused - c3_i ver_i; - const c3_c* met_c; - size_t met_t; - const c3_c* pat_c; - size_t pat_t; - - size_t len_t = buf_u->len < H2O_MAX_REQLEN ? buf_u->len : H2O_MAX_REQLEN; - // XX slowloris? - c3_i las_i = 0; - c3_i sas_i; - - sas_i = phr_parse_request(buf_u->base, len_t, &met_c, &met_t, - &pat_c, &pat_t, &ver_i, hed_u, &hed_t, las_i); - - switch ( sas_i ) { - case -1: return u3_pars_fail; - case -2: return u3_pars_moar; - } - } - - const h2o_token_t* tok_t; - size_t i; - - for ( i = 0; i < hed_t; i++ ) { - // XX in-place, copy first - h2o_strtolower((c3_c*)hed_u[i].name, hed_u[i].name_len); - - if ( 0 != (tok_t = h2o_lookup_token(hed_u[i].name, hed_u[i].name_len)) ) { - if ( tok_t->is_init_header_special && H2O_TOKEN_HOST == tok_t ) { - c3_c* val_c; - c3_c* por_c; - - val_c = c3_malloc(1 + hed_u[i].value_len); - val_c[hed_u[i].value_len] = 0; - memcpy(val_c, hed_u[i].value, hed_u[i].value_len); - - // 'truncate' by replacing port separator ':' with 0 - if ( 0 != (por_c = strchr(val_c, ':')) ) { - por_c[0] = 0; - } - - *hot_c = val_c; - break; - } - } - } - - return u3_pars_good; -} - -/* _proxy_parse_sni(): parse clienthello buffer for SNI -*/ -static u3_proxy_pars -_proxy_parse_sni(const uv_buf_t* buf_u, c3_c** hot_c) -{ - c3_i sas_i = parse_tls_header((const uint8_t*)buf_u->base, - buf_u->len, hot_c); - - if ( 0 > sas_i ) { - switch ( sas_i ) { - case -1: return u3_pars_moar; - case -2: return u3_pars_good; // SNI not present - default: return u3_pars_fail; - } - } - - return u3_pars_good; -} - -/* _proxy_parse_ship(): determine destination (unit ship) for proxied request -*/ -static u3_noun -_proxy_parse_ship(c3_c* hot_c) -{ - if ( 0 == hot_c ) { - return u3_nul; - } - else { - c3_c* dom_c = strchr(hot_c, '.'); - - if ( 0 == dom_c ) { - return u3_nul; - } - else { - // length of the first subdomain - // - c3_w dif_w = dom_c - hot_c; - c3_w dns_w = strlen(PROXY_DOMAIN); - - // validate that everything after the first subdomain - // matches the proxy domain - // (skipped if networking is disabled) - // - if ( (c3y == u3_Host.ops_u.net) && - ( (dns_w != strlen(hot_c) - (dif_w + 1)) || - (0 != strncmp(dom_c + 1, PROXY_DOMAIN, dns_w)) ) ) - { - return u3_nul; - } - else { - // attempt to parse the first subdomain as a @p - // - u3_noun sip; - c3_c* sip_c = c3_malloc(2 + dif_w); - - strncpy(sip_c + 1, hot_c, dif_w); - sip_c[0] = '~'; - sip_c[1 + dif_w] = 0; - - sip = u3dc("slaw", 'p', u3i_string(sip_c)); - free(sip_c); - - return sip; - } - } - } -} - -/* _proxy_dest(): proxy to destination -*/ -static void -_proxy_dest(u3_pcon* con_u, u3_noun sip) -{ - if ( u3_nul == sip ) { - _proxy_loop_connect(con_u); - } - else { - // XX revisit - u3_pier* pir_u = u3_pier_stub(); - u3_noun our = u3i_chubs(2, pir_u->who_d); - u3_noun hip = u3t(sip); - - if ( c3y == u3r_sing(our, hip) ) { - _proxy_loop_connect(con_u); - } - else { - // XX we should u3v_peek %j /=sein= to confirm - // that we're sponsoring this ship - // - _proxy_ward_start(con_u, u3k(hip)); - } - - u3z(our); - } - - u3z(sip); -} - -static void _proxy_peek_read(u3_pcon* con_u); - -/* _proxy_peek(): peek at proxied request for destination -*/ -static void -_proxy_peek(u3_pcon* con_u) -{ - c3_c* hot_c = 0; - - u3_proxy_pars sat_e = ( c3y == con_u->sec ) ? - _proxy_parse_sni(&con_u->buf_u, &hot_c) : - _proxy_parse_host(&con_u->buf_u, &hot_c); - - switch ( sat_e ) { - default: c3_assert(0); - - case u3_pars_fail: { - u3l_log("proxy: peek fail\n"); - _proxy_conn_close(con_u); - break; - } - - case u3_pars_moar: { - u3l_log("proxy: peek moar\n"); - // XX count retries, fail after some n - _proxy_peek_read(con_u); - break; - } - - case u3_pars_good: { - u3_noun sip = _proxy_parse_ship(hot_c); - _proxy_dest(con_u, sip); - break; - } - } - - if ( 0 != hot_c ) { - free(hot_c); - } -} - -/* _proxy_peek_read_cb(): read callback for peeking at proxied request -*/ -static void -_proxy_peek_read_cb(uv_stream_t* don_u, - ssize_t siz_w, - const uv_buf_t* buf_u) -{ - u3_pcon* con_u = don_u->data; - - if ( 0 > siz_w ) { - if ( UV_EOF != siz_w ) { - u3l_log("proxy: peek: %s\n", uv_strerror(siz_w)); - } - _proxy_conn_close(con_u); - } - else { - uv_read_stop(don_u); - - if ( 0 == con_u->buf_u.base ) { - con_u->buf_u = uv_buf_init(buf_u->base, siz_w); - } - else { - c3_w len_w = siz_w + con_u->buf_u.len; - void* ptr_v = c3_realloc(con_u->buf_u.base, len_w); - - memcpy(ptr_v + con_u->buf_u.len, buf_u->base, siz_w); - con_u->buf_u = uv_buf_init(ptr_v, len_w); - - free(buf_u->base); - } - - _proxy_peek(con_u); - } -} - -/* _proxy_peek_read(): start read to peek at proxied request -*/ -static void -_proxy_peek_read(u3_pcon* con_u) -{ - uv_read_start((uv_stream_t*)&con_u->don_u, - _proxy_alloc, _proxy_peek_read_cb); -} - -/* _proxy_serv_free(): free proxy listener -*/ -static void -_proxy_serv_free(u3_prox* lis_u) -{ - u3_pcon* con_u = lis_u->con_u; - - while ( con_u ) { - _proxy_conn_close(con_u); - con_u = con_u->nex_u; - } - - u3_ward* rev_u = lis_u->rev_u; - - while ( rev_u ) { - _proxy_ward_close(rev_u); - rev_u = rev_u->nex_u; - } - - // not unlinked here, owned directly by htp_u - - free(lis_u); -} - -/* _proxy_serv_close(): close proxy listener -*/ -static void -_proxy_serv_close(u3_prox* lis_u) -{ - uv_close((uv_handle_t*)&lis_u->sev_u, (uv_close_cb)_proxy_serv_free); -} - -/* _proxy_serv_new(): allocate proxy listener -*/ -static u3_prox* -_proxy_serv_new(u3_http* htp_u, c3_s por_s, c3_o sec) -{ - u3_prox* lis_u = c3_malloc(sizeof(*lis_u)); - lis_u->sev_u.data = lis_u; - lis_u->por_s = por_s; - lis_u->sec = sec; - lis_u->htp_u = htp_u; - lis_u->con_u = 0; - lis_u->rev_u = 0; - - // not linked here, owned directly by htp_u - - return lis_u; -} - -/* _proxy_serv_accept(): accept new connection. -*/ -static void -_proxy_serv_accept(u3_prox* lis_u) -{ - u3_pcon* con_u = _proxy_conn_new(u3_ptyp_prox, lis_u); - - uv_tcp_init(u3L, &con_u->don_u); - - c3_i sas_i; - if ( 0 != (sas_i = uv_accept((uv_stream_t*)&lis_u->sev_u, - (uv_stream_t*)&con_u->don_u)) ) { - u3l_log("proxy: accept: %s\n", uv_strerror(sas_i)); - _proxy_conn_close(con_u); - } - else { - _proxy_peek_read(con_u); - } -} - -/* _proxy_serv_listen_cb(): listen callback for proxy server. -*/ -static void -_proxy_serv_listen_cb(uv_stream_t* sev_u, c3_i sas_i) -{ - u3_prox* lis_u = (u3_prox*)sev_u; - - if ( 0 != sas_i ) { - u3l_log("proxy: listen_cb: %s\n", uv_strerror(sas_i)); - } - else { - _proxy_serv_accept(lis_u); - } -} - -/* _proxy_serv_start(): start reverse TCP proxy server. -*/ -static u3_prox* -_proxy_serv_start(u3_prox* lis_u) -{ - uv_tcp_init(u3L, &lis_u->sev_u); - - struct sockaddr_in add_u; - - memset(&add_u, 0, sizeof(add_u)); - add_u.sin_family = AF_INET; - add_u.sin_addr.s_addr = INADDR_ANY; - - /* Try ascending ports. - */ - while ( 1 ) { - c3_i sas_i; - - add_u.sin_port = htons(lis_u->por_s); - - if ( 0 != (sas_i = uv_tcp_bind(&lis_u->sev_u, - (const struct sockaddr*)&add_u, 0)) || - 0 != (sas_i = uv_listen((uv_stream_t*)&lis_u->sev_u, - TCP_BACKLOG, _proxy_serv_listen_cb)) ) { - if ( (UV_EADDRINUSE == sas_i) || (UV_EACCES == sas_i) ) { - if ( (c3y == lis_u->sec) && (443 == lis_u->por_s) ) { - lis_u->por_s = 9443; - } - else if ( (c3n == lis_u->sec) && (80 == lis_u->por_s) ) { - lis_u->por_s = 9080; - } - else { - lis_u->por_s++; - } - - continue; - } - - u3l_log("proxy: listen: %s\n", uv_strerror(sas_i)); - _proxy_serv_free(lis_u); - return 0; - } - - return lis_u; - } -} - -/* u3_http_ef_that(): reverse proxy requested connection notification. -*/ -void -u3_http_ef_that(u3_noun tat) -{ - u3_noun sip, por, sec, non; - - if ( ( c3n == u3r_qual(tat, &sip, &por, &sec, &non) ) || - ( c3n == u3ud(sip) ) || - ( c3n == u3a_is_cat(por) ) || - !( c3y == sec || c3n == sec ) || - ( c3n == u3ud(non) ) ) { - u3l_log("http: that: invalid card\n"); - } - else { - u3_http* htp_u; - u3_warc* cli_u; - - for ( htp_u = u3_Host.htp_u; (0 != htp_u); htp_u = htp_u->nex_u ) { - if ( c3n == htp_u->lop && sec == htp_u->sec ) { - break; - } - } - - // XX we should inform our sponsor if we aren't running a server - // so this situation can be avoided - // - if ( 0 == htp_u ) { - u3l_log("http: that: no %s server\n", - (c3y == sec) ? "secure" : "insecure"); - } - else { - cli_u = _proxy_warc_new(htp_u, (u3_atom)u3k(sip), (u3_atom)u3k(non), - (c3_s)por, (c3_o)sec); - - // resolve to loopback if networking is disabled - // - if ( c3n == u3_Host.ops_u.net ) { - cli_u->ipf_w = INADDR_LOOPBACK; - _proxy_ward_connect(cli_u); - } - else { - _proxy_ward_resolve(cli_u); - } - } - } - - u3z(tat); -} diff --git a/pkg/hair/notes/c/lmdb.c b/pkg/hair/notes/c/lmdb.c deleted file mode 100644 index 8a5fd9d90..000000000 --- a/pkg/hair/notes/c/lmdb.c +++ /dev/null @@ -1,670 +0,0 @@ -/* vere/lmdb.c -*/ - -#include "all.h" - -#include -#include - -#include "vere/vere.h" - -// Event log persistence for Urbit -// -// Persistence works by having an lmdb environment opened on the main -// thread. This environment is used to create read-only transactions -// synchronously when needed. -// -// But the majority of lmdb writes operate asynchronously in the uv worker -// pool. Since individual transactions are bound to threads, we perform all -// blocking writing on worker threads. -// -// We perform the very first metadata writes on the main thread because we -// can't do anything until they persist. - -/* u3_lmdb_init(): Opens up a log environment -** -** Precondition: log_path points to an already created directory -*/ -MDB_env* u3_lmdb_init(const char* log_path) -{ - MDB_env* env = 0; - c3_w ret_w = mdb_env_create(&env); - if (ret_w != 0) { - u3l_log("lmdb: init fail: %s\n", mdb_strerror(ret_w)); - return 0; - } - - // Our databases have up to three tables: META, EVENTS, and GRAINS. - ret_w = mdb_env_set_maxdbs(env, 3); - if (ret_w != 0) { - u3l_log("lmdb: failed to set number of databases: %s\n", mdb_strerror(ret_w)); - return 0; - } - - // TODO: Start with forty gigabytes for the maximum event log size. We'll - // need to do something more sophisticated for real in the long term, though. - // - const size_t forty_gigabytes = 42949672960; - ret_w = mdb_env_set_mapsize(env, forty_gigabytes); - if (ret_w != 0) { - u3l_log("lmdb: failed to set database size: %s\n", mdb_strerror(ret_w)); - return 0; - } - - ret_w = mdb_env_open(env, log_path, 0, 0664); - if (ret_w != 0) { - u3l_log("lmdb: failed to open event log: %s\n", mdb_strerror(ret_w)); - return 0; - } - - return env; -} - -/* u3_lmdb_shutdown(): Shuts down lmdb -*/ -void u3_lmdb_shutdown(MDB_env* env) -{ - mdb_env_close(env); -} - -/* _perform_put_on_database_raw(): Writes a key/value pair to a specific -** database as part of a transaction. -** -** The raw version doesn't take ownership of either key/value and performs no -** nock calculations, so it is safe to call from any thread. -*/ -static -c3_o _perform_put_on_database_raw(MDB_txn* transaction_u, - MDB_dbi database_u, - c3_w flags, - void* key, - size_t key_len, - void* value, - size_t value_len) { - MDB_val key_val, value_val; - - key_val.mv_size = key_len; - key_val.mv_data = key; - - value_val.mv_size = value_len; - value_val.mv_data = value; - - c3_w ret_w = mdb_put(transaction_u, database_u, &key_val, &value_val, flags); - if (ret_w != 0) { - u3l_log("lmdb: write failed: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - return c3y; -} - -/* _perform_get_on_database_raw(): Reads a key/value pair to a specific -** database as part of a transaction. -*/ -static -c3_o _perform_get_on_database_raw(MDB_txn* transaction_u, - MDB_dbi database_u, - void* key, - size_t key_len, - MDB_val* value) { - MDB_val key_val; - key_val.mv_size = key_len; - key_val.mv_data = key; - - c3_w ret_w = mdb_get(transaction_u, database_u, &key_val, value); - if (ret_w != 0) { - u3l_log("lmdb: read failed: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - return c3y; -} - -/* _perform_put_on_database_noun(): Writes a noun to the database. -** -** This requires access to the loom so it must only be run from the libuv -** thread. -*/ -static -c3_o _perform_put_on_database_noun(MDB_txn* transaction_u, - MDB_dbi database_u, - c3_c* key, - u3_noun noun) { - // jam noun into an atom representation - u3_atom mat = u3ke_jam(noun); - - // copy the jammed noun into a byte buffer we can hand to lmdb - c3_w len_w = u3r_met(3, mat); - c3_y* bytes_y = (c3_y*) malloc(len_w); - u3r_bytes(0, len_w, bytes_y, mat); - - c3_o ret = _perform_put_on_database_raw( - transaction_u, - database_u, - 0, - key, strlen(key), - bytes_y, len_w); - - free(bytes_y); - u3z(mat); - - return ret; -} - -/* _perform_get_on_database_noun(): Reads a noun from the database. -** -** This requires access to the loom so it must only be run from the libuv -** thread. -*/ -static -c3_o _perform_get_on_database_noun(MDB_txn* transaction_u, - MDB_dbi database_u, - c3_c* key, - u3_noun* noun) { - MDB_val value_val; - c3_o ret = _perform_get_on_database_raw(transaction_u, - database_u, - key, strlen(key), - &value_val); - if (ret == c3n) { - return c3y; - } - - // Take the bytes and cue them. - u3_atom raw_atom = u3i_bytes(value_val.mv_size, value_val.mv_data); - *noun = u3qe_cue(raw_atom); - return c3y; -} - -/* u3_lmdb_write_request: Events to be written together -*/ -struct u3_lmdb_write_request { - // The event number of the first event. - c3_d first_event; - - // The number of events in this write request. Nonzero. - c3_d event_count; - - // An array of serialized event datas. The array size is |event_count|. We - // perform the event serialization on the main thread so we can read the loom - // and write into a malloced structure for the worker thread. - void** malloced_event_data; - - // An array of sizes of serialized event datas. We keep track of this for the - // database write. - size_t* malloced_event_data_size; -}; - -/* u3_lmdb_build_write_request(): Allocates and builds a write request -*/ -struct u3_lmdb_write_request* -u3_lmdb_build_write_request(u3_writ* event_u, c3_d count) -{ - struct u3_lmdb_write_request* request = - c3_malloc(sizeof(struct u3_lmdb_write_request)); - request->first_event = event_u->evt_d; - request->event_count = count; - request->malloced_event_data = c3_malloc(sizeof(void*) * count); - request->malloced_event_data_size = c3_malloc(sizeof(size_t) * count); - - for (c3_d i = 0; i < count; ++i) { - // Sanity check that the events in u3_writ are in order. - c3_assert(event_u->evt_d == (request->first_event + i)); - - // Serialize the jammed event log entry into a malloced buffer we can send - // to the other thread. - c3_w siz_w = u3r_met(3, event_u->mat); - c3_y* data_u = c3_calloc(siz_w); - u3r_bytes(0, siz_w, data_u, event_u->mat); - - request->malloced_event_data[i] = data_u; - request->malloced_event_data_size[i] = siz_w; - - event_u = event_u->nex_u; - } - - return request; -} - -/* u3_lmdb_free_write_request(): Frees a write request -*/ -void u3_lmdb_free_write_request(struct u3_lmdb_write_request* request) { - for (c3_d i = 0; i < request->event_count; ++i) - free(request->malloced_event_data[i]); - - free(request->malloced_event_data); - free(request->malloced_event_data_size); - free(request); -} - -/* _write_request_data: callback struct for u3_lmdb_write_event() -*/ -struct _write_request_data { - // The database environment to write to. This object is thread-safe, though - // the transactions and handles opened from it are explicitly not. - MDB_env* environment; - - // The pier that we're writing for. - u3_pier* pir_u; - - // The encapsulated request. This may contain multiple event writes. - struct u3_lmdb_write_request* request; - - // Whether the write completed successfully. - c3_o success; - - // Called on main loop thread on completion. - void (*on_complete)(c3_o, u3_pier*, c3_d, c3_d); -}; - -/* _u3_lmdb_write_event_cb(): Implementation of u3_lmdb_write_event() -** -** This is always run on a libuv background worker thread; actual nouns cannot -** be touched here. -*/ -static void _u3_lmdb_write_event_cb(uv_work_t* req) { - struct _write_request_data* data = req->data; - - // Creates the write transaction. - MDB_txn* transaction_u; - c3_w ret_w = mdb_txn_begin(data->environment, - (MDB_txn *) NULL, - 0, /* flags */ - &transaction_u); - if (0 != ret_w) { - u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); - return; - } - - // Opens the database as part of the transaction. - c3_w flags_w = MDB_CREATE | MDB_INTEGERKEY; - MDB_dbi database_u; - ret_w = mdb_dbi_open(transaction_u, - "EVENTS", - flags_w, - &database_u); - if (0 != ret_w) { - u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); - return; - } - - struct u3_lmdb_write_request* request = data->request; - for (c3_d i = 0; i < request->event_count; ++i) { - c3_d event_number = request->first_event + i; - - c3_o success = _perform_put_on_database_raw( - transaction_u, - database_u, - MDB_NOOVERWRITE, - &event_number, - sizeof(c3_d), - request->malloced_event_data[i], - request->malloced_event_data_size[i]); - - if (success == c3n) { - u3l_log("lmdb: failed to write event %" PRIu64 "\n", event_number); - mdb_txn_abort(transaction_u); - data->success = c3n; - return; - } - } - - ret_w = mdb_txn_commit(transaction_u); - if (0 != ret_w) { - if ( request->event_count == 1 ) { - u3l_log("lmdb: failed to commit event %" PRIu64 ": %s\n", - request->first_event, - mdb_strerror(ret_w)); - } else { - c3_d through = request->first_event + request->event_count - 1ULL; - u3l_log("lmdb: failed to commit events %" PRIu64 " through %" PRIu64 - ": %s\n", - request->first_event, - through, - mdb_strerror(ret_w)); - } - data->success = c3n; - return; - } - - data->success = c3y; -} - -/* _u3_lmdb_write_event_after_cb(): Implementation of u3_lmdb_write_event() -** -** This is always run on the main loop thread after the worker thread event -** completes. -*/ -static void _u3_lmdb_write_event_after_cb(uv_work_t* req, int status) { - struct _write_request_data* data = req->data; - - data->on_complete(data->success, - data->pir_u, - data->request->first_event, - data->request->event_count); - - u3_lmdb_free_write_request(data->request); - free(data); - free(req); -} - -/* u3_lmdb_write_event(): Asynchronously writes events to the database. -** -** This writes all the passed in events along with log metadata updates to the -** database as a single transaction on a worker thread. Once the transaction -** is completed, it calls the passed in callback on the main loop thread. -*/ -void u3_lmdb_write_event(MDB_env* environment, - u3_pier* pir_u, - struct u3_lmdb_write_request* request_u, - void (*on_complete)(c3_o, u3_pier*, c3_d, c3_d)) -{ - // Structure to pass to the worker thread. - struct _write_request_data* data = c3_malloc(sizeof(struct _write_request_data)); - data->environment = environment; - data->pir_u = pir_u; - data->request = request_u; - data->on_complete = on_complete; - data->success = c3n; - - // Queue asynchronous work to happen on the other thread. - uv_work_t* req = c3_malloc(sizeof(uv_work_t)); - req->data = data; - - uv_queue_work(uv_default_loop(), - req, - _u3_lmdb_write_event_cb, - _u3_lmdb_write_event_after_cb); -} - -/* u3_lmdb_read_events(): Synchronously reads events from the database. -** -** Reads back up to |len_d| events starting with |first_event_d|. For -** each event, the event will be passed to |on_event_read| and further -** reading will be aborted if the callback returns c3n. -** -** Returns c3y on complete success; c3n on any error. -*/ -c3_o u3_lmdb_read_events(u3_pier* pir_u, - c3_d first_event_d, - c3_d len_d, - c3_o(*on_event_read)(u3_pier* pir_u, c3_d id, - u3_noun mat)) -{ - // Creates the read transaction. - MDB_txn* transaction_u; - c3_w ret_w = mdb_txn_begin(pir_u->log_u->db_u, - //environment, - (MDB_txn *) NULL, - MDB_RDONLY, /* flags */ - &transaction_u); - if (0 != ret_w) { - u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - // Opens the database as part of the transaction. - c3_w flags_w = MDB_CREATE | MDB_INTEGERKEY; - MDB_dbi database_u; - ret_w = mdb_dbi_open(transaction_u, - "EVENTS", - flags_w, - &database_u); - if (0 != ret_w) { - u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - // Creates a cursor to iterate over keys starting at first_event_d. - MDB_cursor* cursor_u; - ret_w = mdb_cursor_open(transaction_u, database_u, &cursor_u); - if (0 != ret_w) { - u3l_log("lmdb: cursor_open fail: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - // Sets the cursor to the position of first_event_d. - MDB_val key; - MDB_val val; - key.mv_size = sizeof(c3_d); - key.mv_data = &first_event_d; - - ret_w = mdb_cursor_get(cursor_u, &key, &val, MDB_SET_KEY); - if (0 != ret_w) { - u3l_log("lmdb: could not find initial event %" PRIu64 ": %s\r\n", - first_event_d, mdb_strerror(ret_w)); - mdb_cursor_close(cursor_u); - return c3n; - } - - // Load up to len_d events, iterating forward across the cursor. - for (c3_d loaded = 0; (ret_w != MDB_NOTFOUND) && (loaded < len_d); ++loaded) { - // As a sanity check, we make sure that there aren't any discontinuities in - // the sequence of loaded events. - c3_d current_id = first_event_d + loaded; - if (key.mv_size != sizeof(c3_d)) { - u3l_log("lmdb: invalid cursor key\r\n"); - return c3n; - } - if (*(c3_d*)key.mv_data != current_id) { - u3l_log("lmdb: missing event in database. Expected %" PRIu64 ", received %" - PRIu64 "\r\n", - current_id, - *(c3_d*)key.mv_data); - return c3n; - } - - // Now build the atom version and then the cued version from the raw data - u3_noun mat = u3i_bytes(val.mv_size, val.mv_data); - - if (on_event_read(pir_u, current_id, mat) == c3n) { - u3z(mat); - u3l_log("lmdb: aborting replay due to error.\r\n"); - return c3n; - } - - u3z(mat); - - ret_w = mdb_cursor_get(cursor_u, &key, &val, MDB_NEXT); - if (ret_w != 0 && ret_w != MDB_NOTFOUND) { - u3l_log("lmdb: error while loading events: %s\r\n", - mdb_strerror(ret_w)); - return c3n; - } - } - - mdb_cursor_close(cursor_u); - - // Read-only transactions are aborted since we don't need to record the fact - // that we performed a read. - mdb_txn_abort(transaction_u); - - return c3y; -} - -/* u3_lmdb_get_latest_event_number(): Gets last event id persisted -** -** Reads the last key in order from the EVENTS table as the latest event -** number. On table empty, returns c3y but doesn't modify event_number. -*/ -c3_o u3_lmdb_get_latest_event_number(MDB_env* environment, c3_d* event_number) -{ - // Creates the read transaction. - MDB_txn* transaction_u; - c3_w ret_w = mdb_txn_begin(environment, - (MDB_txn *) NULL, - 0, /* flags */ - &transaction_u); - if (0 != ret_w) { - u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - // Opens the database as part of the transaction. - c3_w flags_w = MDB_CREATE | MDB_INTEGERKEY; - MDB_dbi database_u; - ret_w = mdb_dbi_open(transaction_u, - "EVENTS", - flags_w, - &database_u); - if (0 != ret_w) { - u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - // Creates a cursor to point to the last event - MDB_cursor* cursor_u; - ret_w = mdb_cursor_open(transaction_u, database_u, &cursor_u); - if (0 != ret_w) { - u3l_log("lmdb: cursor_open fail: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - // Set the cursor at the end of the line. - MDB_val key; - MDB_val val; - ret_w = mdb_cursor_get(cursor_u, &key, &val, MDB_LAST); - if (MDB_NOTFOUND == ret_w) { - // Clean up, but don't error out. - mdb_cursor_close(cursor_u); - mdb_txn_abort(transaction_u); - return c3y; - } - - if (0 != ret_w) { - u3l_log("lmdb: could not find last event: %s\r\n", mdb_strerror(ret_w)); - mdb_cursor_close(cursor_u); - mdb_txn_abort(transaction_u); - return c3n; - } - - *event_number = *(c3_d*)key.mv_data; - - mdb_cursor_close(cursor_u); - - // Read-only transactions are aborted since we don't need to record the fact - // that we performed a read. - mdb_txn_abort(transaction_u); - - return c3y; -} - -/* u3_lmdb_write_identity(): Writes the event log identity information -** -** We have a secondary database (table) in this environment named META where we -** read/write identity information from/to. -*/ -c3_o u3_lmdb_write_identity(MDB_env* environment, - u3_noun who, - u3_noun is_fake, - u3_noun life) -{ - // Creates the write transaction. - MDB_txn* transaction_u; - c3_w ret_w = mdb_txn_begin(environment, - (MDB_txn *) NULL, - 0, /* flags */ - &transaction_u); - if (0 != ret_w) { - u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - // Opens the database as part of the transaction. - c3_w flags_w = MDB_CREATE; - MDB_dbi database_u; - ret_w = mdb_dbi_open(transaction_u, - "META", - flags_w, - &database_u); - if (0 != ret_w) { - u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); - mdb_txn_abort(transaction_u); - return c3n; - } - - c3_o ret; - ret = _perform_put_on_database_noun(transaction_u, database_u, "who", who); - if (ret == c3n) { - mdb_txn_abort(transaction_u); - return c3n; - } - - ret = _perform_put_on_database_noun(transaction_u, database_u, "is-fake", - is_fake); - if (ret == c3n) { - mdb_txn_abort(transaction_u); - return c3n; - } - - ret = _perform_put_on_database_noun(transaction_u, database_u, "life", life); - if (ret == c3n) { - mdb_txn_abort(transaction_u); - return c3n; - } - - ret_w = mdb_txn_commit(transaction_u); - if (0 != ret_w) { - u3l_log("lmdb: failed to commit transaction: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - return c3y; -} - - -/* u3_lmdb_read_identity(): Reads the event log identity information. -*/ -c3_o u3_lmdb_read_identity(MDB_env* environment, - u3_noun* who, - u3_noun* is_fake, - u3_noun* life) { - // Creates the write transaction. - MDB_txn* transaction_u; - c3_w ret_w = mdb_txn_begin(environment, - (MDB_txn *) NULL, - MDB_RDONLY, /* flags */ - &transaction_u); - if (0 != ret_w) { - u3l_log("lmdb: txn_begin fail: %s\n", mdb_strerror(ret_w)); - return c3n; - } - - // Opens the database as part of the transaction. - MDB_dbi database_u; - ret_w = mdb_dbi_open(transaction_u, - "META", - 0, - &database_u); - if (0 != ret_w) { - u3l_log("lmdb: dbi_open fail: %s\n", mdb_strerror(ret_w)); - mdb_txn_abort(transaction_u); - return c3n; - } - - c3_o ret; - ret = _perform_get_on_database_noun(transaction_u, database_u, "who", who); - if (ret == c3n) { - mdb_txn_abort(transaction_u); - return c3n; - } - - ret = _perform_get_on_database_noun(transaction_u, database_u, "is-fake", - is_fake); - if (ret == c3n) { - mdb_txn_abort(transaction_u); - return c3n; - } - - ret = _perform_get_on_database_noun(transaction_u, database_u, "life", life); - if (ret == c3n) { - mdb_txn_abort(transaction_u); - return c3n; - } - - // Read-only transactions are aborted since we don't need to record the fact - // that we performed a read. - mdb_txn_abort(transaction_u); - - return c3y; -} diff --git a/pkg/hair/notes/c/newt.c b/pkg/hair/notes/c/newt.c deleted file mode 100644 index 67a220daa..000000000 --- a/pkg/hair/notes/c/newt.c +++ /dev/null @@ -1,359 +0,0 @@ -/* vere/newt.c -** -** implements noun blob messages with trivial framing. -** -** a message is a 64-bit little-endian byte count, followed -** by the indicated number of bytes. the bytes are the -** the ++cue of of a noun. -** -** the implementation is relatively inefficient and could -** lose a few copies, mallocs, etc. -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -#undef NEWT_VERBOSE - -/* _newt_consume(): advance buffer processing. -*/ -static void -_newt_consume(u3_moat* mot_u) -{ - /* process stray bytes, trying to create a new message - ** or add a block to an existing one. - */ - while ( 1 ) { - if ( mot_u->rag_y ) { - /* if there is a live message, add a block to the queue. - */ - if ( mot_u->mes_u ) { - u3_meat* met_u; - - /* create block - */ - met_u = c3_malloc(mot_u->len_d + (c3_d) sizeof(u3_meat)); - met_u->nex_u = 0; - met_u->len_d = mot_u->len_d; - memcpy(met_u->hun_y, mot_u->rag_y, mot_u->len_d); - -#ifdef NEWT_VERBOSE - u3l_log("newt: %d: create: msg %p, new block %p, len %" - PRIu64 ", has %" PRIu64 ", needs %" PRIu64 "\r\n", - getpid(), - mot_u->mes_u, - met_u, - met_u->len_d, - mot_u->mes_u->has_d, - mot_u->mes_u->len_d); -#endif - /* enqueue block - */ - if ( !mot_u->mes_u->meq_u ) { - mot_u->mes_u->meq_u = mot_u->mes_u->qem_u = met_u; - } - else { - mot_u->mes_u->qem_u->nex_u = met_u; - mot_u->mes_u->qem_u = met_u; - } - mot_u->mes_u->has_d += met_u->len_d; - - /* free consumed stray bytes - */ - c3_free(mot_u->rag_y); - mot_u->len_d = 0; - mot_u->rag_y = 0; - } - else { - /* no message, but enough stray bytes to fill in - ** a length; collect them and create a message. - */ - if ( mot_u->len_d >= 8ULL ) { - c3_d nel_d = 0; - - nel_d |= ((c3_d) mot_u->rag_y[0]) << 0ULL; - nel_d |= ((c3_d) mot_u->rag_y[1]) << 8ULL; - nel_d |= ((c3_d) mot_u->rag_y[2]) << 16ULL; - nel_d |= ((c3_d) mot_u->rag_y[3]) << 24ULL; - nel_d |= ((c3_d) mot_u->rag_y[4]) << 32ULL; - nel_d |= ((c3_d) mot_u->rag_y[5]) << 40ULL; - nel_d |= ((c3_d) mot_u->rag_y[6]) << 48ULL; - nel_d |= ((c3_d) mot_u->rag_y[7]) << 56ULL; - -#ifdef NEWT_VERBOSE - u3l_log("newt: %d: parsed length %" PRIu64 "\r\n", - getpid(), - nel_d); -#endif - mot_u->len_d -= 8ULL; - - mot_u->mes_u = c3_malloc(sizeof(u3_mess)); - mot_u->mes_u->len_d = nel_d; - mot_u->mes_u->has_d = 0; - mot_u->mes_u->meq_u = mot_u->mes_u->qem_u = 0; - - if ( !mot_u->len_d ) { - c3_free(mot_u->rag_y); - mot_u->rag_y = 0; - } - else { - /* remove consumed length from stray bytes - */ - c3_y* buf_y = c3_malloc(mot_u->len_d); - - memcpy(buf_y, mot_u->rag_y + 8, mot_u->len_d); - - c3_free(mot_u->rag_y); - mot_u->rag_y = buf_y; - - /* remaining bytes will be installed as message meat - */ - continue; - } - } - } - } - - /* check for message completions - */ - if ( mot_u->mes_u && (mot_u->mes_u->has_d >= mot_u->mes_u->len_d) ) { - c3_d len_d = mot_u->mes_u->len_d; - c3_y* buf_y = c3_malloc(len_d); - c3_d pat_d = 0; - u3_meat* met_u; - - /* we should have just cleared this - */ - c3_assert(!mot_u->rag_y); - c3_assert(!mot_u->len_d); - - /* collect queue blocks, cleaning them up; return any spare meat - ** to the rag. - */ - { - met_u = mot_u->mes_u->meq_u; - while ( met_u && (pat_d < len_d) ) { - u3_meat* nex_u = met_u->nex_u; - c3_d end_d = (pat_d + met_u->len_d); - c3_d eat_d; - c3_d rem_d; - - eat_d = c3_min(len_d, end_d) - pat_d; - memcpy(buf_y + pat_d, met_u->hun_y, eat_d); - pat_d += eat_d; - - rem_d = (met_u->len_d - eat_d); - if ( rem_d ) { - mot_u->rag_y = c3_malloc(rem_d); - memcpy(mot_u->rag_y, met_u->hun_y + eat_d, rem_d); - mot_u->len_d = rem_d; - - /* one: unless we got a bad length, this has to be the last - ** block in the message. - ** - ** two: bad data on a newt channel can cause us to assert. - ** that's actually the right thing for a private channel. - */ - c3_assert(0 == nex_u); - } - c3_free(met_u); - met_u = nex_u; - } - c3_assert(pat_d == len_d); - - /* clear the message - */ - c3_free(mot_u->mes_u); - mot_u->mes_u = 0; - } - - /* build and send the object - */ - { - u3_noun mat = u3i_bytes((c3_w) len_d, buf_y); - - mot_u->pok_f(mot_u->vod_p, mat); - } - - /* continue; spare meat may need processing - */ - continue; - } - - /* nothing happening, await next event - */ - break; - } -} - -/* _raft_alloc(): libuv-style allocator for raft. -*/ -static void -_newt_alloc(uv_handle_t* had_u, - size_t len_i, - uv_buf_t* buf_u) -{ - void* ptr_v = c3_malloc(len_i); - - *buf_u = uv_buf_init(ptr_v, len_i); -} - -/* _newt_read_cb(): stream input callback. -*/ -void -_newt_read_cb(uv_stream_t* str_u, - ssize_t len_i, - const uv_buf_t* buf_u) -{ - c3_d len_d = (c3_d) len_i; - u3_moat* mot_u = (void *)str_u; - - if ( UV_EOF == len_i ) { - // u3l_log("newt: %d: stream closed\r\n", getpid()); - uv_read_stop(str_u); - mot_u->bal_f(mot_u->vod_p, "stream closed"); - } - else { -#ifdef NEWT_VERBOSE - u3l_log("newt: %d: read %ld\r\n", getpid(), len_i); -#endif - -#ifdef NEWT_VERBOSE - u3l_log("newt: %d: ", getpid()); - for ( int i = 0; i < len_i; i++) { - if (0 == (i % 16)) u3l_log("\r\n"); - u3l_log(" %02x", (unsigned) buf_u->base[i]); - } - u3l_log("\r\nnewt: %d: \r\n", getpid()); -#endif - - // grow read buffer by `len_d` bytes - // - if ( mot_u->rag_y ) { - mot_u->rag_y = c3_realloc(mot_u->rag_y, mot_u->len_d + len_d); - memcpy(mot_u->rag_y + mot_u->len_d, buf_u->base, len_d); - c3_free(buf_u->base); - } - else { - mot_u->rag_y = (c3_y *)buf_u->base; - mot_u->len_d = len_d; - } - _newt_consume(mot_u); - } -} - -/* u3_newt_read(): start stream reading. -*/ -void -u3_newt_read(u3_moat* mot_u) -{ - c3_i err_i; - - mot_u->mes_u = 0; - mot_u->len_d = 0; - mot_u->rag_y = 0; - - err_i = uv_read_start((uv_stream_t*) &mot_u->pyp_u, - _newt_alloc, - _newt_read_cb); - - if ( err_i != 0 ) { - mot_u->bal_f(mot_u, uv_strerror(err_i)); - } -} - -/* write request for newt -*/ - struct _u3_write_t { - uv_write_t wri_u; - u3_mojo* moj_u; - void* vod_p; - c3_y* buf_y; - }; - -/* _newt_write_cb(): generic write callback. -*/ -static void -_newt_write_cb(uv_write_t* wri_u, c3_i sas_i) -{ - struct _u3_write_t* req_u = (struct _u3_write_t*)wri_u; - void* vod_p = req_u->vod_p; - u3_mojo* moj_u = req_u->moj_u; - - free(req_u->buf_y); - free(req_u); - - if ( 0 != sas_i ) { - u3l_log("newt: bad write %d\r\n", sas_i); - moj_u->bal_f(vod_p, uv_strerror(sas_i)); - } -} - -/* u3_newt_write(): write atom to stream; free atom. -*/ -void -u3_newt_write(u3_mojo* moj_u, - u3_atom mat, - void* vod_p) -{ - c3_w len_w = u3r_met(3, mat); - c3_y* buf_y = c3_malloc(len_w + 8); - struct _u3_write_t* req_u = c3_malloc(sizeof(*req_u)); - uv_buf_t buf_u; - c3_i err_i; - - /* write header; c3_d is futureproofing - */ - buf_y[0] = ((len_w >> 0) & 0xff); - buf_y[1] = ((len_w >> 8) & 0xff); - buf_y[2] = ((len_w >> 16) & 0xff); - buf_y[3] = ((len_w >> 24) & 0xff); - buf_y[4] = buf_y[5] = buf_y[6] = buf_y[7] = 0; - u3r_bytes(0, len_w, buf_y + 8, mat); - u3z(mat); - - req_u->moj_u = moj_u; - req_u->buf_y = buf_y; - buf_u.base = (c3_c*) buf_y; - buf_u.len = len_w + 8; - -#ifdef NEWT_VERBOSE - u3l_log("newt: %d: write %d\n", getpid(), len_w + 8); -#endif - -#ifdef NEWT_VERBOSE - u3l_log("newt: %d: ", getpid()); - for ( int i = 0; i < len_w+8; i++) { - if (0 == (i % 16)) u3l_log("\r\n"); - u3l_log(" %02x", (unsigned) buf_u.base[i]); - } - u3l_log("\r\nnewt: %d: \r\n", getpid()); -#endif - - if ( 0 != (err_i = uv_write((uv_write_t*)req_u, - (uv_stream_t*)&moj_u->pyp_u, - &buf_u, - 1, - _newt_write_cb)) ) - { - moj_u->bal_f(moj_u, uv_strerror(err_i)); - } -} diff --git a/pkg/hair/notes/c/pier.c b/pkg/hair/notes/c/pier.c deleted file mode 100644 index 730e47f09..000000000 --- a/pkg/hair/notes/c/pier.c +++ /dev/null @@ -1,2143 +0,0 @@ -/* vere/pier.c -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -#undef VERBOSE_EVENTS - - /* event handling proceeds on a single path. across both the - ** child worker process (worker) and parent i/o process (daemon). - ** state transitions are as follows: - ** - ** generated (event numbered and queued) - ** dispatched (sent to worker) - ** computed (completed by worker) - ** commit requested (sent to storage subsystem) - ** commit complete (daemon notified) - ** released (output actions allowed) - ** - ** we dispatch one event at a time to the worker. we don't do - ** anything in parallel. - ** - ** the sanity constraints that constrain this path: - ** - ** - an event can't request a commit until it's computed. - ** - an event can't be released until it, and all events - ** preceding it, are computed and committed. - ** - ** event numbers are uint64 (c3_d) which start with 1. we order - ** events as we receive them. - ** - ** events are executed in order by the working process, and - ** (at present) committed in strict order. - ** - ** the result of computing an event can be completion (in which - ** case we go directly to commit) or replacement (in which we - ** replace the input event with a different event). - ** - ** after crash recovery, events committed but not in the snapshot - ** (the state of the worker) are replayed (re-computed), but their - ** output effects are ignored. it is possible that effects of - ** (only the last of ?) these events are not completely released to - ** the outside world -- but they should never be released more than once. - ** - ** XX analyze replay more comprehensively - */ - -static void _pier_apply(u3_pier* pir_u); -static void _pier_boot_complete(u3_pier* pir_u); -static void _pier_boot_ready(u3_pier* pir_u); -static void _pier_boot_set_ship(u3_pier* pir_u, u3_noun who, u3_noun fak); -static void _pier_exit_done(u3_pier* pir_u); -static void _pier_loop_resume(u3_pier* pir_u); - -/* _pier_db_bail(): bail from disk i/o. -*/ -static void -_pier_db_bail(void* vod_p, const c3_c* err_c) -{ - u3l_log("disk error: %s\r\n", err_c); -} - -/* _pier_db_shutdown(): close the log. -*/ -static void -_pier_db_shutdown(u3_pier* pir_u) -{ - u3_lmdb_shutdown(pir_u->log_u->db_u); -} - -/* _pier_db_commit_complete(): commit complete. - */ -static void -_pier_db_commit_complete(c3_o success, - u3_pier* pir_u, - c3_d first_event_d, - c3_d event_count_d) -{ - u3_disk* log_u = pir_u->log_u; - - if (success == c3n) { - u3l_log("Failed to persist event. Exiting to prevent corruption."); - u3_pier_bail(); - } - -#ifdef VERBOSE_EVENTS - if (event_count_d != 1) { - u3l_log("pier: (%" PRIu64 "-%" PRIu64 "): db commit: complete\r\n", - first_event_d, first_event_d + event_count_d - 1ULL); - } else { - u3l_log("pier: (%" PRIu64 "): db commit: complete\r\n", first_event_d); - } -#endif - - /* advance commit counter - */ - { - c3_assert((first_event_d + event_count_d - 1ULL) == log_u->moc_d); - c3_assert(first_event_d == (1ULL + log_u->com_d)); - log_u->com_d += event_count_d; - } - - _pier_loop_resume(pir_u); -} - -/* _pier_db_commit_request(): start commit. -*/ -static void -_pier_db_commit_request(u3_pier* pir_u, - struct u3_lmdb_write_request* request_u, - c3_d first_event_d, - c3_d count_d) -{ - u3_disk* log_u = pir_u->log_u; - -#ifdef VERBOSE_EVENTS - if (count_d != 1) { - u3l_log("pier: (%" PRIu64 "-%" PRIu64 "): db commit: request\r\n", - first_event_d, first_event_d + count_d - 1ULL); - } else { - u3l_log("pier: (%" PRIu64 "): db commit: request\r\n", first_event_d); - } -#endif - - /* put it in the database - */ - { - u3_lmdb_write_event(log_u->db_u, - pir_u, - request_u, - _pier_db_commit_complete); - } - - /* advance commit-request counter - */ - { - c3_assert(first_event_d == (1ULL + log_u->moc_d)); - log_u->moc_d += count_d; - } -} - - -static void -_pier_db_write_header(u3_pier* pir_u, - u3_noun who, - u3_noun is_fake, - u3_noun life) -{ - c3_o ret = u3_lmdb_write_identity(pir_u->log_u->db_u, - who, is_fake, life); - if (ret == c3n) { - u3_pier_bail(); - } -} - -/* _pier_db_read_header(): reads the ships metadata from lmdb - */ -static void -_pier_db_read_header(u3_pier* pir_u) -{ - u3_noun who, is_fake, life; - c3_o ret = u3_lmdb_read_identity(pir_u->log_u->db_u, - &who, &is_fake, &life); - if (ret == c3n) { - u3l_log("Failed to load identity. Exiting..."); - u3_pier_bail(); - } - - _pier_boot_set_ship(pir_u, u3k(who), u3k(is_fake)); - pir_u->lif_d = u3r_chub(0, life); - - u3z(who); - u3z(is_fake); - u3z(life); -} - -static c3_o -_pier_db_on_commit_loaded(u3_pier* pir_u, - c3_d id, - u3_noun mat) -{ - // Need to grab references to the nouns above. - u3_writ* wit_u = c3_calloc(sizeof(u3_writ)); - wit_u->pir_u = pir_u; - wit_u->evt_d = id; - wit_u->mat = u3k(mat); - - // Parse the expected mug_l and job out of mat. - u3_noun entry = u3ke_cue(u3k(mat)); - u3_noun mug, job; - if ( (c3y != u3du(entry)) || - (c3n == u3r_cell(entry, &mug, &job)) || - (c3n == u3ud(mug)) || - (1 < u3r_met(5, mug)) ) { - u3l_log("pier: load: event %" PRIu64 " malformed.\r\n", id); - return c3n; - } - - wit_u->mug_l = u3r_word(0, mug); - wit_u->job = u3k(job); - - u3z(entry); - - // Insert at queue front since we're loading events in order - if ( !pir_u->ent_u ) { - c3_assert(!pir_u->ext_u); - - pir_u->ent_u = pir_u->ext_u = wit_u; - } - else { - if ( wit_u->evt_d != (1ULL + pir_u->ent_u->evt_d) ) { - fprintf(stderr, "pier: load: commit: event gap: %" PRIx64 ", %" - PRIx64 "\r\n", - wit_u->evt_d, - pir_u->ent_u->evt_d); - _pier_db_bail(0, "pier: load: comit: event gap"); - return c3n; - } - - pir_u->ent_u->nex_u = wit_u; - pir_u->ent_u = wit_u; - } - - return c3y; -} - -/* _pier_db_load_commit(): load len_d commits >= lav_d; enqueue for replay -*/ -static void -_pier_db_load_commits(u3_pier* pir_u, - c3_d lav_d, - c3_d len_d) -{ - if (lav_d == 1) { - // We are restarting from event 1. That means we need to set the ship from - // the log identity information. - u3_noun who, fak, len; - c3_o ret = u3_lmdb_read_identity(pir_u->log_u->db_u, - &who, - &fak, - &len); - if (ret == c3n) { - u3l_log("Failed to load identity for replay. Exiting..."); - u3_pier_bail(); - } - - _pier_boot_set_ship(pir_u, u3k(who), u3k(fak)); - pir_u->lif_d = u3r_chub(0, len); - - u3z(who); - u3z(fak); - u3z(len); - } - - c3_o ret = u3_lmdb_read_events(pir_u, - lav_d, - len_d, - _pier_db_on_commit_loaded); - if (ret == c3n) { - u3l_log("Failed to read event log for replay. Exiting..."); - u3_pier_bail(); - } -} - -/* _pier_db_init(): -*/ -static c3_o -_pier_db_init(u3_disk* log_u) -{ - c3_d evt_d = 0; - c3_d pos_d = 0; - - c3_assert( c3n == log_u->liv_o ); - - // Request from the database the last event - if ( c3n == u3_lmdb_get_latest_event_number(log_u->db_u, &evt_d) ) { - u3l_log("disk init from lmdb failed."); - return c3n; - } - - log_u->liv_o = c3y; - log_u->com_d = log_u->moc_d = evt_d; - - _pier_boot_ready(log_u->pir_u); - - return c3y; -} - -/* _pier_disk_create(): load log for given point. -*/ -static c3_o -_pier_disk_create(u3_pier* pir_u) -{ - u3_disk* log_u = c3_calloc(sizeof(*log_u)); - - pir_u->log_u = log_u; - log_u->pir_u = pir_u; - log_u->liv_o = c3n; - - /* create/load pier, urbit directory, log directory. - */ - { - /* pier directory - */ - { - if ( 0 == (log_u->dir_u = u3_foil_folder(pir_u->pax_c)) ) { - return c3n; - } - } - - /* pier/.urb - */ - { - c3_c* urb_c = c3_malloc(6 + strlen(pir_u->pax_c)); - - strcpy(urb_c, pir_u->pax_c); - strcat(urb_c, "/.urb"); - - if ( 0 == (log_u->urb_u = u3_foil_folder(urb_c)) ) { - c3_free(urb_c); - return c3n; - } - c3_free(urb_c); - } - - /* pier/.urb/log - */ - { - c3_c* log_c = c3_malloc(10 + strlen(pir_u->pax_c)); - - strcpy(log_c, pir_u->pax_c); - strcat(log_c, "/.urb/log"); - - // Creates the folder - if ( 0 == (log_u->com_u = u3_foil_folder(log_c)) ) { - c3_free(log_c); - return c3n; - } - - // Inits the database - if ( 0 == (log_u->db_u = u3_lmdb_init(log_c)) ) { - c3_free(log_c); - return c3n; - } - - c3_free(log_c); - } - - /* pier/.urb/put and pier/.urb/get - */ - { - c3_c* dir_c = c3_malloc(10 + strlen(pir_u->pax_c)); - - strcpy(dir_c, pir_u->pax_c); - strcat(dir_c, "/.urb/put"); - mkdir(dir_c, 0700); - - strcpy(dir_c, pir_u->pax_c); - strcat(dir_c, "/.urb/get"); - mkdir(dir_c, 0700); - - c3_free(dir_c); - } - } - - // create/load event log - // - if ( c3n == _pier_db_init(log_u) ) { - return c3n; - } - - return c3y; -} - -/* _pier_writ_insert(): insert raw event. -*/ -static void -_pier_writ_insert(u3_pier* pir_u, - c3_l msc_l, - u3_noun job) -{ - u3_writ* wit_u = c3_calloc(sizeof(u3_writ)); - wit_u->pir_u = pir_u; - - wit_u->evt_d = pir_u->gen_d; - pir_u->gen_d++; - - wit_u->msc_l = msc_l; - - wit_u->job = job; - - if ( !pir_u->ent_u ) { - c3_assert(!pir_u->ext_u); - - pir_u->ent_u = pir_u->ext_u = wit_u; - } - else { - pir_u->ent_u->nex_u = wit_u; - pir_u->ent_u = wit_u; - } -} - -/* _pier_writ_insert_ovum(): insert raw ovum - for boot sequence. -*/ -static void -_pier_writ_insert_ovum(u3_pier* pir_u, - c3_l msc_l, - u3_noun ovo) -{ - u3_noun now; - struct timeval tim_tv; - - gettimeofday(&tim_tv, 0); - now = u3_time_in_tv(&tim_tv); - - _pier_writ_insert(pir_u, msc_l, u3nc(now, ovo)); -} - -/* _pier_writ_find(): find writ by event number. -*/ -static u3_writ* -_pier_writ_find(u3_pier* pir_u, - c3_d evt_d) -{ - u3_writ* wit_u; - - /* very unlikely to be O(n) and n is small - */ - for ( wit_u = pir_u->ext_u; wit_u; wit_u = wit_u->nex_u ) { - if ( evt_d == wit_u->evt_d ) { - return wit_u; - } - } - return 0; -} - -/* _pier_writ_unlink(): unlink writ from queue. -*/ -static void -_pier_writ_unlink(u3_writ* wit_u) -{ - u3_pier* pir_u = wit_u->pir_u; - -#ifdef VERBOSE_EVENTS - fprintf(stderr, "pier: (%" PRIu64 "): delete\r\n", wit_u->evt_d); -#endif - - pir_u->ext_u = wit_u->nex_u; - - if ( wit_u == pir_u->ent_u ) { - c3_assert(pir_u->ext_u == 0); - pir_u->ent_u = 0; - } -} - -/* _pier_writ_dispose(): dispose of writ. -*/ -static void -_pier_writ_dispose(u3_writ* wit_u) -{ - /* free contents - */ - u3z(wit_u->job); - u3z(wit_u->mat); - u3z(wit_u->act); - - c3_free(wit_u); -} - -/* _pier_work_bail(): handle subprocess error. -*/ -static void -_pier_work_bail(void* vod_p, - const c3_c* err_c) -{ - fprintf(stderr, "pier: work error: %s\r\n", err_c); -} - -/* _pier_work_boot(): prepare for boot. -*/ -static void -_pier_work_boot(u3_pier* pir_u, c3_o sav_o) -{ - u3_controller* god_u = pir_u->god_u; - - c3_assert( 0 != pir_u->lif_d ); - - u3_noun who = u3i_chubs(2, pir_u->who_d); - u3_noun len = u3i_chubs(1, &pir_u->lif_d); - - if ( c3y == sav_o ) { - _pier_db_write_header(pir_u, who, u3k(pir_u->fak_o), len); - } - - u3_noun msg = u3nq(c3__boot, who, pir_u->fak_o, len); - u3_atom mat = u3ke_jam(msg); - u3_newt_write(&god_u->inn_u, mat, 0); -} - -/* _pier_work_shutdown(): stop the worker process. -*/ -static void -_pier_work_shutdown(u3_pier* pir_u) -{ - u3_controller* god_u = pir_u->god_u; - - u3_newt_write(&god_u->inn_u, u3ke_jam(u3nc(c3__exit, 0)), 0); -} - -/* _pier_work_build(): build atomic action. -*/ -static void -_pier_work_build(u3_writ* wit_u) -{ - /* marshal into atom - */ - if ( 0 == wit_u->mat ) { - c3_assert(0 != wit_u->job); - - wit_u->mat = u3ke_jam(u3nc(wit_u->mug_l, - u3k(wit_u->job))); - } -} - -/* _pier_work_send(): send to worker. -*/ -static void -_pier_work_send(u3_writ* wit_u) -{ - u3_pier* pir_u = wit_u->pir_u; - u3_controller* god_u = pir_u->god_u; - - c3_assert(0 != wit_u->mat); - - u3_noun msg = u3ke_jam(u3nt(c3__work, - u3i_chubs(1, &wit_u->evt_d), - u3k(wit_u->mat))); - - u3_newt_write(&god_u->inn_u, msg, wit_u); -} - -/* _pier_work_save(): tell worker to save checkpoint. -*/ -static void -_pier_work_save(u3_pier* pir_u) -{ - u3_controller* god_u = pir_u->god_u; - u3_disk* log_u = pir_u->log_u; - u3_save* sav_u = pir_u->sav_u; - - c3_assert( god_u->dun_d == sav_u->req_d ); - c3_assert( log_u->com_d >= god_u->dun_d ); - - { - u3_noun mat = u3ke_jam(u3nc(c3__save, u3i_chubs(1, &god_u->dun_d))); - u3_newt_write(&god_u->inn_u, mat, 0); - - // XX wait on some report of success before updating? - // - sav_u->dun_d = sav_u->req_d; - } - - // if we're gracefully shutting down, do so now - // - if ( u3_psat_done == pir_u->sat_e ) { - _pier_exit_done(pir_u); - } -} - -/* _pier_work_release(): apply side effects. -*/ -static void -_pier_work_release(u3_writ* wit_u) -{ - u3_pier* pir_u = wit_u->pir_u; - u3_controller* god_u = pir_u->god_u; - u3_noun vir = wit_u->act; - - if ( u3_psat_pace == pir_u->sat_e ) { - fputc('.', stderr); - - // enqueue another batch of events for replay - // - { - u3_disk* log_u = pir_u->log_u; - - // XX requires that writs be unlinked before effects are released - // - if ( (0 == pir_u->ent_u) && - (wit_u->evt_d < log_u->com_d) ) - { - _pier_db_load_commits(pir_u, (1ULL + god_u->dun_d), 1000ULL); - } - } - } - else { -#ifdef VERBOSE_EVENTS - fprintf(stderr, "pier: (%" PRIu64 "): compute: release\r\n", wit_u->evt_d); -#endif - - // advance release counter - // - { - c3_assert(wit_u->evt_d == (1ULL + god_u->rel_d)); - god_u->rel_d += 1ULL; - } - - // apply actions - // - while ( u3_nul != vir ) { - u3_noun ovo, nex; - u3x_cell(vir, &ovo, &nex); - - u3_reck_kick(pir_u, u3k(ovo)); - vir = nex; - } - } - - // if we have completed the boot sequence, activate system events. - // - if ( wit_u->evt_d == pir_u->but_d ) { - _pier_boot_complete(pir_u); - } - - // take snapshot, if requested (and awaiting the commit of this event) - // - { - u3_save* sav_u = pir_u->sav_u; - - if ( (sav_u->req_d > sav_u->dun_d) && - (wit_u->evt_d == sav_u->req_d) ) - { - _pier_work_save(pir_u); - } - } -} - -/* _pier_work_complete(): worker reported completion. -*/ -static void -_pier_work_complete(u3_writ* wit_u, - c3_l mug_l, - u3_noun act) -{ - u3_pier* pir_u = wit_u->pir_u; - u3_controller* god_u = pir_u->god_u; - -#ifdef VERBOSE_EVENTS - fprintf(stderr, "pier: (%" PRIu64 "): compute: complete\r\n", wit_u->evt_d); -#endif - - god_u->dun_d += 1; - c3_assert(god_u->dun_d == wit_u->evt_d); - - god_u->mug_l = mug_l; - - c3_assert(wit_u->act == 0); - wit_u->act = act; - - if ( wit_u->evt_d > pir_u->lif_d ) { - u3_term_stop_spinner(); - } -} - -/* _pier_work_replace(): worker reported replacement. -*/ -static void -_pier_work_replace(u3_writ* wit_u, - u3_noun job) -{ - u3_pier* pir_u = wit_u->pir_u; - u3_controller* god_u = pir_u->god_u; - -#ifdef VERBOSE_EVENTS - fprintf(stderr, "pier: (%" PRIu64 "): compute: replace\r\n", wit_u->evt_d); -#endif - - c3_assert(god_u->sen_d == wit_u->evt_d); - - // something has gone very wrong, we should probably stop now - // - if ( wit_u->rep_d >= 3ULL ) { - u3_pier_bail(); - } - - /* move backward in work processing - */ - { - u3z(wit_u->job); - wit_u->job = job; - - u3z(wit_u->mat); - wit_u->mat = u3ke_jam(u3nc(wit_u->mug_l, - u3k(wit_u->job))); - - wit_u->rep_d += 1ULL; - - god_u->sen_d -= 1ULL; - } - - if ( wit_u->evt_d > pir_u->lif_d ) { - u3_term_stop_spinner(); - } -} - -/* _pier_work_compute(): dispatch for processing. -*/ -static void -_pier_work_compute(u3_writ* wit_u) -{ - u3_pier* pir_u = wit_u->pir_u; - u3_controller* god_u = pir_u->god_u; - -#ifdef VERBOSE_EVENTS - fprintf(stderr, "pier: (%" PRIu64 "): compute: request\r\n", wit_u->evt_d); -#endif - - c3_assert(wit_u->evt_d == (1 + god_u->sen_d)); - - wit_u->mug_l = god_u->mug_l; - - _pier_work_build(wit_u); - _pier_work_send(wit_u); - - god_u->sen_d += 1; - - if ( wit_u->evt_d > pir_u->lif_d ) { - u3_term_start_spinner(wit_u->job); - } -} - -/* _pier_work_play(): with active worker, create or load log. -*/ -static void -_pier_work_play(u3_pier* pir_u, - c3_d lav_d, - c3_l mug_l) -{ - u3_controller* god_u = pir_u->god_u; - -#ifdef VERBOSE_EVENTS - fprintf(stderr, "pier: (%" PRIu64 "): boot at mug %x\r\n", lav_d, mug_l); -#endif - - c3_assert( c3n == god_u->liv_o ); - god_u->liv_o = c3y; - - // all events in the worker are complete - // - god_u->rel_d = god_u->dun_d = god_u->sen_d = (lav_d - 1ULL); - god_u->mug_l = mug_l; - - _pier_boot_ready(pir_u); -} - -/* _pier_work_stdr(): prints an error message to stderr - */ -static void -_pier_work_stdr(u3_writ* wit_u, u3_noun cord) -{ - c3_c* str = u3r_string(cord); - u3C.stderr_log_f(str); - free(str); -} - -/* _pier_work_slog(): print directly. -*/ -static void -_pier_work_slog(u3_writ* wit_u, c3_w pri_w, u3_noun tan) -{ -#ifdef U3_EVENT_TIME_DEBUG - { - static int old; - static struct timeval b4, f2, d0; - static c3_d b4_d; - c3_w ms_w; - - if ( old ) { - gettimeofday(&f2, 0); - timersub(&f2, &b4, &d0); - ms_w = (d0.tv_sec * 1000) + (d0.tv_usec / 1000); - if (ms_w > 1) { - #if 0 - fprintf(stderr, "%6d.%02dms: %9d ", - ms_w, (int) (d0.tv_usec % 1000) / 10, - ((int) (u3R->pro.nox_d - b4_d))); - #else - fprintf(stderr, "%6d.%02dms ", - ms_w, (int) (d0.tv_usec % 1000) / 10); - #endif - gettimeofday(&b4, 0); - b4_d = u3R->pro.nox_d; - } - else { - fprintf(stderr, " "); - } - } - else { - gettimeofday(&b4, 0); - b4_d = u3R->pro.nox_d; - } - old = 1; - } -#endif - - switch ( pri_w ) { - case 3: fprintf(stderr, ">>> "); break; - case 2: fprintf(stderr, ">> "); break; - case 1: fprintf(stderr, "> "); break; - } - - u3_pier_tank(0, tan); -} - -/* _pier_work_exit(): handle subprocess exit. -*/ -static void -_pier_work_exit(uv_process_t* req_u, - c3_ds sas_i, - c3_i sig_i) -{ - u3_controller* god_u = (void *) req_u; - u3_pier* pir_u = god_u->pir_u; - - u3l_log("pier: exit: status %" PRIu64 ", signal %d\r\n", sas_i, sig_i); - uv_close((uv_handle_t*) req_u, 0); - - _pier_db_shutdown(pir_u); - _pier_work_shutdown(pir_u); -} - -/* _pier_work_poke(): handle subprocess result. transfer nouns. -*/ -static void -_pier_work_poke(void* vod_p, - u3_noun mat) -{ - u3_pier* pir_u = vod_p; - u3_noun jar = u3ke_cue(u3k(mat)); - u3_noun p_jar, q_jar, r_jar; - - if ( c3y != u3du(jar) ) { - goto error; - } - - switch ( u3h(jar) ) { - default: goto error; - - // the worker process starts with a %play task, - // which tells us where to start playback - // (and who we are, if it knows) XX remove in favor of event-log header - // - case c3__play: { - c3_d lav_d; - c3_l mug_l; - - if ( (c3n == u3r_qual(u3t(jar), 0, &p_jar, &q_jar, &r_jar)) || - (c3n == u3ud(p_jar)) || - (u3r_met(6, p_jar) != 1) || - (c3n == u3ud(q_jar)) || - (u3r_met(5, p_jar) != 1) || - (c3n == u3du(r_jar)) || - (c3n == u3ud(u3h(r_jar))) || - ((c3y != u3t(r_jar)) && (c3n != u3t(r_jar))) ) - { - if ( u3_nul == u3t(jar) ) { - lav_d = 1ULL; - mug_l = 0; - } - else { - goto error; - } - } - - if ( u3_nul != u3t(jar) ) { - lav_d = u3r_chub(0, p_jar); - mug_l = u3r_word(0, q_jar); - - // single-home - // - _pier_boot_set_ship(pir_u, u3k(u3h(r_jar)), u3k(u3t(r_jar))); - } - - _pier_work_play(pir_u, lav_d, mug_l); - break; - } - - case c3__work: { - if ( (c3n == u3r_trel(jar, 0, &p_jar, &q_jar)) || - (c3n == u3ud(p_jar)) || - (u3r_met(6, p_jar) != 1) ) - { - u3l_log("failed to parse replacement atom"); - goto error; - } - else { - c3_d evt_d = u3r_chub(0, p_jar); - u3_writ* wit_u = _pier_writ_find(pir_u, evt_d); - - u3_noun mug, job; - u3_noun entry = u3ke_cue(u3k(q_jar)); - if ( (c3y != u3du(entry)) || - (c3n == u3r_cell(entry, &mug, &job)) || - (c3n == u3ud(mug)) || - (1 < u3r_met(5, mug)) ) { - goto error; - } - - c3_l mug_l = u3r_word(0, mug); - if ( !wit_u || (mug_l && (mug_l != wit_u->mug_l)) ) { - goto error; - } -#ifdef VERBOSE_EVENTS - fprintf(stderr, "pier: replace: %" PRIu64 "\r\n", evt_d); -#endif - - _pier_work_replace(wit_u, u3k(job)); - } - break; - } - - case c3__done: { - if ( (c3n == u3r_qual(jar, 0, &p_jar, &q_jar, &r_jar)) || - (c3n == u3ud(p_jar)) || - (u3r_met(6, p_jar) != 1) || - (c3n == u3ud(q_jar)) || - (u3r_met(5, q_jar) > 1) ) - { - goto error; - } - else { - c3_d evt_d = u3r_chub(0, p_jar); - c3_l mug_l = u3r_word(0, q_jar); - u3_writ* wit_u = _pier_writ_find(pir_u, evt_d); - - if ( !wit_u ) { - u3l_log("poke: no writ: %" PRIu64 "\r\n", evt_d); - goto error; - } - _pier_work_complete(wit_u, mug_l, u3k(r_jar)); - } - break; - } - - case c3__stdr: { - if ( (c3n == u3r_trel(jar, 0, &p_jar, &q_jar)) || - (c3n == u3ud(p_jar)) || - (u3r_met(6, p_jar) > 1) || - (c3n == u3ud(q_jar)) ) - { - goto error; - } - else { - c3_d evt_d = u3r_chub(0, p_jar); - u3_writ* wit_u = _pier_writ_find(pir_u, evt_d); - - // Unlike slog, we always reprint interpreter errors during replay. - _pier_work_stdr(wit_u, q_jar); - } - break; - } - - case c3__slog: { - if ( (c3n == u3r_qual(jar, 0, &p_jar, &q_jar, &r_jar)) || - (c3n == u3ud(p_jar)) || - (u3r_met(6, p_jar) != 1) || - (c3n == u3ud(q_jar)) || - (u3r_met(3, q_jar) > 1) ) - { - goto error; - } - else { - c3_d evt_d = u3r_chub(0, p_jar); - c3_w pri_w = u3r_word(0, q_jar); - u3_writ* wit_u = _pier_writ_find(pir_u, evt_d); - - // skip slog during replay - // - // XX also update the worker to skip *sending* the slog during replay - // - if ( u3_psat_pace != pir_u->sat_e ) { - _pier_work_slog(wit_u, pri_w, u3k(r_jar)); - } - } - break; - } - } - - u3z(jar); u3z(mat); - _pier_loop_resume(pir_u); - return; - - error: { - u3z(jar); u3z(mat); - _pier_work_bail(0, "bad jar"); - } -} - -/* pier_work_create(): instantiate child process. -*/ -static u3_controller* -_pier_work_create(u3_pier* pir_u) -{ - u3_controller* god_u = c3_calloc(sizeof *god_u); - - pir_u->god_u = god_u; - god_u->pir_u = pir_u; - god_u->liv_o = c3n; - - /* spawn new process and connect to it - */ - { - c3_c* arg_c[5]; - c3_c* bin_c = u3_Host.wrk_c; - c3_c* pax_c; - c3_c key_c[256]; - c3_c wag_c[11]; - c3_i err_i; - - pax_c = c3_malloc(1 + strlen(pir_u->pax_c)); - strcpy(pax_c, pir_u->pax_c); - - sprintf(key_c, "%" PRIx64 ":%" PRIx64 ":%" PRIx64 ":%" PRIx64 "", - pir_u->key_d[0], - pir_u->key_d[1], - pir_u->key_d[2], - pir_u->key_d[3]); - - sprintf(wag_c, "%u", pir_u->wag_w); - - arg_c[0] = bin_c; // executable - arg_c[1] = pax_c; // path to checkpoint directory - arg_c[2] = key_c; // disk key - arg_c[3] = wag_c; // runtime config - arg_c[4] = 0; - - uv_pipe_init(u3L, &god_u->inn_u.pyp_u, 0); - uv_pipe_init(u3L, &god_u->out_u.pyp_u, 0); - - god_u->cod_u[0].flags = UV_CREATE_PIPE | UV_READABLE_PIPE; - god_u->cod_u[0].data.stream = (uv_stream_t *)&god_u->inn_u; - - god_u->cod_u[1].flags = UV_CREATE_PIPE | UV_WRITABLE_PIPE; - god_u->cod_u[1].data.stream = (uv_stream_t *)&god_u->out_u; - - god_u->cod_u[2].flags = UV_INHERIT_FD; - god_u->cod_u[2].data.fd = 2; - - god_u->ops_u.stdio = god_u->cod_u; - god_u->ops_u.stdio_count = 3; - - god_u->ops_u.exit_cb = _pier_work_exit; - god_u->ops_u.file = arg_c[0]; - god_u->ops_u.args = arg_c; - - if ( (err_i = uv_spawn(u3L, &god_u->cub_u, &god_u->ops_u)) ) { - fprintf(stderr, "spawn: %s: %s\r\n", arg_c[0], uv_strerror(err_i)); - - return 0; - } - } - - /* start reading from proc - */ - { - god_u->out_u.vod_p = pir_u; - god_u->out_u.pok_f = _pier_work_poke; - god_u->out_u.bal_f = _pier_work_bail; - - god_u->inn_u.bal_f = _pier_work_bail; - - u3_newt_read(&god_u->out_u); - } - return god_u; -} - -/* _pier_loop_time(): set time. -*/ -static void -_pier_loop_time(void) -{ - struct timeval tim_tv; - - gettimeofday(&tim_tv, 0); - u3v_time(u3_time_in_tv(&tim_tv)); -} - -/* _pier_loop_prepare(): run on every loop iteration before i/o polling. -*/ -static void -_pier_loop_prepare(uv_prepare_t* pep_u) -{ - _pier_loop_time(); -} - -/* _pier_loop_idle_cb(): run on every loop iteration after i/o polling. -*/ -static void -_pier_loop_idle_cb(uv_idle_t* idl_u) -{ - u3_pier* pir_u = idl_u->data; - _pier_apply(pir_u); - - uv_idle_stop(idl_u); -} - -/* _pier_loop_resume(): (re-)activate idle handler -*/ -static void -_pier_loop_resume(u3_pier* pir_u) -{ - if ( !uv_is_active((uv_handle_t*)&pir_u->idl_u) ) { - uv_idle_start(&pir_u->idl_u, _pier_loop_idle_cb); - } -} - -/* _pier_loop_init_pier(): initialize loop handlers. -*/ -static void -_pier_loop_init(u3_pier* pir_u) -{ - c3_l cod_l; - - _pier_loop_time(); - - // for i/o drivers that still use u3A->sen - // - u3v_numb(); - - cod_l = u3a_lush(c3__ames); - u3_ames_io_init(pir_u); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__behn); - u3_behn_io_init(pir_u); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__unix); - u3_unix_io_init(pir_u); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__save); - u3_save_io_init(pir_u); - u3a_lop(cod_l); - - // XX legacy handlers, not yet scoped to a pier - // - { - cod_l = u3a_lush(c3__term); - u3_term_io_init(); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__http); - u3_http_io_init(); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__cttp); - u3_cttp_io_init(); - u3a_lop(cod_l); - } -} - -/* _pier_loop_wake(): initialize listeners and send initial events. -*/ -static void -_pier_loop_wake(u3_pier* pir_u) -{ - c3_l cod_l; - - // inject fresh entropy - // - { - c3_w eny_w[16]; - c3_rand(eny_w); - - u3_noun wir = u3nt(u3_blip, c3__arvo, u3_nul); - u3_noun car = u3nc(c3__wack, u3i_words(16, eny_w)); - - u3_pier_work(pir_u, wir, car); - } - - cod_l = u3a_lush(c3__unix); - u3_unix_io_talk(pir_u); - u3_unix_ef_bake(pir_u); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__ames); - u3_ames_io_talk(pir_u); - u3_ames_ef_bake(pir_u); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__behn); - u3_behn_ef_bake(pir_u); - u3a_lop(cod_l); - - // XX legacy handlers, not yet scoped to a pier - // - { - cod_l = u3a_lush(c3__http); - u3_http_io_talk(); - u3_http_ef_bake(); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__term); - u3_term_io_talk(); - u3_term_ef_bake(); - u3a_lop(cod_l); - } -} - -/* _pier_loop_exit(): terminate I/O across the process. -*/ -static void -_pier_loop_exit(u3_pier* pir_u) -{ - c3_l cod_l; - - cod_l = u3a_lush(c3__unix); - u3_unix_io_exit(pir_u); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__ames); - u3_ames_io_exit(pir_u); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__save); - u3_save_io_exit(pir_u); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__behn); - u3_behn_io_exit(pir_u); - u3a_lop(cod_l); - - // XX legacy handlers, not yet scoped to a pier - // - { - cod_l = u3a_lush(c3__term); - u3_term_io_exit(); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__http); - u3_http_io_exit(); - u3a_lop(cod_l); - - cod_l = u3a_lush(c3__cttp); - u3_cttp_io_exit(); - u3a_lop(cod_l); - } -} - -/* _pier_boot_set_ship(): -*/ -static void -_pier_boot_set_ship(u3_pier* pir_u, u3_noun who, u3_noun fak) -{ - c3_assert( c3y == u3ud(who) ); - c3_assert( (c3y == fak) || (c3n == fak) ); - - c3_o fak_o = fak; - c3_d who_d[2]; - - u3r_chubs(0, 2, who_d, who); - - c3_assert( ( (0 == pir_u->fak_o) && - (0 == pir_u->who_d[0]) && - (0 == pir_u->who_d[1]) ) || - ( (fak_o == pir_u->fak_o) && - (who_d[0] == pir_u->who_d[0]) && - (who_d[1] == pir_u->who_d[1]) ) ); - - pir_u->fak_o = fak_o; - pir_u->who_d[0] = who_d[0]; - pir_u->who_d[1] = who_d[1]; - - { - u3_noun how = u3dc("scot", 'p', u3k(who)); - - c3_free(pir_u->who_c); - pir_u->who_c = u3r_string(how); - u3z(how); - } - - // Disable networking for fake ships - // - if ( c3y == pir_u->fak_o ) { - u3_Host.ops_u.net = c3n; - } - - u3z(who); u3z(fak); -} - -/* _pier_boot_create(): create boot controller -*/ -static u3_boot* -_pier_boot_create(u3_pier* pir_u, u3_noun pil, u3_noun ven) -{ - u3_boot* bot_u = c3_calloc(sizeof(u3_boot)); - bot_u->pil = u3k(pil); - bot_u->ven = u3k(ven); - bot_u->pir_u = pir_u; - - return bot_u; -} - -/* _pier_boot_dispose(): dispose of boot controller -*/ -static void -_pier_boot_dispose(u3_boot* bot_u) -{ - u3_pier* pir_u = bot_u->pir_u; - - u3z(bot_u->pil); - u3z(bot_u->ven); - free(bot_u); - pir_u->bot_u = 0; -} - -/* _pier_boot_vent(): create and enqueue boot sequence -** -** per cgy: -** this new boot sequence is almost, but not quite, -** the right thing. see new arvo. -*/ -static void -_pier_boot_vent(u3_boot* bot_u) -{ - // bot: boot formulas - // mod: module ova - // use: userpace ova - // - u3_noun bot, mod, use; - u3_pier* pir_u = bot_u->pir_u; - - // extract boot formulas and module/userspace ova from pill - // - { - u3_noun pil_p, pil_q, pil_r; - u3_noun pro; - - c3_assert( c3y == u3du(bot_u->pil) ); - - if ( c3y == u3h(bot_u->pil) ) { - u3x_trel(bot_u->pil, 0, &pil_p, &pil_q); - } - else { - u3x_qual(bot_u->pil, 0, &pil_p, &pil_q, &pil_r); - } - - pro = u3m_soft(0, u3ke_cue, u3k(pil_p)); - - if ( 0 != u3h(pro) ) { - fprintf(stderr, "boot: failed: unable to parse pill\r\n"); - exit(1); - } - - u3x_trel(u3t(pro), &bot, &mod, &use); - u3k(bot); u3k(mod); u3k(use); - - // optionally replace filesystem in userspace - // - if ( c3y == u3h(bot_u->pil) ) { - if ( u3_nul != pil_q ) { - c3_w len_w = 0; - u3_noun ova = use; - u3_noun new = u3_nul; - u3_noun ovo; - - while ( u3_nul != ova ) { - ovo = u3h(ova); - - if ( c3__into == u3h(u3t(ovo)) ) { - c3_assert( 0 == len_w ); - len_w++; - ovo = u3k(u3t(pil_q)); - } - - new = u3nc(u3k(ovo), new); - ova = u3t(ova); - } - - c3_assert( 1 == len_w ); - - u3z(use); - use = u3kb_flop(new); - } - } - // prepend %lite module and userspace ova - // - else { - mod = u3kb_weld(u3k(pil_q), mod); - use = u3kb_weld(u3k(pil_r), use); - } - - u3z(pro); - } - - // prepend entropy to the module sequence - // - { - c3_w eny_w[16]; - c3_rand(eny_w); - - u3_noun wir = u3nt(u3_blip, c3__arvo, u3_nul); - u3_noun car = u3nc(c3__wack, u3i_words(16, eny_w)); - - mod = u3nc(u3nc(wir, car), mod); - } - - // prepend identity to the module sequence, setting single-home - // - { - u3_noun wir = u3nt(u3_blip, c3__arvo, u3_nul); - u3_noun car = u3nc(c3__whom, u3i_chubs(2, pir_u->who_d)); - - mod = u3nc(u3nc(wir, car), mod); - } - - // insert boot sequence directly - // - // Note that these are not ovum or (pair @da ovum) events, - // but raw nock formulas to be directly evaluated as the - // subject of the lifecycle formula [%2 [%0 3] %0 2]. - // All subsequent events will be (pair @da ovum). - // - { - u3_noun fol = bot; - - // initialize the boot barrier - // - // And the initial lifecycle boot barrier. - // - pir_u->but_d = u3kb_lent(u3k(fol)); - pir_u->lif_d = pir_u->but_d; - - while ( u3_nul != fol ) { - _pier_writ_insert(pir_u, 0, u3k(u3h(fol))); - fol = u3t(fol); - } - } - - // insert module events - // - { - u3_noun ova = mod; - // add to the boot barrier - // - pir_u->but_d += u3kb_lent(u3k(ova)); - - while ( u3_nul != ova ) { - _pier_writ_insert_ovum(pir_u, 0, u3k(u3h(ova))); - ova = u3t(ova); - } - } - - // insert legacy boot event - // - { - // XX do something about this wire - // XX route directly to %jael? - // - c3_assert( c3y == u3du(bot_u->ven) ); - - u3_noun wir = u3nq(u3_blip, c3__term, '1', u3_nul); - u3_noun car = u3nc(c3__boot, u3k(bot_u->ven)); - u3_noun ovo = u3nc(wir, car); - - _pier_writ_insert_ovum(pir_u, 0, ovo); - } - - // insert userspace events - // - // Currently just the initial filesystem - // - { - u3_noun ova = use; - - while ( u3_nul != ova ) { - _pier_writ_insert_ovum(pir_u, 0, u3k(u3h(ova))); - ova = u3t(ova); - } - } - - u3z(bot); u3z(mod); u3z(use); -} - -/* _pier_boot_complete(): start organic event flow on boot/reboot. -*/ -static void -_pier_boot_complete(u3_pier* pir_u) -{ - if ( u3_psat_init != pir_u->sat_e ) { - u3_pier_snap(pir_u); - } - - if ( u3_psat_boot == pir_u->sat_e ) { - fprintf(stderr, "pier: boot complete\r\n"); - } - else if ( u3_psat_pace == pir_u->sat_e ) { - fprintf(stderr, "\n\r---------------- playback complete----------------\r\n"); - } - - pir_u->sat_e = u3_psat_play; - - // the main course - // - _pier_loop_wake(pir_u); - - // XX where should this go? - // - { - if ( c3y == u3_Host.ops_u.veb ) { - u3_term_ef_verb(); - } - } -} - -/* _pier_boot_ready(): -*/ -static void -_pier_boot_ready(u3_pier* pir_u) -{ - u3_controller* god_u = pir_u->god_u; - u3_disk* log_u = pir_u->log_u; - - c3_assert( u3_psat_init == pir_u->sat_e ); - - if ( ( 0 == god_u) || - ( 0 == log_u) || - (c3y != god_u->liv_o) || - (c3y != log_u->liv_o) ) - { - return; - } - - // mark all commits as released - // - god_u->rel_d = log_u->com_d; - - // set next expected event number - // - pir_u->gen_d = (1ULL + log_u->com_d); - - // boot - // - if ( 0 != pir_u->bot_u ) { - c3_assert( 0 == log_u->com_d ); - c3_assert( 0 == god_u->dun_d ); - - // construct/enqueue boot sequence - // - _pier_boot_vent(pir_u->bot_u); - _pier_boot_dispose(pir_u->bot_u); - - // prepare worker for boot sequence, write log header - // - _pier_work_boot(pir_u, c3y); - - fprintf(stderr, "boot: ship: %s%s\r\n", - pir_u->who_c, - (c3y == pir_u->fak_o) ? " (fake)" : ""); - - pir_u->sat_e = u3_psat_boot; - } - // replay - // - else if ( god_u->dun_d < log_u->com_d ) { - c3_assert( 0 != log_u->com_d ); - - fprintf(stderr, "---------------- playback starting----------------\r\n"); - - // set the boot barrier to the last committed event - // - pir_u->but_d = log_u->com_d; - - // begin queuing batches of committed events - // - _pier_db_load_commits(pir_u, (1ULL + god_u->dun_d), 1000ULL); - - if ( 0 == god_u->dun_d ) { - fprintf(stderr, "pier: replaying events 1 through %" PRIu64 "\r\n", - log_u->com_d); - - // prepare worker for replay of boot sequence, don't write log header - // - _pier_work_boot(pir_u, c3n); - } - else { - fprintf(stderr, "pier: replaying events %" PRIu64 - " through %" PRIu64 "\r\n", - god_u->dun_d, - log_u->com_d); - } - - pir_u->sat_e = u3_psat_pace; - } - // resume - // - else { - c3_assert( 0 != log_u->com_d ); - c3_assert( 0 != god_u->dun_d ); - - // set the boot barrier to the last computed event - // - pir_u->but_d = god_u->dun_d; - - // resume normal operation - // - _pier_boot_complete(pir_u); - } -} - -/* _pier_apply(): react to i/o, inbound or outbound. -*/ -static void -_pier_apply(u3_pier* pir_u) -{ - u3_disk* log_u = pir_u->log_u; - u3_controller* god_u = pir_u->god_u; - u3_save* sav_u = pir_u->sav_u; - - if ( (0 == log_u) || - (0 == god_u) || - (c3n == god_u->liv_o) || - (u3_psat_init == pir_u->sat_e) ) - { - return; - } - - u3_writ* wit_u; - c3_o act_o = c3n; - -start: - - /* iterate from queue exit, advancing any writs that can advance - */ - wit_u = pir_u->ext_u; - while ( wit_u ) { - /* if writ is (a) next in line to compute, (b) worker is inactive, - ** and (c) a snapshot has not been requested, request computation - */ - if ( (wit_u->evt_d == (1 + god_u->sen_d)) && - (god_u->sen_d == god_u->dun_d) && - (sav_u->dun_d == sav_u->req_d) ) - { - _pier_work_compute(wit_u); - act_o = c3y; - } - - /* if writ is (a) computed and (b) next in line to commit, - ** and (c) no commit is in progress and (d) we've booted, - ** request commit. - */ - if ( (wit_u->evt_d <= god_u->dun_d) && - (wit_u->evt_d == (1 + log_u->moc_d)) && - (wit_u->evt_d == (1 + log_u->com_d)) ) - { - c3_d count = 1 + (god_u->dun_d - wit_u->evt_d); - struct u3_lmdb_write_request* request = - u3_lmdb_build_write_request(wit_u, count); - c3_assert(request != 0); - - _pier_db_commit_request(pir_u, - request, - wit_u->evt_d, - count); - act_o = c3y; - } - - /* if writ is (a) committed and (b) computed, - ** release effects and delete from queue - */ - if ( (wit_u->evt_d <= log_u->com_d) && - (wit_u->evt_d <= god_u->dun_d) ) - { - // effects must be released in order - // - c3_assert(wit_u == pir_u->ext_u); - - // remove from queue - // - // Must be done before releasing effects - // - _pier_writ_unlink(wit_u); - - // release effects - // - _pier_work_release(wit_u); - - // free writ - // - _pier_writ_dispose(wit_u); - - wit_u = pir_u->ext_u; - act_o = c3y; - } - else { - /* otherwise, continue backward - */ - wit_u = wit_u->nex_u; - } - } - - /* if we did anything to the queue, make another pass. - */ - if ( c3y == act_o ) { - act_o = c3n; - goto start; - } -} - -/* _pier_create(): create a pier, loading existing. -*/ -static u3_pier* -_pier_create(c3_w wag_w, c3_c* pax_c) -{ - // create pier - // - u3_pier* pir_u = c3_calloc(sizeof *pir_u); - - pir_u->pax_c = pax_c; - pir_u->wag_w = wag_w; - pir_u->sat_e = u3_psat_init; - - pir_u->sam_u = c3_calloc(sizeof(u3_ames)); - pir_u->teh_u = c3_calloc(sizeof(u3_behn)); - pir_u->unx_u = c3_calloc(sizeof(u3_unix)); - pir_u->sav_u = c3_calloc(sizeof(u3_save)); - - // initialize persistence - // - if ( c3n == _pier_disk_create(pir_u) ) { - return 0; - } - - // start the worker process - // - if ( !(pir_u->god_u = _pier_work_create(pir_u)) ) { - return 0; - } - - // install in the pier table - // - if ( 0 == u3K.all_w ) { - u3K.all_w = 16; - u3K.tab_u = c3_malloc(16 * sizeof(u3_pier*)); - } - if ( u3K.len_w == u3K.all_w ) { - u3K.all_w = 2 * u3K.all_w; - u3K.tab_u = c3_realloc(u3K.tab_u, u3K.all_w * sizeof(u3_pier*)); - } - u3K.tab_u[u3K.len_w++] = pir_u; - - return pir_u; -} - -/* u3_pier_interrupt(): interrupt running process. -*/ -void -u3_pier_interrupt(u3_pier* pir_u) -{ - uv_process_kill(&pir_u->god_u->cub_u, SIGINT); -} - -/* _pier_exit_done(): synchronously shutting down -*/ -static void -_pier_exit_done(u3_pier* pir_u) -{ - u3l_log("pier: exit\r\n"); - - _pier_db_shutdown(pir_u); - _pier_work_shutdown(pir_u); - _pier_loop_exit(pir_u); - - // XX uninstall pier from u3K.tab_u, dispose - - // XX no can do - // - uv_stop(u3L); -} - -/* u3_pier_exit(): trigger a gentle shutdown. -*/ -void -u3_pier_exit(u3_pier* pir_u) -{ - pir_u->sat_e = u3_psat_done; - - // XX must wait for callback confirming - // - u3_pier_snap(pir_u); -} - -/* u3_pier_snap(): request snapshot -*/ -void -u3_pier_snap(u3_pier* pir_u) -{ - u3_controller* god_u = pir_u->god_u; - u3_disk* log_u = pir_u->log_u; - u3_save* sav_u = pir_u->sav_u; - - c3_d top_d = c3_max(god_u->sen_d, god_u->dun_d); - - // no-op if there are no un-snapshot'ed events - // - if ( top_d > sav_u->dun_d ) { - sav_u->req_d = top_d; - - // save eagerly if all computed events are already committed - // - if ( (log_u->com_d >= top_d) && - (god_u->dun_d == top_d) ) { - _pier_work_save(pir_u); - } - } - // if we're gracefully shutting down, do so now - // - else if ( u3_psat_done == pir_u->sat_e ) { - _pier_exit_done(pir_u); - } -} - -/* u3_pier_discover(): insert task into process controller. -*/ -void -u3_pier_discover(u3_pier* pir_u, - c3_l msc_l, - u3_noun job) -{ - _pier_writ_insert(pir_u, msc_l, job); - _pier_loop_resume(pir_u); -} - -/* u3_pier_send(): modern send with target and path. -*/ -void -u3_pier_send(u3_pier* pir_u, u3_noun pax, u3_noun tag, u3_noun fav) -{ -} - -/* u3_pier_work(): send event; real pier pointer. -** -** XX: u3_pier_work() is for legacy events sent to a real pier. -*/ -void -u3_pier_work(u3_pier* pir_u, u3_noun pax, u3_noun fav) -{ - u3_noun now; - struct timeval tim_tv; - - gettimeofday(&tim_tv, 0); - now = u3_time_in_tv(&tim_tv); - - u3_pier_discover(pir_u, 0, u3nt(now, pax, fav)); -} - -/* u3_pier_plan(): send event; fake pier pointer -** -** XX: u3_pier_plan() is maximum legacy, do not use. -*/ -void -u3_pier_plan(u3_noun pax, u3_noun fav) -{ - u3_pier_work(u3_pier_stub(), pax, fav); -} - -/* c3_rand(): fill a 512-bit (16-word) buffer. -*/ -void -c3_rand(c3_w* rad_w) -{ - if ( 0 != ent_getentropy(rad_w, 64) ) { - u3l_log("c3_rand getentropy: %s\n", strerror(errno)); - // XX review - // - u3_pier_bail(); - } -} - -/* u3_pier_bail(): immediately shutdown. -*/ -void -u3_pier_bail(void) -{ - if ( 0 != u3K.len_w ) { - _pier_exit_done(u3_pier_stub()); - } - - fflush(stdout); - exit(1); -} - -/* _pier_tape(): dump a tape, old style. Don't do this. -*/ -static void -_pier_tape(FILE* fil_u, u3_noun tep) -{ - u3_noun tap = tep; - - while ( c3y == u3du(tap) ) { - c3_c car_c; - - if ( u3h(tap) >= 127 ) { - car_c = '?'; - } else car_c = u3h(tap); - - putc(car_c, fil_u); - tap = u3t(tap); - } - u3z(tep); -} - -/* _pier_wall(): dump a wall, old style. Don't do this. -*/ -static void -_pier_wall(u3_noun wol) -{ - FILE* fil_u = u3_term_io_hija(); - u3_noun wal = wol; - - // XX temporary, for urb.py test runner - // - if ( c3y == u3_Host.ops_u.dem ) { - fil_u = stderr; - } - - while ( u3_nul != wal ) { - _pier_tape(fil_u, u3k(u3h(wal))); - - putc(13, fil_u); - putc(10, fil_u); - - wal = u3t(wal); - } - u3_term_io_loja(0); - u3z(wol); -} - -/* u3_pier_tank(): dump single tank. -*/ -void -u3_pier_tank(c3_l tab_l, u3_noun tac) -{ - u3_pier_punt(tab_l, u3nc(tac, u3_nul)); -} - -/* u3_pier_punt(): dump tank list. -*/ -void -u3_pier_punt(c3_l tab_l, u3_noun tac) -{ - u3_noun blu = u3_term_get_blew(0); - c3_l col_l = u3h(blu); - u3_noun cat = tac; - - // We are calling nock here, but hopefully need no protection. - // - while ( c3y == u3r_du(cat) ) { - if ( 0 == u3A->roc ) { - u3_noun act = u3h(cat); - - if ( c3__leaf == u3h(act) ) { - FILE* fil_u = u3_term_io_hija(); - - // XX temporary, for urb.py test runner - // - if ( c3y == u3_Host.ops_u.dem ) { - fil_u = stderr; - } - - _pier_tape(fil_u, u3k(u3t(act))); - putc(13, fil_u); - putc(10, fil_u); - - u3_term_io_loja(0); - } - } - else { - u3_noun wol = u3dc("wash", u3nc(tab_l, col_l), u3k(u3h(cat))); - - _pier_wall(wol); - } - cat = u3t(cat); - } - u3z(tac); - u3z(blu); -} - -/* u3_pier_sway(): print trace. -*/ -void -u3_pier_sway(c3_l tab_l, u3_noun tax) -{ - u3_noun mok = u3dc("mook", 2, tax); - - u3_pier_punt(tab_l, u3k(u3t(mok))); - u3z(mok); -} - -/* u3_pier_stub(): get the One Pier for unreconstructed code. -*/ -u3_pier* -u3_pier_stub(void) -{ - if ( 0 == u3K.len_w ) { - c3_assert(!"plan: no pier"); - } - else { - return u3K.tab_u[0]; - } -} - -/* _pier_init(): initialize pier i/o handles -*/ -static void -_pier_init(u3_pier* pir_u) -{ - // initialize i/o handlers - // - _pier_loop_init(pir_u); - - // initialize pre i/o polling handle - // - uv_prepare_init(u3_Host.lup_u, &pir_u->pep_u); - pir_u->pep_u.data = pir_u; - uv_prepare_start(&pir_u->pep_u, _pier_loop_prepare); - - // initialize post i/o polling handle - // - uv_idle_init(u3_Host.lup_u, &pir_u->idl_u); - pir_u->idl_u.data = pir_u; - - _pier_loop_resume(pir_u); -} - -/* u3_pier_boot(): start the new pier system. -*/ -void -u3_pier_boot(c3_w wag_w, // config flags - u3_noun who, // identity - u3_noun ven, // boot event - u3_noun pil, // type-of/path-to pill - u3_noun pax) // path to pier -{ - // make/load pier - // - u3_pier* pir_u = _pier_create(wag_w, u3r_string(pax)); - - if ( 0 == pir_u ) { - u3l_log("pier: failed to create\r\n"); - u3_daemon_bail(); - exit(1); - } - - // set boot params - // - { - pir_u->bot_u = _pier_boot_create(pir_u, u3k(pil), u3k(ven)); - - _pier_boot_set_ship(pir_u, u3k(who), ( c3__fake == u3h(ven) ) ? c3y : c3n); - } - - _pier_init(pir_u); - - u3z(who); u3z(ven); u3z(pil); u3z(pax); -} - -/* u3_pier_stay(): resume the new pier system. -*/ -void -u3_pier_stay(c3_w wag_w, u3_noun pax) -{ - // make/load pier - // - u3_pier* pir_u = _pier_create(wag_w, u3r_string(pax)); - - if ( 0 == pir_u ) { - u3l_log("pier: failed to create\r\n"); - u3_daemon_bail(); - exit(1); - } - - _pier_init(pir_u); - - u3z(pax); -} - -/* u3_pier_mark(): mark all Loom allocations in all u3_pier structs. -*/ -c3_w -u3_pier_mark(FILE* fil_u) -{ - c3_w len_w = u3K.len_w; - c3_w tot_w = 0; - u3_pier* pir_u; - - while ( 0 < len_w ) { - pir_u = u3K.tab_u[--len_w]; - u3l_log("pier: %u\r\n", len_w); - - if ( 0 != pir_u->bot_u ) { - tot_w += u3a_maid(fil_u, " boot event", u3a_mark_noun(pir_u->bot_u->ven)); - tot_w += u3a_maid(fil_u, " pill", u3a_mark_noun(pir_u->bot_u->pil)); - } - - { - u3_writ* wit_u = pir_u->ent_u; - c3_w wit_w = 0; - - while ( 0 != wit_u ) { - wit_w += u3a_mark_noun(wit_u->job); - wit_w += u3a_mark_noun(wit_u->now); - wit_w += u3a_mark_noun(wit_u->mat); - wit_w += u3a_mark_noun(wit_u->act); - wit_u = wit_u->nex_u; - } - - tot_w += u3a_maid(fil_u, " writs", wit_w); - } - } - - return tot_w; -} diff --git a/pkg/hair/notes/c/reck.c b/pkg/hair/notes/c/reck.c deleted file mode 100644 index ba803e36c..000000000 --- a/pkg/hair/notes/c/reck.c +++ /dev/null @@ -1,482 +0,0 @@ -/* vere/reck.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -/* _reck_mole(): parse simple atomic mole. -*/ -static u3_noun -_reck_mole(u3_noun fot, - u3_noun san, - c3_d* ato_d) -{ - u3_noun uco = u3dc("slaw", fot, san); - u3_noun p_uco, q_uco; - - if ( (c3n == u3r_cell(uco, &p_uco, &q_uco)) || - (u3_nul != p_uco) ) - { - u3l_log("strange mole %s\n", u3r_string(san)); - - u3z(fot); u3z(uco); return c3n; - } - else { - *ato_d = u3r_chub(0, q_uco); - - u3z(fot); u3z(uco); return c3y; - } -} - -/* _reck_lily(): parse little atom. -*/ -static u3_noun -_reck_lily(u3_noun fot, u3_noun txt, c3_l* tid_l) -{ - c3_d ato_d; - - if ( c3n == _reck_mole(fot, txt, &ato_d) ) { - return c3n; - } else { - if ( ato_d >= 0x80000000ULL ) { - return c3n; - } else { - *tid_l = (c3_l) ato_d; - - return c3y; - } - } -} - -/* _reck_orchid(): parses only a number as text - * - * Parses a text string which contains a decimal number. In practice, this - * number is always '1'. - */ -static u3_noun -_reck_orchid(u3_noun fot, u3_noun txt, c3_l* tid_l) -{ - c3_c* str = u3r_string(txt); - c3_d ato_d = strtol(str, NULL, 10); - free(str); - - if ( ato_d >= 0x80000000ULL ) { - return c3n; - } else { - *tid_l = (c3_l) ato_d; - - return c3y; - } -} - -/* _reck_kick_term(): apply terminal outputs. -*/ -static u3_noun -_reck_kick_term(u3_pier* pir_u, u3_noun pox, c3_l tid_l, u3_noun fav) -{ - u3_noun p_fav; - - if ( c3n == u3du(fav) ) { - u3z(pox); u3z(fav); return c3n; - } - else switch ( u3h(fav) ) { - default: u3z(pox); u3z(fav); return c3n; - case c3__bbye: - { - u3z(pox); u3z(fav); return c3y; - } break; - - case c3__blit: p_fav = u3t(fav); - { - u3_term_ef_blit(tid_l, u3k(p_fav)); - - u3z(pox); u3z(fav); return c3y; - } break; - - // this can return through dill due to our fscked up boot sequence - // - case c3__send: { - u3_noun lan = u3k(u3h(u3t(fav))); - u3_noun pac = u3k(u3t(u3t(fav))); - - u3l_log("kick: strange send\r\n"); - u3_ames_ef_send(pir_u, lan, pac); - u3z(pox); u3z(fav); return c3y; - } break; - - case c3__logo: - { - u3_pier_exit(pir_u); - u3_Host.xit_i = u3t(fav); - - u3z(pox); u3z(fav); return c3y; - } break; - - case c3__init: p_fav = u3t(fav); - { - // daemon ignores %init - // u3A->own = u3nc(u3k(p_fav), u3A->own); - // u3l_log("kick: init: %d\n", p_fav); - u3z(pox); u3z(fav); return c3y; - } break; - - case c3__mass: p_fav = u3t(fav); - { - u3z(pox); u3z(fav); - - // gc the daemon area - // - uv_timer_start(&u3K.tim_u, (uv_timer_cb)u3_daemon_grab, 0, 0); - return c3y; - } break; - } - c3_assert(!"not reached"); return 0; -} - -/* _reck_kick_http(): apply http effects. -*/ -static u3_noun -_reck_kick_http(u3_pier* pir_u, - u3_noun pox, - c3_l sev_l, - c3_l coq_l, - c3_l seq_l, - u3_noun fav) -{ - u3_noun p_fav, q_fav; - - if ( c3n == u3du(fav) ) { - u3z(pox); u3z(fav); return c3n; - } - else switch ( u3h(fav) ) { - default: u3z(pox); u3z(fav); return c3n; - - case c3__form: p_fav = u3t(fav); - { - u3_http_ef_form(u3k(p_fav)); - - // The control server has now started. - // - // If we're in daemon mode, we need to inform the parent process - // that we've finished booting. - if (u3_Host.bot_f) { - u3_Host.bot_f(); - } - - u3z(pox); u3z(fav); - return c3y; - } - - case c3__that: p_fav = u3t(fav); - { - u3_http_ef_that(u3k(p_fav)); - - u3z(pox); u3z(fav); - return c3y; - } - - case c3__thus: p_fav = u3h(u3t(fav)); q_fav = u3t(u3t(fav)); - { - u3_cttp_ef_thus(u3r_word(0, p_fav), u3k(q_fav)); - - u3z(pox); u3z(fav); - return c3y; - } - case c3__thou: p_fav = u3t(fav); - { - u3_http_ef_thou(sev_l, coq_l, seq_l, u3k(p_fav)); - - u3z(pox); u3z(fav); - return c3y; - } break; - } - c3_assert(!"not reached"); return c3n; -} - -/* _reck_kick_behn(): apply packet network outputs. -*/ -static u3_noun -_reck_kick_behn(u3_pier* pir_u, u3_noun pox, u3_noun fav) -{ - switch ( u3h(fav) ) { - default: break; - - case c3__doze: { - u3_behn_ef_doze(pir_u, u3k(u3t(fav))); - u3z(pox); u3z(fav); return c3y; - } break; - } - u3z(pox); u3z(fav); return c3n; -} - -/* _reck_kick_sync(): apply sync outputs. -*/ -static u3_noun -_reck_kick_sync(u3_pier* pir_u, u3_noun pox, u3_noun fav) -{ - switch ( u3h(fav) ) { - default: break; - case c3__dirk: { - u3_unix_ef_dirk(pir_u, u3k(u3t(fav))); - u3z(pox); u3z(fav); return c3y; - } - case c3__ergo: { - u3_noun mon = u3k(u3h(u3t(fav))); - u3_noun can = u3k(u3t(u3t(fav))); - - u3_unix_ef_ergo(pir_u, mon, can); - u3z(pox); u3z(fav); return c3y; - } break; - case c3__ogre: { - u3_unix_ef_ogre(pir_u, u3k(u3t(fav))); - u3z(pox); u3z(fav); return c3y; - } - case c3__hill: { - u3_unix_ef_hill(pir_u, u3k(u3t(fav))); - u3z(pox); u3z(fav); return c3y; - } - } - - // XX obviously not right! - // ? looks fine to me - u3z(pox); u3z(fav); return c3n; -} - -/* _reck_kick_newt(): apply packet network outputs. -*/ -static u3_noun -_reck_kick_newt(u3_pier* pir_u, u3_noun pox, u3_noun fav) -{ - switch ( u3h(fav) ) { - default: break; - case c3__send: { - u3_noun lan = u3k(u3h(u3t(fav))); - u3_noun pac = u3k(u3t(u3t(fav))); - - u3_ames_ef_send(pir_u, lan, pac); - u3z(pox); u3z(fav); return c3y; - } break; - - case c3__turf: { - u3_ames_ef_turf(pir_u, u3k(u3t(fav))); - u3z(pox); u3z(fav); return c3y; - } break; - - } - u3z(pox); u3z(fav); return c3n; -} - -/* _reck_kick_ames(): apply packet network outputs. -*/ -static u3_noun -_reck_kick_ames(u3_pier* pir_u, u3_noun pox, u3_noun fav) -{ - u3_noun p_fav; - - switch ( u3h(fav) ) { - default: break; - case c3__init: p_fav = u3t(fav); - { - // daemon ignores %init - // u3A->own = u3nc(u3k(p_fav), u3A->own); - // u3l_log("kick: init: %d\n", p_fav); - u3z(pox); u3z(fav); return c3y; - } break; - } - u3z(pox); u3z(fav); return c3n; -} - -/* _reck_kick_spec(): apply an effect, by path. -*/ -static u3_noun -_reck_kick_spec(u3_pier* pir_u, u3_noun pox, u3_noun fav) -{ - u3_noun i_pox, t_pox; - - if ( (c3n == u3r_cell(pox, &i_pox, &t_pox)) || - ((i_pox != u3_blip) && - (i_pox != c3__gold) && - (i_pox != c3__iron) && - (i_pox != c3__lead)) ) - { - u3z(pox); u3z(fav); return c3n; - } else { - u3_noun it_pox, tt_pox; - - if ( (c3n == u3r_cell(t_pox, &it_pox, &tt_pox)) ) { - u3z(pox); u3z(fav); return c3n; - } - else switch ( it_pox ) { - default: u3z(pox); u3z(fav); return c3n; - - case c3__http: { - u3_noun pud = tt_pox; - u3_noun p_pud, t_pud, tt_pud, q_pud, r_pud, s_pud; - c3_l sev_l, coq_l, seq_l; - - if ( (c3n == u3r_cell(pud, &p_pud, &t_pud)) || - (c3n == _reck_lily(c3__uv, u3k(p_pud), &sev_l)) ) - { - u3z(pox); u3z(fav); return c3n; - } - - if ( u3_nul == t_pud ) { - coq_l = seq_l = 0; - } - else { - if ( (c3n == u3r_cell(t_pud, &q_pud, &tt_pud)) || - (c3n == _reck_lily(c3__ud, u3k(q_pud), &coq_l)) ) - { - u3z(pox); u3z(fav); return c3n; - } - - if ( u3_nul == tt_pud ) { - seq_l = 0; - } else { - if ( (c3n == u3r_cell(tt_pud, &r_pud, &s_pud)) || - (u3_nul != s_pud) || - (c3n == _reck_lily(c3__ud, u3k(r_pud), &seq_l)) ) - { - u3z(pox); u3z(fav); return c3n; - } - } - } - return _reck_kick_http(pir_u, pox, sev_l, coq_l, seq_l, fav); - } break; - - case c3__behn: { - return _reck_kick_behn(pir_u, pox, fav); - } break; - - case c3__clay: - case c3__boat: - case c3__sync: { - return _reck_kick_sync(pir_u, pox, fav); - } break; - - case c3__newt: { - return _reck_kick_newt(pir_u, pox, fav); - } break; - - case c3__ames: { - if ( (u3_nul != tt_pox) ) { - u3z(pox); u3z(fav); return c3n; - } - else { - return _reck_kick_ames(pir_u, pox, fav); - } - } break; - - case c3__init: { - // daemon ignores %init - // p_fav = u3t(fav); - // u3A->own = u3nc(u3k(p_fav), u3A->own); - // u3l_log("kick: init: %d\n", p_fav); - u3z(pox); u3z(fav); return c3y; - } break; - - case c3__term: { - u3_noun pud = tt_pox; - u3_noun p_pud, q_pud; - c3_l tid_l; - - if ( (c3n == u3r_cell(pud, &p_pud, &q_pud)) || - (u3_nul != q_pud) || - (c3n == _reck_orchid(c3__ud, u3k(p_pud), &tid_l)) ) - { - u3l_log("term: bad tire\n"); - u3z(pox); u3z(fav); return c3n; - } else { - return _reck_kick_term(pir_u, pox, tid_l, fav); - } - } break; - } - } - c3_assert(!"not reached"); - return c3n; -} - -/* _reck_kick_norm(): non path-specific effect handling. -*/ -static u3_noun -_reck_kick_norm(u3_pier* pir_u, u3_noun pox, u3_noun fav) -{ - if ( c3n == u3du(fav) ) { - u3z(pox); u3z(fav); return c3n; - } - else switch ( u3h(fav) ) { - default: u3z(pox); u3z(fav); return c3n; - - case c3__vega: - { - u3l_log("<<>>\n"); - u3z(pox); u3z(fav); - - // reclaim memory from persistent caches - // - u3m_reclaim(); - - return c3y; - } - case c3__exit: - { - u3l_log("<<>>\n"); - u3_pier_exit(pir_u); - - u3z(pox); u3z(fav); return c3y; - } break; - } - c3_assert(!"not reached"); return c3n; - u3z(pox); u3z(fav); return c3n; -} - -/* u3_reck_kick(): handle effect. -*/ -void -u3_reck_kick(u3_pier* pir_u, u3_noun ovo) -{ - if ( (c3n == _reck_kick_spec(pir_u, u3k(u3h(ovo)), u3k(u3t(ovo)))) && - (c3n == _reck_kick_norm(pir_u, u3k(u3h(ovo)), u3k(u3t(ovo)))) ) - { -#if 0 - if ( (c3__warn != u3h(u3t(ovo))) && - (c3__text != u3h(u3t(ovo))) && - (c3__note != u3h(u3t(ovo))) ) -#endif -#if 1 - if ( (c3__crud == u3h(u3t(ovo))) ) -#if 0 - (c3__talk == u3h(u3t(ovo))) || - (c3__helo == u3h(u3t(ovo))) || - (c3__init == u3h(u3t(ovo))) ) -#endif - { - u3_pier_work(pir_u, - u3nt(u3_blip, c3__term, u3_nul), - u3nc(c3__flog, u3k(u3t(ovo)))); - } - else { - u3_noun tox = u3do("spat", u3k(u3h(ovo))); - u3l_log("kick: lost %%%s on %s\n", - u3r_string(u3h(u3t(ovo))), - u3r_string(tox)); - u3z(tox); -#if 0 - if ( c3__hear == u3h(u3t(ovo)) ) { - c3_assert(0); - } -#endif - } -#endif - } - u3z(ovo); -} diff --git a/pkg/hair/notes/c/save.c b/pkg/hair/notes/c/save.c deleted file mode 100644 index 1c62e8442..000000000 --- a/pkg/hair/notes/c/save.c +++ /dev/null @@ -1,66 +0,0 @@ -/* vere/save.c -** -*/ -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -/* _save_time_cb(): timer callback. -*/ -static void -_save_time_cb(uv_timer_t* tim_u) -{ - u3_pier *pir_u = tim_u->data; - u3_pier_snap(pir_u); -} - -/* u3_save_ef_chld(): report save termination. -*/ -void -u3_save_ef_chld(u3_pier *pir_u) -{ - u3_save* sav_u = pir_u->sav_u; - c3_i loc_i; - c3_w pid_w; - - /* modified for cases with no pid_w - */ - u3l_log("checkpoint: complete %d\n", sav_u->pid_w); - pid_w = wait(&loc_i); - if (0 != sav_u->pid_w) { - c3_assert(pid_w == sav_u->pid_w); - } - else { - c3_assert(pid_w > 0); - } - sav_u->pid_w = 0; -} - -/* u3_save_io_init(): initialize autosave. -*/ -void -u3_save_io_init(u3_pier *pir_u) -{ - u3_save* sav_u = pir_u->sav_u; - - sav_u->req_d = 0; - sav_u->dun_d = 0; - sav_u->pid_w = 0; - - sav_u->tim_u.data = pir_u; - uv_timer_init(u3L, &sav_u->tim_u); - uv_timer_start(&sav_u->tim_u, _save_time_cb, 120000, 120000); -} - -/* u3_save_io_exit(): terminate save I/O. -*/ -void -u3_save_io_exit(u3_pier *pir_u) -{ -} diff --git a/pkg/hair/notes/c/term.c b/pkg/hair/notes/c/term.c deleted file mode 100644 index 868a33c53..000000000 --- a/pkg/hair/notes/c/term.c +++ /dev/null @@ -1,1342 +0,0 @@ -/* vere/term.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -static void _term_spinner_cb(void*); -static void _term_read_cb(uv_stream_t* tcp_u, - ssize_t siz_i, - const uv_buf_t * buf_u); -static inline void _term_suck(u3_utty*, const c3_y*, ssize_t); -static u3_utty* _term_main(); - -#define _SPIN_COOL_US 500000 // spinner activation delay when cool -#define _SPIN_WARM_US 50000 // spinner activation delay when warm -#define _SPIN_RATE_US 250000 // spinner rate (microseconds/frame) -#define _SPIN_IDLE_US 500000 // spinner cools down if stopped this long - -static void _write(int fd, const void *buf, size_t count) -{ - if (count != write(fd, buf, count)){ - u3l_log("write failed\r\n"); - c3_assert(0); - } -} - - -/* _term_msc_out_host(): unix microseconds from current host time. -*/ -static c3_d -_term_msc_out_host() -{ - struct timeval tim_tv; - gettimeofday(&tim_tv, 0); - return 1000000ULL * tim_tv.tv_sec + tim_tv.tv_usec; -} - -/* _term_alloc(): libuv buffer allocator. -*/ -static void -_term_alloc(uv_handle_t* had_u, - size_t len_i, - uv_buf_t* buf - ) -{ - // this read can range from a single byte to a paste buffer - // 123 bytes has been chosen because its not a power of 2 - // this is probably still broken - // - void* ptr_v = c3_malloc(123); - *buf = uv_buf_init(ptr_v, 123); -} - - -// XX unused, but %hook is in %zuse. -// implement or remove -// -#if 0 -/* _term_close_cb(): free terminal. -*/ -static void -_term_close_cb(uv_handle_t* han_t) -{ - u3_utty* tty_u = (void*) han_t; - if ( u3_Host.uty_u == tty_u ) { - u3_Host.uty_u = tty_u->nex_u; - } - else { - u3_utty* uty_u; - for (uty_u = u3_Host.uty_u; uty_u; uty_u = uty_u->nex_u ) { - if ( uty_u->nex_u == tty_u ) { - uty_u->nex_u = tty_u->nex_u; - break; - } - } - } - - { - u3_noun tid = u3dc("scot", c3__ud, tty_u->tid_l); - u3_noun pax = u3nq(u3_blip, c3__term, tid, u3_nul); - u3_pier_plan(u3k(pax), u3nc(c3__hook, u3_nul)); - u3z(pax); - } - free(tty_u); -} -#endif - -/* u3_term_io_init(): initialize terminal. -*/ -void -u3_term_io_init() -{ - u3_utty* uty_u = c3_calloc(sizeof(u3_utty)); - - if ( c3y == u3_Host.ops_u.dem ) { - uty_u->fid_i = 1; - - uv_pipe_init(u3L, &(uty_u->pop_u), 0); - uv_pipe_open(&(uty_u->pop_u), uty_u->fid_i); - } - else { - // Initialize event processing. Rawdog it. - // - { - uty_u->fid_i = 0; // stdin, yes we write to it... - - uv_pipe_init(u3L, &(uty_u->pop_u), 0); - uv_pipe_open(&(uty_u->pop_u), uty_u->fid_i); - uv_read_start((uv_stream_t*)&(uty_u->pop_u), _term_alloc, _term_read_cb); - } - - // Configure horrible stateful terminfo api. - // - { - if ( 0 != setupterm(0, 2, 0) ) { - c3_assert(!"init-setupterm"); - } - } - - // Load terminfo strings. - // - { - c3_w len_w; - -# define _utfo(way, nam) \ - { \ - uty_u->ufo_u.way.nam##_y = (const c3_y *) tigetstr(#nam); \ - c3_assert(uty_u->ufo_u.way.nam##_y); \ - } - - uty_u->ufo_u.inn.max_w = 0; - - _utfo(inn, kcuu1); - _utfo(inn, kcud1); - _utfo(inn, kcub1); - _utfo(inn, kcuf1); - - _utfo(out, clear); - _utfo(out, el); - // _utfo(out, el1); - _utfo(out, ed); - _utfo(out, bel); - _utfo(out, cub1); - _utfo(out, cuf1); - _utfo(out, cuu1); - _utfo(out, cud1); - // _utfo(out, cub); - // _utfo(out, cuf); - - // Terminfo chronically reports the wrong sequence for arrow - // keys on xterms. Drastic fix for ridiculous unacceptable bug. - // Yes, we could fix this with smkx/rmkx, but this is retarded as well. - { - uty_u->ufo_u.inn.kcuu1_y = (const c3_y*)"\033[A"; - uty_u->ufo_u.inn.kcud1_y = (const c3_y*)"\033[B"; - uty_u->ufo_u.inn.kcuf1_y = (const c3_y*)"\033[C"; - uty_u->ufo_u.inn.kcub1_y = (const c3_y*)"\033[D"; - } - - uty_u->ufo_u.inn.max_w = 0; - if ( (len_w = strlen((c3_c*)uty_u->ufo_u.inn.kcuu1_y)) > - uty_u->ufo_u.inn.max_w ) - { - uty_u->ufo_u.inn.max_w = len_w; - } - if ( (len_w = strlen((c3_c*)uty_u->ufo_u.inn.kcud1_y)) > - uty_u->ufo_u.inn.max_w ) - { - uty_u->ufo_u.inn.max_w = len_w; - } - if ( (len_w = strlen((c3_c*)uty_u->ufo_u.inn.kcub1_y)) > - uty_u->ufo_u.inn.max_w ) - { - uty_u->ufo_u.inn.max_w = len_w; - } - if ( (len_w = strlen((c3_c*)uty_u->ufo_u.inn.kcuf1_y)) > - uty_u->ufo_u.inn.max_w ) - { - uty_u->ufo_u.inn.max_w = len_w; - } - } - - // Load old terminal state to restore. - // - { - if ( 0 != tcgetattr(uty_u->fid_i, &uty_u->bak_u) ) { - c3_assert(!"init-tcgetattr"); - } - if ( -1 == fcntl(uty_u->fid_i, F_GETFL, &uty_u->cug_i) ) { - c3_assert(!"init-fcntl"); - } - uty_u->cug_i &= ~O_NONBLOCK; // could fix? - uty_u->nob_i = uty_u->cug_i | O_NONBLOCK; // O_NDELAY on older unix - } - - // Construct raw termios configuration. - // - { - uty_u->raw_u = uty_u->bak_u; - - uty_u->raw_u.c_lflag &= ~(ECHO | ECHONL | ICANON | IEXTEN); - uty_u->raw_u.c_iflag &= ~(ICRNL | INPCK | ISTRIP); - uty_u->raw_u.c_cflag &= ~(CSIZE | PARENB); - uty_u->raw_u.c_cflag |= CS8; - uty_u->raw_u.c_oflag &= ~(OPOST); - uty_u->raw_u.c_cc[VMIN] = 0; - uty_u->raw_u.c_cc[VTIME] = 0; - } - - // Initialize mirror and accumulator state. - // - { - uty_u->tat_u.mir.lin_w = 0; - uty_u->tat_u.mir.len_w = 0; - uty_u->tat_u.mir.cus_w = 0; - - uty_u->tat_u.esc.ape = c3n; - uty_u->tat_u.esc.bra = c3n; - - uty_u->tat_u.fut.len_w = 0; - uty_u->tat_u.fut.wid_w = 0; - } - } - - // This is terminal 1, linked in host. - // - { - uty_u->tid_l = 1; - uty_u->nex_u = 0; - u3_Host.uty_u = uty_u; - } - - if ( c3n == u3_Host.ops_u.dem ) { - // Start raw input. - // - { - if ( 0 != tcsetattr(uty_u->fid_i, TCSADRAIN, &uty_u->raw_u) ) { - c3_assert(!"init-tcsetattr"); - } - if ( -1 == fcntl(uty_u->fid_i, F_SETFL, uty_u->nob_i) ) { - c3_assert(!"init-fcntl"); - } - } - - // Start spinner thread. - // - { - uty_u->tat_u.sun.sit_u = (uv_thread_t*)malloc(sizeof(uv_thread_t)); - if ( uty_u->tat_u.sun.sit_u ) { - uv_mutex_init(&uty_u->tat_u.mex_u); - uv_mutex_lock(&uty_u->tat_u.mex_u); - - c3_w ret_w = uv_thread_create(uty_u->tat_u.sun.sit_u, - _term_spinner_cb, - uty_u); - if ( 0 != ret_w ) { - u3l_log("term: spinner start: %s\n", uv_strerror(ret_w)); - free(uty_u->tat_u.sun.sit_u); - uty_u->tat_u.sun.sit_u = NULL; - uv_mutex_unlock(&uty_u->tat_u.mex_u); - uv_mutex_destroy(&uty_u->tat_u.mex_u); - } - } - } - } -} - -void -u3_term_io_talk(void) -{ -} - -/* u3_term_io_exit(): clean up terminal. -*/ -void -u3_term_io_exit(void) -{ - if ( c3y == u3_Host.ops_u.dem ) { - uv_close((uv_handle_t*)&u3_Host.uty_u->pop_u, NULL); - } - else { - u3_utty* uty_u; - - for ( uty_u = u3_Host.uty_u; uty_u; uty_u = uty_u->nex_u ) { - if ( uty_u->fid_i == -1 ) { continue; } - if ( 0 != tcsetattr(uty_u->fid_i, TCSADRAIN, &uty_u->bak_u) ) { - c3_assert(!"exit-tcsetattr"); - } - if ( -1 == fcntl(uty_u->fid_i, F_SETFL, uty_u->cug_i) ) { - c3_assert(!"exit-fcntl"); - } - _write(uty_u->fid_i, "\r\n", 2); - -#if 0 - if ( uty_u->tat_u.sun.sit_u ) { - uv_thread_t* sit_u = uty_u->tat_u.sun.sit_u; - uty_u->tat_u.sun.sit_u = NULL; - - uv_mutex_unlock(&uty_u->tat_u.mex_u); - - // XX can block exit waiting for wakeup (max _SPIN_COOL_US) - c3_w ret_w; - if ( 0 != (ret_w = uv_thread_join(sit_u)) ) { - u3l_log("term: spinner exit: %s\n", uv_strerror(ret_w)); - } - else { - uv_mutex_destroy(&uty_u->tat_u.mex_u); - } - - free(sit_u); - } -#endif - } - } -} - -/* _term_it_buf(): create a data buffer. -*/ -static u3_ubuf* -_term_it_buf(c3_w len_w, const c3_y* hun_y) -{ - u3_ubuf* buf_u = c3_malloc(len_w + sizeof(*buf_u)); - - buf_u->len_w = len_w; - memcpy(buf_u->hun_y, hun_y, len_w); - - buf_u->nex_u = 0; - return buf_u; -} - -/* An unusual lameness in libuv. -*/ - typedef struct { - uv_write_t wri_u; - c3_y* buf_y; - } _u3_write_t; - -/* _term_write_cb(): general write callback. -*/ -static void -_term_write_cb(uv_write_t* wri_u, c3_i sas_i) -{ - _u3_write_t* ruq_u = (void *)wri_u; - - if ( 0 != sas_i ) { - // u3l_log("term: write: ERROR\n"); - } - free(ruq_u->buf_y); - free(ruq_u); -} - -/* _term_it_write_buf(): write buffer uv style. -*/ -static void -_term_it_write_buf(u3_utty* uty_u, uv_buf_t buf_u) -{ - _u3_write_t* ruq_u = (_u3_write_t*) c3_malloc(sizeof(_u3_write_t)); - - ruq_u->buf_y = (c3_y*)buf_u.base; - - c3_w ret_w; - if ( 0 != (ret_w = uv_write(&ruq_u->wri_u, - (uv_stream_t*)&(uty_u->pop_u), - &buf_u, 1, - _term_write_cb)) ) - { - u3l_log("terminal: %s\n", uv_strerror(ret_w)); - } -} - -/* _term_it_write_old(): write buffer, transferring pointer. -*/ -static void -_term_it_write_old(u3_utty* uty_u, - u3_ubuf* old_u) -{ - uv_buf_t buf_u; - - // XX extra copy here due to old code. Use hbod as base directly. - // - { - c3_y* buf_y = c3_malloc(old_u->len_w); - - memcpy(buf_y, old_u->hun_y, old_u->len_w); - buf_u = uv_buf_init((c3_c*)buf_y, old_u->len_w); - - free(old_u); - } - _term_it_write_buf(uty_u, buf_u); -} - -/* _term_it_write_bytes(): write bytes, retaining pointer. -*/ -static void -_term_it_write_bytes(u3_utty* uty_u, - c3_w len_w, - const c3_y* hun_y) -{ - _term_it_write_old(uty_u, _term_it_buf(len_w, hun_y)); -} - -/* _term_it_write_txt(): write null-terminated string, retaining pointer. -*/ -static void -_term_it_write_txt(u3_utty* uty_u, - const c3_y* hun_y) -{ - _term_it_write_bytes(uty_u, strlen((const c3_c*)hun_y), hun_y); -} - -/* _term_it_write_str(): write null-terminated string, retaining pointer. -*/ -static void -_term_it_write_str(u3_utty* uty_u, - const c3_c* str_c) -{ - _term_it_write_txt(uty_u, (const c3_y*) str_c); -} - -/* _term_it_show_wide(): show wide text, retaining. -*/ -static void -_term_it_show_wide(u3_utty* uty_u, c3_w len_w, c3_w* txt_w) -{ - u3_noun wad = u3i_words(len_w, txt_w); - u3_noun txt = u3do("tuft", wad); - c3_c* txt_c = u3r_string(txt); - - _term_it_write_str(uty_u, txt_c); - free(txt_c); - u3z(txt); - - uty_u->tat_u.mir.cus_w += len_w; -} - -/* _term_it_show_clear(): clear to the beginning of the current line. -*/ -static void -_term_it_show_clear(u3_utty* uty_u) -{ - if ( uty_u->tat_u.siz.col_l ) { - _term_it_write_str(uty_u, "\r"); - _term_it_write_txt(uty_u, uty_u->ufo_u.out.el_y); - - uty_u->tat_u.mir.len_w = 0; - uty_u->tat_u.mir.cus_w = 0; - } -} - -/* _term_it_show_blank(): blank the screen. -*/ -static void -_term_it_show_blank(u3_utty* uty_u) -{ - _term_it_write_txt(uty_u, uty_u->ufo_u.out.clear_y); -} - -/* _term_it_show_cursor(): set current line, transferring pointer. -*/ -static void -_term_it_show_cursor(u3_utty* uty_u, c3_w cur_w) -{ - if ( cur_w < uty_u->tat_u.mir.cus_w ) { - c3_w dif_w = (uty_u->tat_u.mir.cus_w - cur_w); - - while ( dif_w-- ) { - _term_it_write_txt(uty_u, uty_u->ufo_u.out.cub1_y); - } - } - else if ( cur_w > uty_u->tat_u.mir.cus_w ) { - c3_w dif_w = (cur_w - uty_u->tat_u.mir.cus_w); - - while ( dif_w-- ) { - _term_it_write_txt(uty_u, uty_u->ufo_u.out.cuf1_y); - } - } - uty_u->tat_u.mir.cus_w = cur_w; -} - -/* _term_it_show_line(): set current line -*/ -static void -_term_it_show_line(u3_utty* uty_u, c3_w* lin_w, c3_w len_w) -{ - _term_it_show_wide(uty_u, len_w, lin_w); - - if ( lin_w != uty_u->tat_u.mir.lin_w ) { - if ( uty_u->tat_u.mir.lin_w ) { - free(uty_u->tat_u.mir.lin_w); - } - uty_u->tat_u.mir.lin_w = lin_w; - } - uty_u->tat_u.mir.len_w = len_w; -} - -/* _term_it_refresh_line(): refresh current line. -*/ -static void -_term_it_refresh_line(u3_utty* uty_u) -{ - c3_w len_w = uty_u->tat_u.mir.len_w; - c3_w cus_w = uty_u->tat_u.mir.cus_w; - - _term_it_show_clear(uty_u); - _term_it_show_line(uty_u, uty_u->tat_u.mir.lin_w, len_w); - _term_it_show_cursor(uty_u, cus_w); -} - -/* _term_it_show_more(): new current line. -*/ -static void -_term_it_show_more(u3_utty* uty_u) -{ - if ( c3y == u3_Host.ops_u.dem ) { - _term_it_write_str(uty_u, "\n"); - } else { - _term_it_write_str(uty_u, "\r\n"); - } - uty_u->tat_u.mir.cus_w = 0; -} - -/* _term_it_path(): path for console file. -*/ -static c3_c* -_term_it_path(c3_o fyl, u3_noun pax) -{ - c3_w len_w; - c3_c *pas_c; - - // measure - // - len_w = strlen(u3_Host.dir_c); - { - u3_noun wiz = pax; - - while ( u3_nul != wiz ) { - len_w += (1 + u3r_met(3, u3h(wiz))); - wiz = u3t(wiz); - } - } - - // cut - // - pas_c = c3_malloc(len_w + 1); - strncpy(pas_c, u3_Host.dir_c, len_w); - pas_c[len_w] = '\0'; - { - u3_noun wiz = pax; - c3_c* waq_c = (pas_c + strlen(pas_c)); - - while ( u3_nul != wiz ) { - c3_w tis_w = u3r_met(3, u3h(wiz)); - - if ( (c3y == fyl) && (u3_nul == u3t(wiz)) ) { - *waq_c++ = '.'; - } else *waq_c++ = '/'; - - u3r_bytes(0, tis_w, (c3_y*)waq_c, u3h(wiz)); - waq_c += tis_w; - - wiz = u3t(wiz); - } - *waq_c = 0; - } - u3z(pax); - return pas_c; -} - -/* _term_it_save(): save file by path. -*/ -static void -_term_it_save(u3_noun pax, u3_noun pad) -{ - c3_c* pax_c; - c3_c* bas_c = 0; - c3_w xap_w = u3kb_lent(u3k(pax)); - u3_noun xap = u3_nul; - u3_noun urb = c3_s4('.','u','r','b'); - u3_noun put = c3_s3('p','u','t'); - - // directory base and relative path - if ( 2 < xap_w ) { - u3_noun bas = u3nt(urb, put, u3_nul); - bas_c = _term_it_path(c3n, bas); - xap = u3qb_scag(xap_w - 2, pax); - } - - pax = u3nt(urb, put, pax); - pax_c = _term_it_path(c3y, pax); - - u3_walk_save(pax_c, 0, pad, bas_c, xap); - - free(pax_c); - free(bas_c); -} - -/* _term_io_belt(): send belt. -*/ -static void -_term_io_belt(u3_utty* uty_u, u3_noun blb) -{ - u3_noun tid = u3dc("scot", c3__ud, uty_u->tid_l); - u3_noun pax = u3nq(u3_blip, c3__term, tid, u3_nul); - - u3_pier_plan(pax, u3nc(c3__belt, blb)); -} - -/* _term_io_suck_char(): process a single character. -*/ -static void -_term_io_suck_char(u3_utty* uty_u, c3_y cay_y) -{ - u3_utat* tat_u = &uty_u->tat_u; - - if ( c3y == tat_u->esc.ape ) { - if ( c3y == tat_u->esc.bra ) { - switch ( cay_y ) { - default: { - _term_it_write_txt(uty_u, uty_u->ufo_u.out.bel_y); - break; - } - case 'A': _term_io_belt(uty_u, u3nc(c3__aro, 'u')); break; - case 'B': _term_io_belt(uty_u, u3nc(c3__aro, 'd')); break; - case 'C': _term_io_belt(uty_u, u3nc(c3__aro, 'r')); break; - case 'D': _term_io_belt(uty_u, u3nc(c3__aro, 'l')); break; - } - tat_u->esc.ape = tat_u->esc.bra = c3n; - } - else { - if ( (cay_y >= 'a') && (cay_y <= 'z') ) { - tat_u->esc.ape = c3n; - _term_io_belt(uty_u, u3nc(c3__met, cay_y)); - } - else if ( '.' == cay_y ) { - tat_u->esc.ape = c3n; - _term_io_belt(uty_u, u3nc(c3__met, c3__dot)); - } - else if ( 8 == cay_y || 127 == cay_y ) { - tat_u->esc.ape = c3n; - _term_io_belt(uty_u, u3nc(c3__met, c3__bac)); - } - else if ( ('[' == cay_y) || ('O' == cay_y) ) { - tat_u->esc.bra = c3y; - } - else { - tat_u->esc.ape = c3n; - - _term_it_write_txt(uty_u, uty_u->ufo_u.out.bel_y); - } - } - } - else if ( 0 != tat_u->fut.wid_w ) { - tat_u->fut.syb_y[tat_u->fut.len_w++] = cay_y; - - if ( tat_u->fut.len_w == tat_u->fut.wid_w ) { - u3_noun huv = u3i_bytes(tat_u->fut.wid_w, tat_u->fut.syb_y); - u3_noun wug; - - // u3l_log("muck-utf8 len %d\n", tat_u->fut.len_w); - // u3l_log("muck-utf8 %x\n", huv); - wug = u3do("taft", huv); - // u3l_log("muck-utf32 %x\n", tat_u->fut.len_w); - - tat_u->fut.len_w = tat_u->fut.wid_w = 0; - _term_io_belt(uty_u, u3nt(c3__txt, wug, u3_nul)); - } - } - else { - if ( (cay_y >= 32) && (cay_y < 127) ) { - _term_io_belt(uty_u, u3nt(c3__txt, cay_y, u3_nul)); - } - else if ( 0 == cay_y ) { - _term_it_write_txt(uty_u, uty_u->ufo_u.out.bel_y); - } - else if ( 8 == cay_y || 127 == cay_y ) { - _term_io_belt(uty_u, u3nc(c3__bac, u3_nul)); - } - else if ( 13 == cay_y ) { - _term_io_belt(uty_u, u3nc(c3__ret, u3_nul)); - } -#if 0 - else if ( 6 == cay_y ) { - _term_io_flow(uty_u); // XX hack - } -#endif - else if ( cay_y <= 26 ) { - _term_io_belt(uty_u, u3nc(c3__ctl, ('a' + (cay_y - 1)))); - } - else if ( 27 == cay_y ) { - tat_u->esc.ape = c3y; - } - else if ( cay_y >= 128 ) { - tat_u->fut.len_w = 1; - tat_u->fut.syb_y[0] = cay_y; - - if ( cay_y < 224 ) { - tat_u->fut.wid_w = 2; - } else if ( cay_y < 240 ) { - tat_u->fut.wid_w = 3; - } else tat_u->fut.wid_w = 4; - } - } -} - -/* _term_suck(): process a chunk of input -*/ - -/* - * `nread` (siz_w) is > 0 if there is data available, 0 if libuv is done reading for - * now, or < 0 on error. - * - * The callee is responsible for closing the stream when an error happens - * by calling uv_close(). Trying to read from the stream again is undefined. - * - * The callee is responsible for freeing the buffer, libuv does not reuse it. - * The buffer may be a null buffer (where buf->base=NULL and buf->len=0) on - * error. - */ - -static inline void -_term_suck(u3_utty* uty_u, const c3_y* buf, ssize_t siz_i) -{ - { - if ( siz_i == UV_EOF ) { - // We hear EOF (on the third read callback) if - // 2x the _term_alloc() buffer size is pasted. - // The process hangs if we do nothing (and ctrl-z - // then corrupts the event log), so we force shutdown. - // - u3l_log("term: hangup (EOF)\r\n"); - u3_pier_exit(u3_pier_stub()); - } - else if ( siz_i < 0 ) { - u3l_log("term %d: read: %s\n", uty_u->tid_l, uv_strerror(siz_i)); - } - else { - c3_i i; - - for ( i=0; i < siz_i; i++ ) { - _term_io_suck_char(uty_u, buf[i]); - } - } - } -} - -/* _term_read_cb(): server read callback. -*/ -static void -_term_read_cb(uv_stream_t* tcp_u, - ssize_t siz_i, - const uv_buf_t * buf_u) -{ - u3_utty* uty_u = (u3_utty*)(void*)tcp_u; - _term_suck(uty_u, (const c3_y*)buf_u->base, siz_i); - free(buf_u->base); -} - -/* _term_try_write_str(): write null-terminated string (off-thread, retain). -*/ -static void -_term_try_write_str(u3_utty* uty_u, - const c3_c* hun_y) -{ - // c3_i fid_i = uv_fileno(&uty_u->pop_u); - c3_i fid_i = uty_u->pop_u.io_watcher.fd; // XX old libuv - _write(fid_i, hun_y, strlen(hun_y)); -} - -/* _term_try_move_left(): move the cursor left (off-thread). -*/ -static void -_term_try_move_left(u3_utty* uty_u) -{ - _term_try_write_str(uty_u, (const c3_c*)uty_u->ufo_u.out.cub1_y); -} - -/* _term_show_spinner(): render spinner (off-thread). -*/ -static void -_term_show_spinner(u3_utty* uty_u, c3_d lag_d) -{ - if ( 0 == uty_u->tat_u.sun.eve_d ) { - return; - } - - c3_w cus_w = uty_u->tat_u.mir.cus_w; - - if ( cus_w >= uty_u->tat_u.siz.col_l ) { // shenanigans! - return; - } - - c3_w bac_w = uty_u->tat_u.siz.col_l - 1 - cus_w; // backoff from end of line - - const c3_c daz_c[] = "|/-\\"; - const c3_c dal_c[] = "\xc2\xab"; - const c3_c dar_c[] = "\xc2\xbb"; - - c3_c buf_c[1 + 2 + 4 + 2 + 1]; - // | + « + why + » + \0 - - c3_c* cur_c = buf_c; - - *cur_c++ = daz_c[(lag_d / _SPIN_RATE_US) % strlen(daz_c)]; - c3_w sol_w = 1; // spinner length (utf-32) - - c3_c* why_c = uty_u->tat_u.sun.why_c; - if ( why_c && strlen(why_c) <= 4 ) { - strcpy(cur_c, dal_c); - cur_c += strlen(dal_c); - sol_w += 1; // length of dal_c (utf-32) - - c3_w wel_w = strlen(why_c); - strcpy(cur_c, why_c); - cur_c += wel_w; - sol_w += wel_w; - - strcpy(cur_c, dar_c); - cur_c += strlen(dar_c); - sol_w += 1; // length of dar_c (utf-32) - } - *cur_c = '\0'; - - // One-time cursor backoff. - if ( c3n == uty_u->tat_u.sun.diz_o ) { - c3_w i_w; - for ( i_w = bac_w; i_w < sol_w; i_w++ ) { - _term_try_move_left(uty_u); - } - } - - _term_try_write_str(uty_u, buf_c); - uty_u->tat_u.sun.diz_o = c3y; - - // Cursor stays on spinner. - while ( sol_w-- ) { - _term_try_move_left(uty_u); - } -} - -/* _term_start_spinner(): prepare spinner state. RETAIN. -*/ -static void -_term_start_spinner(u3_utty* uty_u, u3_noun ovo) -{ - uty_u->tat_u.sun.diz_o = c3n; - - c3_d now_d = _term_msc_out_host(); - - // If we receive an event shortly after a previous spin, use a shorter delay - // to avoid giving the impression of a half-idle system. - // - c3_d lag_d; - if ( now_d - uty_u->tat_u.sun.end_d < _SPIN_IDLE_US ) { - lag_d = _SPIN_WARM_US; - } - else { - lag_d = _SPIN_COOL_US; - } - - // second item of the event wire - // - u3_noun why = u3h(u3t(u3h(u3t(ovo)))); - if ( c3__term == why ) { - u3_noun eve = u3t(u3t(ovo)); - if ( c3__belt == u3h(eve) && c3__ret == u3h(u3t(eve)) ) { - lag_d = 0; // No delay for %ret. - } - } - else { - uty_u->tat_u.sun.why_c = (c3_c*)u3r_string(why); - } - - uty_u->tat_u.sun.eve_d = now_d + lag_d; - - uv_mutex_unlock(&uty_u->tat_u.mex_u); -} - -/* u3_term_stop_spinner(): reset spinner state and restore input line. -*/ -static void -_term_stop_spinner(u3_utty* uty_u) -{ - uv_mutex_lock(&uty_u->tat_u.mex_u); - - if ( c3y == uty_u->tat_u.sun.diz_o ) { - _term_it_refresh_line(uty_u); - uty_u->tat_u.sun.end_d = _term_msc_out_host(); - } - else { - uty_u->tat_u.sun.end_d = 0; - } - - uty_u->tat_u.sun.diz_o = c3n; - uty_u->tat_u.sun.eve_d = 0; - free(uty_u->tat_u.sun.why_c); - uty_u->tat_u.sun.why_c = NULL; -} - -/* u3_term_start_spinner(): prepare spinner state. RETAIN. -*/ -void -u3_term_start_spinner(u3_noun ovo) -{ - if ( c3n == u3_Host.ops_u.dem ) { - _term_start_spinner(_term_main(), ovo); - } -} - -/* u3_term_stop_spinner(): reset spinner state and restore input line. -*/ -void -u3_term_stop_spinner(void) -{ - if ( c3n == u3_Host.ops_u.dem ) { - _term_stop_spinner(_term_main()); - } -} - -/* _term_spinner_cb(): manage spinner (off-thread). -*/ -static void -_term_spinner_cb(void* ptr_v) -{ - // This thread shouldn't receive signals. - // - { - sigset_t set; - sigfillset(&set); - pthread_sigmask(SIG_BLOCK, &set, NULL); - } - - u3_utty* uty_u = (u3_utty*)ptr_v; - - for ( uv_mutex_lock(&uty_u->tat_u.mex_u); - uty_u->tat_u.sun.sit_u; - uv_mutex_lock(&uty_u->tat_u.mex_u) ) - { - c3_d eve_d = uty_u->tat_u.sun.eve_d; - - if ( 0 == eve_d ) { - c3_o diz_o = uty_u->tat_u.sun.diz_o; - uv_mutex_unlock(&uty_u->tat_u.mex_u); - usleep(c3y == diz_o ? _SPIN_WARM_US : _SPIN_COOL_US); - } - else { - c3_d now_d = _term_msc_out_host(); - - if (now_d < eve_d) { - uv_mutex_unlock(&uty_u->tat_u.mex_u); - usleep(eve_d - now_d); - } - else { - _term_show_spinner(uty_u, now_d - eve_d); - uv_mutex_unlock(&uty_u->tat_u.mex_u); - usleep(_SPIN_RATE_US); - } - } - } - - uv_mutex_unlock(&uty_u->tat_u.mex_u); -} - -/* _term_main(): return main or console terminal. -*/ -static u3_utty* -_term_main() -{ - u3_utty* uty_u; - - for ( uty_u = u3_Host.uty_u; uty_u; uty_u = uty_u->nex_u ) { - if ( (uty_u->fid_i != -1) && (uty_u->fid_i <= 2) ) { - return uty_u; - } - } - return u3_Host.uty_u; -} - -/* _term_ef_get(): terminal by id. -*/ -static u3_utty* -_term_ef_get(c3_l tid_l) -{ - if ( 0 != tid_l ) { - u3_utty* uty_u; - - for ( uty_u = u3_Host.uty_u; uty_u; uty_u = uty_u->nex_u ) { - if ( tid_l == uty_u->tid_l ) { - return uty_u; - } - } - } - return _term_main(); -} - -/* u3_term_get_blew(): return window size [columns rows]. -*/ -u3_noun -u3_term_get_blew(c3_l tid_l) -{ - u3_utty* uty_u = _term_ef_get(tid_l); - c3_l col_l, row_l; - - struct winsize siz_u; - if ( uty_u && (0 == ioctl(uty_u->fid_i, TIOCGWINSZ, &siz_u)) ) { - col_l = siz_u.ws_col; - row_l = siz_u.ws_row; - } else { - col_l = 80; - row_l = 24; - } - - if ( uty_u ) { - uty_u->tat_u.siz.col_l = col_l; - uty_u->tat_u.siz.row_l = row_l; - } - - return u3nc(col_l, row_l); -} - -/* u3_term_ef_winc(): window change. Just console right now. -*/ -void -u3_term_ef_winc(void) -{ - u3_noun pax = u3nq(u3_blip, c3__term, '1', u3_nul); - - u3_pier_plan(pax, u3nc(c3__blew, u3_term_get_blew(1))); -} - -/* u3_term_ef_ctlc(): send ^C on console. -*/ -void -u3_term_ef_ctlc(void) -{ - u3_noun pax = u3nq(u3_blip, c3__term, '1', u3_nul); - - u3_pier_plan(pax, u3nt(c3__belt, c3__ctl, 'c')); - - _term_it_refresh_line(_term_main()); -} - -/* u3_term_ef_verb(): initial effects for verbose events -*/ -void -u3_term_ef_verb(void) -{ - u3_noun pax = u3nq(u3_blip, c3__term, '1', u3_nul); - - u3_pier_plan(pax, u3nc(c3__verb, u3_nul)); -} - -/* u3_term_ef_bake(): initial effects for new terminal. -*/ -void -u3_term_ef_bake(void) -{ - u3_noun pax = u3nq(u3_blip, c3__term, '1', u3_nul); - - // u3_pier_plan(u3k(pax), u3nq(c3__flow, c3__seat, c3__dojo, u3_nul)); - u3_pier_plan(u3k(pax), u3nc(c3__blew, u3_term_get_blew(1))); - u3_pier_plan(u3k(pax), u3nc(c3__hail, u3_nul)); - - u3z(pax); -} - -/* _term_ef_blit(): send blit to terminal. -*/ -static void -_term_ef_blit(u3_utty* uty_u, - u3_noun blt) -{ - switch ( u3h(blt) ) { - default: break; - case c3__bee: { - if ( c3n == u3_Host.ops_u.dem ) { - if ( u3_nul == u3t(blt) ) { - _term_stop_spinner(uty_u); - } - else { - _term_start_spinner(uty_u, u3t(blt)); - } - } - } break; - - case c3__bel: { - if ( c3n == u3_Host.ops_u.dem ) { - _term_it_write_txt(uty_u, uty_u->ufo_u.out.bel_y); - } - } break; - - case c3__clr: { - if ( c3n == u3_Host.ops_u.dem ) { - _term_it_show_blank(uty_u); - _term_it_refresh_line(uty_u); - } - } break; - - case c3__hop: { - if ( c3n == u3_Host.ops_u.dem ) { - _term_it_show_cursor(uty_u, u3t(blt)); - } - } break; - - case c3__lin: { - u3_noun lin = u3t(blt); - c3_w len_w = u3kb_lent(u3k(lin)); - c3_w* lin_w = c3_malloc(4 * len_w); - - { - c3_w i_w; - - for ( i_w = 0; u3_nul != lin; i_w++, lin = u3t(lin) ) { - lin_w[i_w] = u3r_word(0, u3h(lin)); - } - } - - if ( c3n == u3_Host.ops_u.dem ) { - _term_it_show_clear(uty_u); - _term_it_show_line(uty_u, lin_w, len_w); - } else { - _term_it_show_line(uty_u, lin_w, len_w); - } - } break; - - case c3__mor: { - _term_it_show_more(uty_u); - } break; - - case c3__sav: { - _term_it_save(u3k(u3h(u3t(blt))), u3k(u3t(u3t(blt)))); - } break; - - case c3__sag: { - u3_noun pib = u3k(u3t(u3t(blt))); - u3_noun jam; - - jam = u3ke_jam(pib); - - _term_it_save(u3k(u3h(u3t(blt))), jam); - } break; - - case c3__url: { - if ( c3n == u3ud(u3t(blt)) ) { - break; - } else { - c3_c* txt_c = u3r_string(u3t(blt)); - - _term_it_show_clear(uty_u); - _term_it_write_str(uty_u, txt_c); - free(txt_c); - - _term_it_show_more(uty_u); - _term_it_refresh_line(uty_u); - } - } - } - u3z(blt); - - return; -} - -/* u3_term_ef_blit(): send %blit list to specific terminal. -*/ -void -u3_term_ef_blit(c3_l tid_l, - u3_noun bls) -{ - u3_utty* uty_u = _term_ef_get(tid_l); - - if ( 0 == uty_u ) { - // u3l_log("no terminal %d\n", tid_l); - // u3l_log("uty_u %p\n", u3_Host.uty_u); - - u3z(bls); return; - } - - { - u3_noun bis = bls; - - while ( c3y == u3du(bis) ) { - _term_ef_blit(uty_u, u3k(u3h(bis))); - bis = u3t(bis); - } - u3z(bls); - } -} - -/* u3_term_io_hija(): hijack console for fprintf, returning FILE*. -*/ -FILE* -u3_term_io_hija(void) -{ - u3_utty* uty_u = _term_main(); - - if ( uty_u ) { - if ( uty_u->fid_i > 2 ) { - // We *should* in fact, produce some kind of fake FILE* for - // non-console terminals. If we use this interface enough... - // - c3_assert(0); - } - else { - if ( c3n == u3_Host.ops_u.dem ) { - if ( 0 != tcsetattr(1, TCSADRAIN, &uty_u->bak_u) ) { - perror("hija-tcsetattr-1"); - c3_assert(!"hija-tcsetattr"); - } - if ( -1 == fcntl(1, F_SETFL, uty_u->cug_i) ) { - perror("hija-fcntl-1"); - c3_assert(!"hija-fcntl"); - } - if ( 0 != tcsetattr(0, TCSADRAIN, &uty_u->bak_u) ) { - perror("hija-tcsetattr-0"); - c3_assert(!"hija-tcsetattr"); - } - if ( -1 == fcntl(0, F_SETFL, uty_u->cug_i) ) { - perror("hija-fcntl-0"); - c3_assert(!"hija-fcntl"); - } - _write(uty_u->fid_i, "\r", 1); - _write(uty_u->fid_i, uty_u->ufo_u.out.el_y, - strlen((c3_c*) uty_u->ufo_u.out.el_y)); - } - return stdout; - } - } - else return stdout; -} - -/* u3_term_io_loja(): release console from fprintf. -*/ -void -u3_term_io_loja(int x) -{ - u3_utty* uty_u = _term_main(); - - if ( uty_u ) { - if ( uty_u->fid_i > 2 ) { - // We *should* in fact, produce some kind of fake FILE* for - // non-console terminals. If we use this interface enough... - // - c3_assert(0); - } - else { - if ( c3y == u3_Host.ops_u.dem ) { - fflush(stdout); - } - else { - if ( 0 != tcsetattr(1, TCSADRAIN, &uty_u->raw_u) ) { - perror("loja-tcsetattr-1"); - c3_assert(!"loja-tcsetattr"); - } - if ( -1 == fcntl(1, F_SETFL, uty_u->nob_i) ) { - perror("hija-fcntl-1"); - c3_assert(!"loja-fcntl"); - } - if ( 0 != tcsetattr(0, TCSADRAIN, &uty_u->raw_u) ) { - perror("loja-tcsetattr-0"); - c3_assert(!"loja-tcsetattr"); - } - if ( -1 == fcntl(0, F_SETFL, uty_u->nob_i) ) { - perror("hija-fcntl-0"); - c3_assert(!"loja-fcntl"); - } - _term_it_refresh_line(uty_u); - } - } - } -} - -/* u3_term_it_log(): writes a log message -*/ -void -u3_term_io_log(c3_c* line) -{ - FILE* stream = u3_term_io_hija(); - u3_term_io_loja(fprintf(stream, "%s", line)); -} - -/* u3_term_tape_to(): dump a tape to a file. -*/ -void -u3_term_tape_to(FILE *fil_f, u3_noun tep) -{ - u3_noun tap = tep; - - while ( u3_nul != tap ) { - c3_c car_c; - - if ( u3h(tap) >= 127 ) { - car_c = '?'; - } else car_c = u3h(tap); - - putc(car_c, fil_f); - tap = u3t(tap); - } - u3z(tep); -} - -/* u3_term_tape(): dump a tape to stdout. -*/ -void -u3_term_tape(u3_noun tep) -{ - FILE* fil_f = u3_term_io_hija(); - - u3_term_tape_to(fil_f, tep); - - u3_term_io_loja(0); -} - -/* u3_term_wall(): dump a wall to stdout. -*/ -void -u3_term_wall(u3_noun wol) -{ - FILE* fil_f = u3_term_io_hija(); - u3_noun wal = wol; - - while ( u3_nul != wal ) { - u3_term_tape_to(fil_f, u3k(u3h(wal))); - - putc(13, fil_f); - putc(10, fil_f); - - wal = u3t(wal); - } - u3_term_io_loja(0); - - u3z(wol); -} diff --git a/pkg/hair/notes/c/time.c b/pkg/hair/notes/c/time.c deleted file mode 100644 index 2a36cf822..000000000 --- a/pkg/hair/notes/c/time.c +++ /dev/null @@ -1,179 +0,0 @@ -/* vere/time.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - -/* u3_time_sec_in(): urbit seconds from unix time. -** -** Adjust for future leap secs! -*/ -c3_d -u3_time_sec_in(c3_w unx_w) -{ - return 0x8000000cce9e0d80ULL + (c3_d)unx_w; -} - -/* u3_time_sec_out(): unix time from urbit seconds. -** -** Adjust for future leap secs! -*/ -c3_w -u3_time_sec_out(c3_d urs_d) -{ - c3_d adj_d = (urs_d - 0x8000000cce9e0d80ULL); - - if ( adj_d > 0xffffffffULL ) { - fprintf(stderr, "Agh! It's 2106! And no one's fixed this shite!\n"); - exit(1); - } - return (c3_w)adj_d; -} - -/* u3_time_fsc_in(): urbit fracto-seconds from unix microseconds. -*/ -c3_d -u3_time_fsc_in(c3_w usc_w) -{ - c3_d usc_d = usc_w; - - return ((usc_d * 65536ULL) / 1000000ULL) << 48ULL; -} - -/* u3_time_fsc_out: unix microseconds from urbit fracto-seconds. -*/ -c3_w -u3_time_fsc_out(c3_d ufc_d) -{ - return (c3_w) (((ufc_d >> 48ULL) * 1000000ULL) / 65536ULL); -} - -/* u3_time_msc_out: unix microseconds from urbit fracto-seconds. -*/ -c3_w -u3_time_msc_out(c3_d ufc_d) -{ - return (c3_w) (((ufc_d >> 48ULL) * 1000ULL) / 65536ULL); -} - -/* u3_time_in_tv(): urbit time from struct timeval. -*/ -u3_atom -u3_time_in_tv(struct timeval* tim_tv) -{ - c3_w unx_w = tim_tv->tv_sec; - c3_w usc_w = tim_tv->tv_usec; - c3_d cub_d[2]; - - cub_d[0] = u3_time_fsc_in(usc_w); - cub_d[1] = u3_time_sec_in(unx_w); - - return u3i_chubs(2, cub_d); -} - -/* u3_time_out_tv(): struct timeval from urbit time. -*/ -void -u3_time_out_tv(struct timeval* tim_tv, u3_noun now) -{ - c3_d ufc_d = u3r_chub(0, now); - c3_d urs_d = u3r_chub(1, now); - - tim_tv->tv_sec = u3_time_sec_out(urs_d); - tim_tv->tv_usec = u3_time_fsc_out(ufc_d); - - u3z(now); -} - -/* u3_time_in_ts(): urbit time from struct timespec. -*/ -u3_atom -u3_time_in_ts(struct timespec* tim_ts) -{ - struct timeval tim_tv; - - tim_tv.tv_sec = tim_ts->tv_sec; - tim_tv.tv_usec = (tim_ts->tv_nsec / 1000); - - return u3_time_in_tv(&tim_tv); -} - -#if defined(U3_OS_linux) -/* u3_time_t_in_ts(): urbit time from time_t. -*/ -u3_atom -u3_time_t_in_ts(time_t tim) -{ - struct timeval tim_tv; - - tim_tv.tv_sec = tim; - tim_tv.tv_usec = 0; - - return u3_time_in_tv(&tim_tv); -} -#endif // defined(U3_OS_linux) - -/* u3_time_out_ts(): struct timespec from urbit time. -*/ -void -u3_time_out_ts(struct timespec* tim_ts, u3_noun now) -{ - struct timeval tim_tv; - - u3_time_out_tv(&tim_tv, now); - - tim_ts->tv_sec = tim_tv.tv_sec; - tim_ts->tv_nsec = (tim_tv.tv_usec * 1000); -} - -/* u3_time_gap_ms(): (wen - now) in ms. -*/ -c3_d -u3_time_gap_ms(u3_noun now, u3_noun wen) -{ - if ( c3n == u3ka_gth(u3k(wen), u3k(now)) ) { - u3z(wen); u3z(now); - return 0ULL; - } - else { - u3_noun dif = u3ka_sub(wen, now); - c3_d fsc_d = u3r_chub(0, dif); - c3_d sec_d = u3r_chub(1, dif); - - u3z(dif); - return (sec_d * 1000ULL) + u3_time_msc_out(fsc_d); - } -} - -/* u3_time_gap_double(): (wen - now) in libev resolution. -*/ -double -u3_time_gap_double(u3_noun now, u3_noun wen) -{ - mpz_t now_mp, wen_mp, dif_mp; - double sec_g = (((double)(1ULL << 32ULL)) * ((double)(1ULL << 32ULL))); - double gap_g, dif_g; - - u3r_mp(now_mp, now); - u3r_mp(wen_mp, wen); - mpz_init(dif_mp); - mpz_sub(dif_mp, wen_mp, now_mp); - - u3z(now); - u3z(wen); - - dif_g = mpz_get_d(dif_mp) / sec_g; - gap_g = (dif_g > 0.0) ? dif_g : 0.0; - mpz_clear(dif_mp); mpz_clear(wen_mp); mpz_clear(now_mp); - - return gap_g; -} diff --git a/pkg/hair/notes/c/unix.c b/pkg/hair/notes/c/unix.c deleted file mode 100644 index e3a013293..000000000 --- a/pkg/hair/notes/c/unix.c +++ /dev/null @@ -1,1333 +0,0 @@ -/* vere/unix.c -** -*/ -#include "all.h" -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "vere/vere.h" - -c3_w u3_readdir_r(DIR *dirp, struct dirent *entry, struct dirent **result) -{ - errno = 0; - struct dirent * tmp_u = readdir(dirp); - - if (NULL == tmp_u){ - *result = NULL; - return (errno); // either success or error code - } else { - memcpy(entry, tmp_u, sizeof(struct dirent)); - *result = entry; - } - - return(0); -} - - -/* _unix_down(): descend path. -*/ -static c3_c* -_unix_down(c3_c* pax_c, c3_c* sub_c) -{ - c3_w pax_w = strlen(pax_c); - c3_w sub_w = strlen(sub_c); - c3_c* don_c = c3_malloc(pax_w + sub_w + 2); - - strncpy(don_c, pax_c, pax_w); - don_c[pax_w] = '/'; - strncpy(don_c + pax_w + 1, sub_c, sub_w); - don_c[pax_w + 1 + sub_w] = '\0'; - - return don_c; -} - -/* _unix_string_to_path(): convert c string to u3_noun path - * - * c string must begin with the pier path plus mountpoint -*/ -static u3_noun -_unix_string_to_path_helper(c3_c* pax_c) { - c3_assert(pax_c[-1] == '/'); - c3_c* end_w = strchr(pax_c, '/'); - if ( !end_w ) { - end_w = strrchr(pax_c, '.'); - if ( !end_w ) { - return u3nc(u3i_string(pax_c), u3_nul); - } - else { - return u3nt(u3i_bytes(end_w - pax_c, (c3_y*) pax_c), - u3i_string(end_w + 1), - u3_nul); - } - } - else { - return u3nc(u3i_bytes(end_w - pax_c, (c3_y*) pax_c), - _unix_string_to_path_helper(end_w + 1)); - } -} -static u3_noun -_unix_string_to_path(u3_pier *pir_u, c3_c* pax_c) { - pax_c += strlen(pir_u->pax_c) + 1; - c3_c* pox_c = strchr(pax_c, '/'); - if ( !pox_c ) { - pox_c = strchr(pax_c, '.'); - if ( !pox_c ) { - return u3_nul; - } - else { - return u3nc(u3i_string(pox_c + 1), u3_nul); - } - } - else { - return _unix_string_to_path_helper(pox_c + 1); - } -} - -/* _unix_rm_r_cb(): callback to delete individual files/directories -*/ -static c3_i -_unix_rm_r_cb(const c3_c* pax_c, - const struct stat* buf_u, - c3_i typeflag, - struct FTW* ftw_u) -{ - switch ( typeflag ) { - default: - u3l_log("bad file type in rm_r: %s\r\n", pax_c); - break; - case FTW_F: - if ( 0 != unlink(pax_c) && ENOENT != errno ) { - u3l_log("error unlinking (in rm_r) %s: %s\n", - pax_c, strerror(errno)); - c3_assert(0); - } - break; - case FTW_D: - u3l_log("shouldn't have gotten pure directory: %s\r\n", pax_c); - break; - case FTW_DNR: - u3l_log("couldn't read directory: %s\r\n", pax_c); - break; - case FTW_NS: - u3l_log("couldn't stat path: %s\r\n", pax_c); - break; - case FTW_DP: - if ( 0 != rmdir(pax_c) && ENOENT != errno ) { - u3l_log("error rmdiring %s: %s\n", pax_c, strerror(errno)); - c3_assert(0); - } - break; - case FTW_SL: - u3l_log("got symbolic link: %s\r\n", pax_c); - break; - case FTW_SLN: - u3l_log("got nonexistent symbolic link: %s\r\n", pax_c); - break; - } - - return 0; -} - -/* _unix_rm_r(): rm -r directory -*/ -static void -_unix_rm_r(c3_c* pax_c) -{ - if ( 0 > nftw(pax_c, _unix_rm_r_cb, 100, FTW_DEPTH | FTW_PHYS ) - && ENOENT != errno) { - u3l_log("rm_r error on %s: %s\r\n", pax_c, strerror(errno)); - } -} - -/* _unix_mkdir(): mkdir, asserting. -*/ -static void -_unix_mkdir(c3_c* pax_c) -{ - if ( 0 != mkdir(pax_c, 0755) && EEXIST != errno) { - u3l_log("error mkdiring %s: %s\n", pax_c, strerror(errno)); - c3_assert(0); - } -} - -/* _unix_write_file_hard(): write to a file, overwriting what's there -*/ -static c3_w -_unix_write_file_hard(c3_c* pax_c, u3_noun mim) -{ - c3_i fid_i = open(pax_c, O_WRONLY | O_CREAT | O_TRUNC, 0666); - c3_w len_w, rit_w, siz_w, mug_w = 0; - c3_y* dat_y; - - u3_noun dat = u3t(u3t(mim)); - - if ( fid_i < 0 ) { - u3l_log("error opening %s for writing: %s\r\n", - pax_c, strerror(errno)); - u3z(mim); - return 0; - } - - siz_w = u3h(u3t(mim)); - len_w = u3r_met(3, dat); - dat_y = c3_calloc(siz_w); - - u3r_bytes(0, len_w, dat_y, dat); - u3z(mim); - - rit_w = write(fid_i, dat_y, siz_w); - - if ( rit_w != siz_w ) { - u3l_log("error writing %s: %s\r\n", - pax_c, strerror(errno)); - mug_w = 0; - } - else { - mug_w = u3r_mug_bytes(dat_y, len_w); - } - - close(fid_i); - free(dat_y); - - return mug_w; -} - -/* _unix_write_file_soft(): write to a file, not overwriting if it's changed -*/ -static void -_unix_write_file_soft(u3_ufil* fil_u, u3_noun mim) -{ - struct stat buf_u; - c3_i fid_i = open(fil_u->pax_c, O_RDONLY, 0644); - c3_ws len_ws, red_ws; - c3_w old_w; - c3_y* old_y; - - if ( fid_i < 0 || fstat(fid_i, &buf_u) < 0 ) { - if ( ENOENT == errno ) { - goto _unix_write_file_soft_go; - } - else { - u3l_log("error opening file (soft) %s: %s\r\n", - fil_u->pax_c, strerror(errno)); - u3z(mim); - return; - } - } - - len_ws = buf_u.st_size; - old_y = c3_malloc(len_ws); - - red_ws = read(fid_i, old_y, len_ws); - - if ( close(fid_i) < 0 ) { - u3l_log("error closing file (soft) %s: %s\r\n", - fil_u->pax_c, strerror(errno)); - } - - if ( len_ws != red_ws ) { - if ( red_ws < 0 ) { - u3l_log("error reading file (soft) %s: %s\r\n", - fil_u->pax_c, strerror(errno)); - } - else { - u3l_log("wrong # of bytes read in file %s: %d %d\r\n", - fil_u->pax_c, len_ws, red_ws); - } - free(old_y); - u3z(mim); - return; - } - - old_w = u3r_mug_bytes(old_y, len_ws); - - if ( old_w != fil_u->gum_w ) { - fil_u->gum_w = u3r_mug(u3t(u3t(mim))); // XXX this might fail with - free(old_y); // trailing zeros - u3z(mim); - return; - } - - free(old_y); - -_unix_write_file_soft_go: - fil_u->gum_w = _unix_write_file_hard(fil_u->pax_c, mim); -} - -static void -_unix_watch_dir(u3_udir* dir_u, u3_udir* par_u, c3_c* pax_c); -static void -_unix_watch_file(u3_pier *pir_u, u3_ufil* fil_u, u3_udir* par_u, c3_c* pax_c); - -/* _unix_get_mount_point(): retrieve or create mount point -*/ -static u3_umon* -_unix_get_mount_point(u3_pier *pir_u, u3_noun mon) -{ - if ( c3n == u3ud(mon) ) { - c3_assert(!"mount point must be an atom"); - u3z(mon); - return NULL; - } - - c3_c* nam_c = u3r_string(mon); - u3_umon* mon_u; - - for ( mon_u = pir_u->unx_u->mon_u; - mon_u && 0 != strcmp(nam_c, mon_u->nam_c); - mon_u = mon_u->nex_u ) - { - } - - if ( !mon_u ) { - mon_u = c3_malloc(sizeof(u3_umon)); - mon_u->nam_c = nam_c; - mon_u->dir_u.dir = c3y; - mon_u->dir_u.dry = c3n; - mon_u->dir_u.pax_c = strdup(pir_u->pax_c); - mon_u->dir_u.par_u = NULL; - mon_u->dir_u.nex_u = NULL; - mon_u->dir_u.kid_u = NULL; - mon_u->nex_u = pir_u->unx_u->mon_u; - pir_u->unx_u->mon_u = mon_u; - - } - else { - free(nam_c); - } - - u3z(mon); - - return mon_u; -} - -/* _unix_scan_mount_point(): scan unix for already-existing mount point -*/ -static void -_unix_scan_mount_point(u3_pier *pir_u, u3_umon* mon_u) -{ - DIR* rid_u = opendir(mon_u->dir_u.pax_c); - if ( !rid_u ) { - u3l_log("error opening pier directory: %s: %s\r\n", - mon_u->dir_u.pax_c, strerror(errno)); - return; - } - - c3_w len_w = strlen(mon_u->nam_c); - - while ( 1 ) { - struct dirent ent_u; - struct dirent* out_u; - c3_w err_w; - - if ( 0 != (err_w = u3_readdir_r(rid_u, &ent_u, &out_u)) ) { - u3l_log("erroring loading pier directory %s: %s\r\n", - mon_u->dir_u.pax_c, strerror(errno)); - - c3_assert(0); - } - else if ( !out_u ) { - break; - } - else if ( '.' == out_u->d_name[0] ) { // unnecessary, but consistency - continue; - } - else if ( 0 != strncmp(mon_u->nam_c, out_u->d_name, len_w) ) { - continue; - } - else { - c3_c* pax_c = _unix_down(mon_u->dir_u.pax_c, out_u->d_name); - - struct stat buf_u; - - if ( 0 != stat(pax_c, &buf_u) ) { - u3l_log("can't stat pier directory %s: %s\r\n", - mon_u->dir_u.pax_c, strerror(errno)); - free(pax_c); - continue; - } - if ( S_ISDIR(buf_u.st_mode) ) { - if ( out_u->d_name[len_w] != '\0' ) { - free(pax_c); - continue; - } - else { - u3_udir* dir_u = c3_malloc(sizeof(u3_udir)); - _unix_watch_dir(dir_u, &mon_u->dir_u, pax_c); - } - } - else { - if ( '.' != out_u->d_name[len_w] - || '\0' == out_u->d_name[len_w + 1] - || '~' == out_u->d_name[strlen(out_u->d_name) - 1] - || ('#' == out_u->d_name[0] && - '#' == out_u->d_name[strlen(out_u->d_name) - 1]) - ) { - free(pax_c); - continue; - } - else { - u3_ufil* fil_u = c3_malloc(sizeof(u3_ufil)); - _unix_watch_file(pir_u, fil_u, &mon_u->dir_u, pax_c); - } - } - - free(pax_c); - } - } -} - -static u3_noun _unix_free_node(u3_pier *pir_u, u3_unod* nod_u); - -/* _unix_free_file(): free file, unlinking it -*/ -static void -_unix_free_file(u3_ufil *fil_u) -{ - if ( 0 != unlink(fil_u->pax_c) && ENOENT != errno ) { - u3l_log("error unlinking %s: %s\n", fil_u->pax_c, strerror(errno)); - c3_assert(0); - } - - free(fil_u->pax_c); - free(fil_u); -} - -/* _unix_free_dir(): free directory, deleting everything within -*/ -static void -_unix_free_dir(u3_udir *dir_u) -{ - _unix_rm_r(dir_u->pax_c); - - if ( dir_u->kid_u ) { - fprintf(stderr, "don't kill me, i've got a family %s\r\n", dir_u->pax_c); - } - else { - // fprintf(stderr, "i'm a lone, lonely loner %s\r\n", dir_u->pax_c); - } - free(dir_u->pax_c); - free(dir_u); // XXX this might be too early, how do we - // know we've freed all the children? - // i suspect we should do this only if - // our kid list is empty -} - -/* _unix_free_node(): free node, deleting everything within - * - * also deletes from parent list if in it -*/ -static u3_noun -_unix_free_node(u3_pier *pir_u, u3_unod* nod_u) -{ - u3_noun can; - if ( nod_u->par_u ) { - u3_unod* don_u = nod_u->par_u->kid_u; - - if ( !don_u ) { - } - else if ( nod_u == don_u ) { - nod_u->par_u->kid_u = nod_u->par_u->kid_u->nex_u; - } - else { - for ( ; don_u->nex_u && nod_u != don_u->nex_u; don_u = don_u->nex_u ) { - } - if ( don_u->nex_u ) { - don_u->nex_u = don_u->nex_u->nex_u; - } - } - } - - if ( c3y == nod_u->dir ) { - can = u3_nul; - u3_unod* nud_u = ((u3_udir*) nod_u)->kid_u; - while ( nud_u ) { - u3_unod* nex_u = nud_u->nex_u; - can = u3kb_weld(_unix_free_node(pir_u, nud_u), can); - nud_u = nex_u; - } - _unix_free_dir((u3_udir *)nod_u); - } - else { - can = u3nc(u3nc(_unix_string_to_path(pir_u, nod_u->pax_c), u3_nul), - u3_nul); - _unix_free_file((u3_ufil *)nod_u); - } - - return can; -} - -/* _unix_free_mount_point(): free mount point - * - * this process needs to happen in a very careful order. in particular, - * we must recurse before we get to the callback, so that libuv does all - * the child directories before it does us. - * - * tread carefully -*/ -static void -_unix_free_mount_point(u3_pier *pir_u, u3_umon* mon_u) -{ - u3_unod* nod_u; - for ( nod_u = mon_u->dir_u.kid_u; nod_u; ) { - u3_unod* nex_u = nod_u->nex_u; - u3z(_unix_free_node(pir_u, nod_u)); - nod_u = nex_u; - } - - free(mon_u->dir_u.pax_c); - free(mon_u->nam_c); - free(mon_u); -} - -/* _unix_delete_mount_point(): remove mount point from list and free -*/ -static void -_unix_delete_mount_point(u3_pier *pir_u, u3_noun mon) -{ - if ( c3n == u3ud(mon) ) { - c3_assert(!"mount point must be an atom"); - u3z(mon); - return; - } - - c3_c* nam_c = u3r_string(mon); - u3_umon* mon_u; - u3_umon* tem_u; - - mon_u = pir_u->unx_u->mon_u; - if ( !mon_u ) { - u3l_log("mount point already gone: %s\r\n", nam_c); - goto _delete_mount_point_out; - } - if ( 0 == strcmp(nam_c, mon_u->nam_c) ) { - pir_u->unx_u->mon_u = mon_u->nex_u; - _unix_free_mount_point(pir_u, mon_u); - goto _delete_mount_point_out; - } - - for ( ; - mon_u->nex_u && 0 != strcmp(nam_c, mon_u->nex_u->nam_c); - mon_u = mon_u->nex_u ) - { - } - - if ( !mon_u->nex_u ) { - u3l_log("mount point already gone: %s\r\n", nam_c); - goto _delete_mount_point_out; - } - - tem_u = mon_u->nex_u; - mon_u->nex_u = mon_u->nex_u->nex_u; - _unix_free_mount_point(pir_u, tem_u); - -_delete_mount_point_out: - free(nam_c); - u3z(mon); -} - -/* _unix_commit_mount_point: commit from mount point -*/ -static void -_unix_commit_mount_point(u3_pier *pir_u, u3_noun mon) -{ - pir_u->unx_u->dyr = c3y; - u3z(mon); - u3_unix_ef_look(pir_u, c3n); - return; -} - -/* _unix_watch_file(): initialize file -*/ -static void -_unix_watch_file(u3_pier *pir_u, u3_ufil* fil_u, u3_udir* par_u, c3_c* pax_c) -{ - // initialize fil_u - - fil_u->dir = c3n; - fil_u->dry = c3n; - fil_u->pax_c = c3_malloc(1 + strlen(pax_c)); - strcpy(fil_u->pax_c, pax_c); - fil_u->par_u = par_u; - fil_u->nex_u = NULL; - fil_u->mug_w = 0; - fil_u->gum_w = 0; - - if ( par_u ) { - fil_u->nex_u = par_u->kid_u; - par_u->kid_u = (u3_unod*) fil_u; - } -} - -/* _unix_watch_dir(): initialize directory -*/ -static void -_unix_watch_dir(u3_udir* dir_u, u3_udir* par_u, c3_c* pax_c) -{ - // initialize dir_u - - dir_u->dir = c3y; - dir_u->dry = c3n; - dir_u->pax_c = c3_malloc(1 + strlen(pax_c)); - strcpy(dir_u->pax_c, pax_c); - dir_u->par_u = par_u; - dir_u->nex_u = NULL; - dir_u->kid_u = NULL; - - if ( par_u ) { - dir_u->nex_u = par_u->kid_u; - par_u->kid_u = (u3_unod*) dir_u; - } -} - -/* _unix_create_dir(): create unix directory and watch it -*/ -static void -_unix_create_dir(u3_udir* dir_u, u3_udir* par_u, u3_noun nam) -{ - c3_c* nam_c = u3r_string(nam); - c3_w nam_w = strlen(nam_c); - c3_w pax_w = strlen(par_u->pax_c); - c3_c* pax_c = c3_malloc(pax_w + 1 + nam_w + 1); - - strncpy(pax_c, par_u->pax_c, pax_w); - pax_c[pax_w] = '/'; - strncpy(pax_c + pax_w + 1, nam_c, nam_w); - pax_c[pax_w + 1 + nam_w] = '\0'; - - free(nam_c); - u3z(nam); - - _unix_mkdir(pax_c); - _unix_watch_dir(dir_u, par_u, pax_c); -} - -static u3_noun _unix_update_node(u3_pier *pir_u, u3_unod* nod_u); - -/* _unix_update_file(): update file, producing list of changes - * - * when scanning through files, if dry, do nothing. otherwise, mark as - * dry, then check if file exists. if not, remove self from node list - * and add path plus sig to %into event. otherwise, read the file and - * get a mug checksum. if same as mug_w, move on. otherwise, overwrite - * mug_w with new mug and add path plus data to %into event. -*/ -static u3_noun -_unix_update_file(u3_pier *pir_u, u3_ufil* fil_u) -{ - c3_assert( c3n == fil_u->dir ); - - if ( c3y == fil_u->dry ) { - return u3_nul; - } - - fil_u->dry = c3n; - - struct stat buf_u; - c3_i fid_i = open(fil_u->pax_c, O_RDONLY, 0644); - c3_ws len_ws, red_ws; - c3_y* dat_y; - - if ( fid_i < 0 || fstat(fid_i, &buf_u) < 0 ) { - if ( ENOENT == errno ) { - return u3nc(u3nc(_unix_string_to_path(pir_u, fil_u->pax_c), u3_nul), u3_nul); - } - else { - u3l_log("error opening file %s: %s\r\n", - fil_u->pax_c, strerror(errno)); - return u3_nul; - } - } - - len_ws = buf_u.st_size; - dat_y = c3_malloc(len_ws); - - red_ws = read(fid_i, dat_y, len_ws); - - if ( close(fid_i) < 0 ) { - u3l_log("error closing file %s: %s\r\n", - fil_u->pax_c, strerror(errno)); - } - - if ( len_ws != red_ws ) { - if ( red_ws < 0 ) { - u3l_log("error reading file %s: %s\r\n", - fil_u->pax_c, strerror(errno)); - } - else { - u3l_log("wrong # of bytes read in file %s: %d %d\r\n", - fil_u->pax_c, len_ws, red_ws); - } - free(dat_y); - return u3_nul; - } - else { - c3_w mug_w = u3r_mug_bytes(dat_y, len_ws); - if ( mug_w == fil_u->mug_w ) { - free(dat_y); - return u3_nul; - } - else if ( mug_w == fil_u->gum_w ) { - fil_u->mug_w = mug_w; - free(dat_y); - return u3_nul; - } - else { - fil_u->mug_w = mug_w; - - u3_noun pax = _unix_string_to_path(pir_u, fil_u->pax_c); - u3_noun mim = u3nt(c3__text, u3i_string("plain"), u3_nul); - u3_noun dat = u3nt(mim, len_ws, u3i_bytes(len_ws, dat_y)); - - free(dat_y); - return u3nc(u3nt(pax, u3_nul, dat), u3_nul); - } - } -} - -/* _unix_update_dir(): update directory, producing list of changes - * - * when changing this, consider whether to also change - * _unix_initial_update_dir() -*/ -static u3_noun -_unix_update_dir(u3_pier *pir_u, u3_udir* dir_u) -{ - u3_noun can = u3_nul; - - c3_assert( c3y == dir_u->dir ); - - if ( c3y == dir_u->dry ) { - return u3_nul; - } - - dir_u->dry = c3n; - - // Check that old nodes are still there - - u3_unod* nod_u = dir_u->kid_u; - - if ( nod_u ) { - while ( nod_u ) { - if ( c3y == nod_u->dry ) { - nod_u = nod_u->nex_u; - } - else { - if ( c3y == nod_u->dir ) { - DIR* red_u = opendir(nod_u->pax_c); - if ( 0 == red_u ) { - u3_unod* nex_u = nod_u->nex_u; - can = u3kb_weld(_unix_free_node(pir_u, nod_u), can); - nod_u = nex_u; - } - else { - closedir(red_u); - nod_u = nod_u->nex_u; - } - } - else { - struct stat buf_u; - c3_i fid_i = open(nod_u->pax_c, O_RDONLY, 0644); - - if ( (fid_i < 0) || (fstat(fid_i, &buf_u) < 0) ) { - if ( ENOENT != errno ) { - u3l_log("_unix_update_dir: error opening file %s: %s\r\n", - nod_u->pax_c, strerror(errno)); - } - - u3_unod* nex_u = nod_u->nex_u; - can = u3kb_weld(_unix_free_node(pir_u, nod_u), can); - nod_u = nex_u; - } - else { - if ( close(fid_i) < 0 ) { - u3l_log("_unix_update_dir: error closing file %s: %s\r\n", - nod_u->pax_c, strerror(errno)); - } - - nod_u = nod_u->nex_u; - } - } - } - } - } - - // Check for new nodes - - DIR* rid_u = opendir(dir_u->pax_c); - if ( !rid_u ) { - u3l_log("error opening directory %s: %s\r\n", - dir_u->pax_c, strerror(errno)); - c3_assert(0); - } - - while ( 1 ) { - struct dirent ent_u; - struct dirent* out_u; - c3_w err_w; - - - if ( (err_w = u3_readdir_r(rid_u, &ent_u, &out_u)) != 0 ) { - u3l_log("error loading directory %s: %s\r\n", - dir_u->pax_c, strerror(err_w)); - c3_assert(0); - } - else if ( !out_u ) { - break; - } - else if ( '.' == out_u->d_name[0] ) { - continue; - } - else { - c3_c* pax_c = _unix_down(dir_u->pax_c, out_u->d_name); - - struct stat buf_u; - - if ( 0 != stat(pax_c, &buf_u) ) { - u3l_log("can't stat %s: %s\r\n", pax_c, strerror(errno)); - free(pax_c); - continue; - } - else { - u3_unod* nod_u; - for ( nod_u = dir_u->kid_u; nod_u; nod_u = nod_u->nex_u ) { - if ( 0 == strcmp(pax_c, nod_u->pax_c) ) { - if ( S_ISDIR(buf_u.st_mode) ) { - if ( c3n == nod_u->dir ) { - u3l_log("not a directory: %s\r\n", nod_u->pax_c); - c3_assert(0); - } - } - else { - if ( c3y == nod_u->dir ) { - u3l_log("not a file: %s\r\n", nod_u->pax_c); - c3_assert(0); - } - } - break; - } - } - - if ( !nod_u ) { - if ( !S_ISDIR(buf_u.st_mode) ) { - if ( !strchr(out_u->d_name,'.') - || '~' == out_u->d_name[strlen(out_u->d_name) - 1] - || ('#' == out_u->d_name[0] && - '#' == out_u->d_name[strlen(out_u->d_name) - 1]) - ) { - free(pax_c); - continue; - } - - u3_ufil* fil_u = c3_malloc(sizeof(u3_ufil)); - _unix_watch_file(pir_u, fil_u, dir_u, pax_c); - } - else { - u3_udir* dis_u = c3_malloc(sizeof(u3_udir)); - _unix_watch_dir(dis_u, dir_u, pax_c); - can = u3kb_weld(_unix_update_dir(pir_u, dis_u), can); // XXX unnecessary? - } - } - } - - free(pax_c); - } - } - - if ( closedir(rid_u) < 0 ) { - u3l_log("error closing directory %s: %s\r\n", - dir_u->pax_c, strerror(errno)); - } - - if ( !dir_u->kid_u ) { - return u3kb_weld(_unix_free_node(pir_u, (u3_unod*) dir_u), can); - } - - // get change list - - for ( nod_u = dir_u->kid_u; nod_u; nod_u = nod_u->nex_u ) { - can = u3kb_weld(_unix_update_node(pir_u, nod_u), can); - } - - return can; -} - -/* _unix_update_node(): update node, producing list of changes -*/ -static u3_noun -_unix_update_node(u3_pier *pir_u, u3_unod* nod_u) -{ - if ( c3y == nod_u->dir ) { - return _unix_update_dir(pir_u, (void*)nod_u); - } - else { - return _unix_update_file(pir_u, (void*)nod_u); - } -} - -/* _unix_update_mount(): update mount point -*/ -static void -_unix_update_mount(u3_pier *pir_u, u3_umon* mon_u, u3_noun all) -{ - if ( c3n == mon_u->dir_u.dry ) { - u3_noun can = u3_nul; - u3_unod* nod_u; - for ( nod_u = mon_u->dir_u.kid_u; nod_u; nod_u = nod_u->nex_u ) { - can = u3kb_weld(_unix_update_node(pir_u, nod_u), can); - } - - u3_pier_work(pir_u, - u3nq(u3_blip, c3__sync, u3k(u3A->sen), u3_nul), - u3nq(c3__into, u3i_string(mon_u->nam_c), all, can)); - } -} - -/* _unix_initial_update_file(): read file, but don't watch -** XX deduplicate with _unix_update_file() -*/ -static u3_noun -_unix_initial_update_file(c3_c* pax_c, c3_c* bas_c) -{ - struct stat buf_u; - c3_i fid_i = open(pax_c, O_RDONLY, 0644); - c3_ws len_ws, red_ws; - c3_y* dat_y; - - if ( fid_i < 0 || fstat(fid_i, &buf_u) < 0 ) { - if ( ENOENT == errno ) { - return u3_nul; - } - else { - u3l_log("error opening initial file %s: %s\r\n", - pax_c, strerror(errno)); - return u3_nul; - } - } - - len_ws = buf_u.st_size; - dat_y = c3_malloc(len_ws); - - red_ws = read(fid_i, dat_y, len_ws); - - if ( close(fid_i) < 0 ) { - u3l_log("error closing initial file %s: %s\r\n", - pax_c, strerror(errno)); - } - - if ( len_ws != red_ws ) { - if ( red_ws < 0 ) { - u3l_log("error reading initial file %s: %s\r\n", - pax_c, strerror(errno)); - } - else { - u3l_log("wrong # of bytes read in initial file %s: %d %d\r\n", - pax_c, len_ws, red_ws); - } - free(dat_y); - return u3_nul; - } - else { - u3_noun pax = _unix_string_to_path_helper(pax_c - + strlen(bas_c) - + 1); /* XX slightly less VERY BAD than before*/ - u3_noun mim = u3nt(c3__text, u3i_string("plain"), u3_nul); - u3_noun dat = u3nt(mim, len_ws, u3i_bytes(len_ws, dat_y)); - - free(dat_y); - return u3nc(u3nt(pax, u3_nul, dat), u3_nul); - } -} - -/* _unix_initial_update_dir(): read directory, but don't watch -** XX deduplicate with _unix_update_dir() -*/ -static u3_noun -_unix_initial_update_dir(c3_c* pax_c, c3_c* bas_c) -{ - u3_noun can = u3_nul; - - DIR* rid_u = opendir(pax_c); - if ( !rid_u ) { - u3l_log("error opening initial directory: %s: %s\r\n", - pax_c, strerror(errno)); - return u3_nul; - } - - while ( 1 ) { - struct dirent ent_u; - struct dirent* out_u; - c3_w err_w; - - if ( 0 != (err_w = u3_readdir_r(rid_u, &ent_u, &out_u)) ) { - u3l_log("error loading initial directory %s: %s\r\n", - pax_c, strerror(errno)); - - c3_assert(0); - } - else if ( !out_u ) { - break; - } - else if ( '.' == out_u->d_name[0] ) { - continue; - } - else { - c3_c* pox_c = _unix_down(pax_c, out_u->d_name); - - struct stat buf_u; - - if ( 0 != stat(pox_c, &buf_u) ) { - u3l_log("initial can't stat %s: %s\r\n", - pox_c, strerror(errno)); - free(pox_c); - continue; - } - else { - if ( S_ISDIR(buf_u.st_mode) ) { - can = u3kb_weld(_unix_initial_update_dir(pox_c, bas_c), can); - } - else { - can = u3kb_weld(_unix_initial_update_file(pox_c, bas_c), can); - } - free(pox_c); - } - } - } - - if ( closedir(rid_u) < 0 ) { - u3l_log("error closing initial directory %s: %s\r\n", - pax_c, strerror(errno)); - } - - return can; -} - -/* u3_unix_initial_into_card(): create initial filesystem sync card. -*/ -u3_noun -u3_unix_initial_into_card(c3_c* arv_c) -{ - u3_noun can = _unix_initial_update_dir(arv_c, arv_c); - - return u3nc(u3nt(u3_blip, c3__sync, u3_nul), - u3nq(c3__into, u3_nul, c3y, can)); -} - -/* _unix_sync_file(): sync file to unix -*/ -static void -_unix_sync_file(u3_pier *pir_u, u3_udir* par_u, u3_noun nam, u3_noun ext, u3_noun mim) -{ - c3_assert( par_u ); - c3_assert( c3y == par_u->dir ); - - // form file path - - c3_c* nam_c = u3r_string(nam); - c3_c* ext_c = u3r_string(ext); - c3_w par_w = strlen(par_u->pax_c); - c3_w nam_w = strlen(nam_c); - c3_w ext_w = strlen(ext_c); - c3_c* pax_c = c3_malloc(par_w + 1 + nam_w + 1 + ext_w + 1); - - strncpy(pax_c, par_u->pax_c, par_w); - pax_c[par_w] = '/'; - strncpy(pax_c + par_w + 1, nam_c, nam_w); - pax_c[par_w + 1 + nam_w] = '.'; - strncpy(pax_c + par_w + 1 + nam_w + 1, ext_c, ext_w); - pax_c[par_w + 1 + nam_w + 1 + ext_w] = '\0'; - - free(nam_c); free(ext_c); - u3z(nam); u3z(ext); - - // check whether we already know about this file - - u3_unod* nod_u; - for ( nod_u = par_u->kid_u; - ( nod_u && - ( c3y == nod_u->dir || - 0 != strcmp(nod_u->pax_c, pax_c) ) ); - nod_u = nod_u->nex_u ) - { } - - // apply change - - if ( u3_nul == mim ) { - if ( nod_u ) { - u3z(_unix_free_node(pir_u, nod_u)); - } - } - else { - - if ( !nod_u ) { - c3_w gum_w = _unix_write_file_hard(pax_c, u3k(u3t(mim))); - u3_ufil* fil_u = c3_malloc(sizeof(u3_ufil)); - _unix_watch_file(pir_u, fil_u, par_u, pax_c); - fil_u->gum_w = gum_w; - goto _unix_sync_file_out; - } - else { - _unix_write_file_soft((u3_ufil*) nod_u, u3k(u3t(mim))); - } - } - - free(pax_c); - -_unix_sync_file_out: - u3z(mim); -} - -/* _unix_sync_change(): sync single change to unix -*/ -static void -_unix_sync_change(u3_pier *pir_u, u3_udir* dir_u, u3_noun pax, u3_noun mim) -{ - c3_assert( c3y == dir_u->dir ); - - if ( c3n == u3du(pax) ) { - if ( u3_nul == pax ) { - u3l_log("can't sync out file as top-level, strange\r\n"); - } - else { - u3l_log("sync out: bad path\r\n"); - } - u3z(pax); u3z(mim); - return; - } - else if ( c3n == u3du(u3t(pax)) ) { - u3l_log("can't sync out file as top-level, strangely\r\n"); - u3z(pax); u3z(mim); - } - else { - u3_noun i_pax = u3h(pax); - u3_noun t_pax = u3t(pax); - u3_noun it_pax = u3h(t_pax); - u3_noun tt_pax = u3t(t_pax); - - if ( u3_nul == tt_pax ) { - _unix_sync_file(pir_u, dir_u, u3k(i_pax), u3k(it_pax), mim); - } - else { - c3_c* nam_c = u3r_string(i_pax); - c3_w pax_w = strlen(dir_u->pax_c); - u3_unod* nod_u; - - for ( nod_u = dir_u->kid_u; - ( nod_u && - ( c3n == nod_u->dir || - 0 != strcmp(nod_u->pax_c + pax_w + 1, nam_c) ) ); - nod_u = nod_u->nex_u ) - { } - - if ( !nod_u ) { - nod_u = c3_malloc(sizeof(u3_udir)); - _unix_create_dir((u3_udir*) nod_u, dir_u, u3k(i_pax)); - } - - if ( c3n == nod_u->dir ) { - u3l_log("weird, we got a file when we weren't expecting to\r\n"); - c3_assert(0); - } - - _unix_sync_change(pir_u, (u3_udir*) nod_u, u3k(t_pax), mim); - } - } - u3z(pax); -} - -/* _unix_sync_ergo(): sync list of changes to unix -*/ -static void -_unix_sync_ergo(u3_pier *pir_u, u3_umon* mon_u, u3_noun can) -{ - u3_noun nac = can; - u3_noun nam = u3i_string(mon_u->nam_c); - - while ( u3_nul != nac) { - _unix_sync_change(pir_u, &mon_u->dir_u, - u3nc(u3k(nam), u3k(u3h(u3h(nac)))), - u3k(u3t(u3h(nac)))); - nac = u3t(nac); - } - - u3z(nam); - u3z(can); -} - -/* u3_unix_ef_dirk(): commit mount point -*/ -void -u3_unix_ef_dirk(u3_pier *pir_u, u3_noun mon) -{ - _unix_commit_mount_point(pir_u, mon); -} - -/* u3_unix_ef_ergo(): update filesystem from urbit -*/ -void -u3_unix_ef_ergo(u3_pier *pir_u, u3_noun mon, u3_noun can) -{ - u3_umon* mon_u = _unix_get_mount_point(pir_u, mon); - - _unix_sync_ergo(pir_u, mon_u, can); -} - -/* u3_unix_ef_ogre(): delete mount point -*/ -void -u3_unix_ef_ogre(u3_pier *pir_u, u3_noun mon) -{ - _unix_delete_mount_point(pir_u, mon); -} - -/* u3_unix_ef_hill(): enumerate mount points -*/ -void -u3_unix_ef_hill(u3_pier *pir_u, u3_noun hil) -{ - u3_noun mon; - for ( mon = hil; c3y == u3du(mon); mon = u3t(mon) ) { - u3_umon* mon_u = _unix_get_mount_point(pir_u, u3k(u3h(mon))); - _unix_scan_mount_point(pir_u, mon_u); - } - u3z(hil); -} - -/* u3_unix_io_init(): initialize unix sync. -*/ -void -u3_unix_io_init(u3_pier *pir_u) -{ - u3_unix* unx_u = pir_u->unx_u; - - unx_u->mon_u = NULL; - - unx_u->alm = c3n; - unx_u->dyr = c3n; -} - -/* u3_unix_acquire(): acquire a lockfile, killing anything that holds it. -*/ -static void -u3_unix_acquire(c3_c* pax_c) -{ - c3_c* paf_c = _unix_down(pax_c, ".vere.lock"); - c3_w pid_w; - FILE* loq_u; - - if ( NULL != (loq_u = fopen(paf_c, "r")) ) { - if ( 1 != fscanf(loq_u, "%" SCNu32, &pid_w) ) { - u3l_log("lockfile %s is corrupt!\n", paf_c); - kill(getpid(), SIGTERM); - sleep(1); c3_assert(0); - } - else if (pid_w != getpid()) { - c3_w i_w; - - if ( -1 != kill(pid_w, SIGTERM) ) { - u3l_log("unix: stopping process %d, live in %s...\n", - pid_w, pax_c); - - for ( i_w = 0; i_w < 16; i_w++ ) { - sleep(1); - if ( -1 == kill(pid_w, SIGTERM) ) { - break; - } - } - if ( 16 == i_w ) { - for ( i_w = 0; i_w < 16; i_w++ ) { - if ( -1 == kill(pid_w, SIGKILL) ) { - break; - } - sleep(1); - } - } - if ( 16 == i_w ) { - u3l_log("process %d seems unkillable!\n", pid_w); - c3_assert(0); - } - u3l_log("unix: stopped old process %u\n", pid_w); - } - } - fclose(loq_u); - unlink(paf_c); - } - - loq_u = fopen(paf_c, "w"); - fprintf(loq_u, "%u\n", getpid()); - - { - c3_i fid_i = fileno(loq_u); -#if defined(U3_OS_linux) - fdatasync(fid_i); -#elif defined(U3_OS_osx) - fcntl(fid_i, F_FULLFSYNC); -#elif defined(U3_OS_bsd) - fsync(fid_i); -#else -# error "port: datasync" -#endif - } - fclose(loq_u); - free(paf_c); -} - -/* u3_unix_release(): release a lockfile. -*/ -static void -u3_unix_release(c3_c* pax_c) -{ - c3_c* paf_c = _unix_down(pax_c, ".vere.lock"); - - unlink(paf_c); - free(paf_c); -} - -/* u3_unix_ef_bake(): initial effects for new process. -*/ -void -u3_unix_ef_bake(u3_pier *pir_u) -{ - u3_pier_work(pir_u, - u3nt(u3_blip, c3__boat, u3_nul), - u3nc(c3__boat, u3_nul)); -} - -/* u3_unix_ef_look(): update the root. -*/ -void -u3_unix_ef_look(u3_pier *pir_u, u3_noun all) -{ - if ( c3y == pir_u->unx_u->dyr ) { - pir_u->unx_u->dyr = c3n; - u3_umon* mon_u; - - for ( mon_u = pir_u->unx_u->mon_u; mon_u; mon_u = mon_u->nex_u ) { - _unix_update_mount(pir_u, mon_u, all); - } - } -} - -/* u3_unix_io_talk(): start listening for fs events. -*/ -void -u3_unix_io_talk(u3_pier *pir_u) -{ - u3_unix_acquire(pir_u->pax_c); -} - -/* u3_unix_io_exit(): terminate unix I/O. -*/ -void -u3_unix_io_exit(u3_pier *pir_u) -{ - u3_unix_release(pir_u->pax_c); -} diff --git a/pkg/hair/notes/c/walk.c b/pkg/hair/notes/c/walk.c deleted file mode 100644 index e3af728b2..000000000 --- a/pkg/hair/notes/c/walk.c +++ /dev/null @@ -1,334 +0,0 @@ -/* vere/walk.c -** -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include "vere/vere.h" - - /* |% - ** ++ arch :: fs node - ** $% [& p=@uvI q=*] :: file, hash/data - ** [| p=(map ,@ta arch)] :: directory - ** == :: - ** -- - */ - -#if 0 -static u3_noun -_walk_ok(u3_noun nod) -{ - u3_noun don = u3n_mung(u3k(u2A->toy.arch), u3k(nod)); - - if ( c3n == u3_sing(nod, don) ) { - c3_assert(0); - } - u3z(don); - return nod; -} -#endif - -/* u3_walk_safe(): load file or 0. -*/ -u3_noun -u3_walk_safe(c3_c* pas_c) -{ - struct stat buf_b; - c3_i fid_i = open(pas_c, O_RDONLY, 0644); - c3_w fln_w, red_w; - c3_y* pad_y; - - if ( (fid_i < 0) || (fstat(fid_i, &buf_b) < 0) ) { - // u3l_log("%s: %s\n", pas_c, strerror(errno)); - return 0; - } - fln_w = buf_b.st_size; - pad_y = c3_malloc(buf_b.st_size); - - red_w = read(fid_i, pad_y, fln_w); - close(fid_i); - - if ( fln_w != red_w ) { - free(pad_y); - return 0; - } - else { - u3_noun pad = u3i_bytes(fln_w, (c3_y *)pad_y); - free(pad_y); - - return pad; - } -} - -/* u3_walk_load(): load file or bail. -*/ -u3_noun -u3_walk_load(c3_c* pas_c) -{ - struct stat buf_b; - c3_i fid_i = open(pas_c, O_RDONLY, 0644); - c3_w fln_w, red_w; - c3_y* pad_y; - - if ( (fid_i < 0) || (fstat(fid_i, &buf_b) < 0) ) { - u3l_log("%s: %s\n", pas_c, strerror(errno)); - return u3m_bail(c3__fail); - } - fln_w = buf_b.st_size; - pad_y = c3_malloc(buf_b.st_size); - - red_w = read(fid_i, pad_y, fln_w); - close(fid_i); - - if ( fln_w != red_w ) { - free(pad_y); - return u3m_bail(c3__fail); - } - else { - u3_noun pad = u3i_bytes(fln_w, (c3_y *)pad_y); - free(pad_y); - - return pad; - } -} - -/* _walk_mkdirp(): recursively make directories in pax at bas_c (RETAIN) -*/ -static void -_walk_mkdirp(c3_c* bas_c, u3_noun pax) -{ - c3_c* pax_c; - c3_y* waq_y; - c3_w pax_w, fas_w, len_w; - - if ( u3_nul == pax ) { - return; - } - - pax_w = u3r_met(3, u3h(pax)); - fas_w = strlen(bas_c); - len_w = 1 + fas_w + pax_w; - - pax_c = c3_malloc(1 + len_w); - strncpy(pax_c, bas_c, len_w); - pax_c[fas_w] = '/'; - waq_y = (void*)(1 + pax_c + fas_w); - u3r_bytes(0, pax_w, waq_y, u3h(pax)); - pax_c[len_w] = '\0'; - - if ( 0 != mkdir(pax_c, 0755) && EEXIST != errno ) { - u3l_log("error mkdiring %s: %s\n", pax_c, strerror(errno)); - u3m_bail(c3__fail); - } - - _walk_mkdirp(pax_c, u3t(pax)); - free(pax_c); -} - -/* u3_walk_save(): save file or bail. -*/ -void -u3_walk_save(c3_c* pas_c, u3_noun tim, u3_atom pad, c3_c* bas_c, u3_noun pax) -{ - c3_i fid_i = open(pas_c, O_WRONLY | O_CREAT | O_TRUNC, 0666); - c3_w fln_w, rit_w; - c3_y* pad_y; - - if ( fid_i < 0 ) { - if ( ENOENT == errno && u3_nul != pax ) { - _walk_mkdirp(bas_c, pax); - return u3_walk_save(pas_c, tim, pad, 0, u3_nul); - } - - u3l_log("%s: %s\n", pas_c, strerror(errno)); - u3m_bail(c3__fail); - } - - fln_w = u3r_met(3, pad); - pad_y = c3_malloc(fln_w); - u3r_bytes(0, fln_w, pad_y, pad); - u3z(pad); - u3z(pax); - - rit_w = write(fid_i, pad_y, fln_w); - close(fid_i); - free(pad_y); - - if ( rit_w != fln_w ) { - u3l_log("%s: %s\n", pas_c, strerror(errno)); - u3m_bail(c3__fail); - } - - if ( 0 != tim ) { - struct timeval tim_tv[2]; - - u3_time_out_tv(&tim_tv[0], u3k(tim)); - u3_time_out_tv(&tim_tv[1], tim); - - utimes(pas_c, tim_tv); - } -} - -/* _walk_in(): inner loop of _walk(), producing map. -*/ -static u3_noun -_walk_in(const c3_c* dir_c, c3_w len_w) -{ - DIR* dir_d = opendir(dir_c); - u3_noun map = u3_nul; - - if ( !dir_d ) { - return u3_nul; - } - else while ( 1 ) { - struct dirent ent_n; - struct dirent* out_n; - - if ( u3_readdir_r(dir_d, &ent_n, &out_n) != 0 ) { - u3l_log("%s: %s\n", dir_c, strerror(errno)); - break; - } - else if ( !out_n ) { - break; - } - else if ( !strcmp(out_n->d_name, ".") || - !strcmp(out_n->d_name, "..") || - ('~' == out_n->d_name[0]) || - ('.' == out_n->d_name[0]) ) // XX restricts some spans - { - continue; - } - else { - c3_c* fil_c = out_n->d_name; - c3_w lef_w = len_w + 1 + strlen(fil_c); - c3_c* pat_c = c3_malloc(lef_w + 1); - struct stat buf_b; - - strncpy(pat_c, dir_c, lef_w); - pat_c[len_w] = '/'; - strncpy(pat_c + len_w + 1, fil_c, lef_w); - pat_c[lef_w] = '\0'; - - if ( 0 != stat(pat_c, &buf_b) ) { - free(pat_c); - } else { - u3_noun tim = c3_stat_mtime(&buf_b); - - if ( !S_ISDIR(buf_b.st_mode) ) { - c3_c* dot_c = strrchr(fil_c, '.'); - c3_c* nam_c = strdup(fil_c); - c3_c* ext_c = strdup(dot_c + 1); - - nam_c[dot_c - fil_c] = 0; - { - u3_noun nam = u3i_string(nam_c); - u3_noun ext = u3i_string(ext_c); - u3_noun get = u3kdb_get(u3k(map), u3k(nam)); - u3_noun dat = u3_walk_load(pat_c); - u3_noun hax; - - if ( !strcmp("noun", ext_c) ) { - dat = u3ke_cue(dat); - } - hax = u3do("sham", u3k(dat)); - if ( u3_none == get ) { get = u3_nul; } - - get = u3kdb_put(get, ext, u3nt(c3y, hax, dat)); - map = u3kdb_put(map, nam, u3nc(c3n, get)); - } - free(nam_c); - free(ext_c); - } - else { - u3_noun dir = _walk_in(pat_c, lef_w); - - if ( u3_nul != dir ) { - map = u3kdb_put - (map, u3i_string(fil_c), u3nc(c3n, dir)); - } - else u3z(tim); - } - free(pat_c); - } - } - } - closedir(dir_d); - return map; -} - -/* u3_walk(): traverse `dir_c` to produce an arch, updating `old`. -*/ -u3_noun -u3_walk(const c3_c* dir_c, u3_noun old) -{ - // XX - obviously, cheaper to update old data. - u3z(old); - { - struct stat buf_b; - - if ( 0 != stat(dir_c, &buf_b) ) { - u3l_log("can't stat %s\n", dir_c); - // return u3m_bail(c3__fail); - c3_assert(0); - } - else { - return u3nc(c3n, - _walk_in(dir_c, strlen(dir_c))); - } - } -} - -/* u3_path(): C unix path in computer for file or directory. -*/ -c3_c* -u3_path(c3_o fyl, u3_noun pax) -{ - c3_w len_w; - c3_c *pas_c; - - // measure - // - len_w = strlen(u3_Local); - { - u3_noun wiz = pax; - - while ( u3_nul != wiz ) { - len_w += (1 + u3r_met(3, u3h(wiz))); - wiz = u3t(wiz); - } - } - - // cut - // - pas_c = c3_malloc(len_w + 1); - strncpy(pas_c, u3_Local, len_w); - pas_c[len_w] = '\0'; - { - u3_noun wiz = pax; - c3_c* waq_c = (pas_c + strlen(pas_c)); - - while ( u3_nul != wiz ) { - c3_w tis_w = u3r_met(3, u3h(wiz)); - - if ( (c3y == fyl) && (u3_nul == u3t(wiz)) ) { - *waq_c++ = '.'; - } else *waq_c++ = '/'; - - u3r_bytes(0, tis_w, (c3_y*)waq_c, u3h(wiz)); - waq_c += tis_w; - - wiz = u3t(wiz); - } - *waq_c = 0; - } - u3z(pax); - return pas_c; -} diff --git a/pkg/hair/notes/c/worker.c b/pkg/hair/notes/c/worker.c deleted file mode 100644 index 1a37ca775..000000000 --- a/pkg/hair/notes/c/worker.c +++ /dev/null @@ -1,947 +0,0 @@ -/* worker/main.c -** -** the main loop of a worker process. -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "all.h" -#include - - typedef struct _u3_worker { - c3_w len_w; // boot sequence length - u3_noun roe; // lifecycle formulas - c3_d sen_d; // last event requested - c3_d dun_d; // last event processed - c3_l mug_l; // hash of state - c3_d key_d[4]; // disk key - u3_moat inn_u; // message input - u3_mojo out_u; // message output - c3_c* dir_c; // execution directory (pier) - } u3_worker; - static u3_worker u3V; - -/* -:: worker to daemon protocol -:: -|% -:: +plea: from worker to daemon -:: -+$ plea - $% :: status on startup - :: - $: %play - $= p - :: ~ if no snapshot - :: - %- unit - :: p: event number expected - :: q: mug of kernel - :: r: identity, fake flag - :: - [p=@ q=@ r=[our=@p fak=?]] - == - :: event executed unchanged (in response to %work) - :: - $: %done - :: p: event number - :: q: mug of kernel - :: r: effects - :: - [p=@ q=@ r=(list ovum)] - == - :: replace event and retry (in response to %work) - :: - $: %work - :: p: event number - :: q: mug of kernel - :: r: replacement event (at date) - :: - [p=@ q=@ r=(pair date ovum)] - == - :: sends a line to stderr while computing event - :: - $: %stdr - :: p: event number - :: q: output cord - :: - [p=@ q=cord] - == - :: send slog hint while computing event - :: - $: %slog - :: p: event number - :: q: priority - :: r: output tank - :: - [p=@ q=@ r=tank] - == == -:: +writ: from daemon to worker -:: -+$ writ - $% :: prepare to boot - :: - :: p: identity - :: q: fake? - :: r: number of boot formulas - :: - [%boot p=@p q=? r=@] - :: exit immediately - :: - :: p: exit code - :: - [%exit p=@] - :: save snapshot to disk - :: - :: p: event number - :: - [%save p=@] - :: execute event - :: - $: %work - :: p: event number - :: q: a jammed noun [mug [date ovum]] - :: - [p=@ q=@] - == == --- -*/ - -/* _worker_space(): print n spaces. -*/ -void _worker_space(FILE* fil_u, c3_w n) -{ - for (; n > 0; n--) - (fprintf(fil_u," ")); -} - -/* _worker_print_memory(): print memory amount. -** -** Helper for _worker_prof(), just an un-captioned u3a_print_memory(). -*/ -void -_worker_print_memory(FILE* fil_u, c3_w wor_w) -{ - c3_w byt_w = (wor_w * 4); - c3_w gib_w = (byt_w / 1000000000); - c3_w mib_w = (byt_w % 1000000000) / 1000000; - c3_w kib_w = (byt_w % 1000000) / 1000; - c3_w bib_w = (byt_w % 1000); - - if ( gib_w ) { - (fprintf(fil_u, "GB/%d.%03d.%03d.%03d\r\n", - gib_w, mib_w, kib_w, bib_w)); - } - else if ( mib_w ) { - (fprintf(fil_u, "MB/%d.%03d.%03d\r\n", mib_w, kib_w, bib_w)); - } - else if ( kib_w ) { - (fprintf(fil_u, "KB/%d.%03d\r\n", kib_w, bib_w)); - } - else { - (fprintf(fil_u, "B/%d\r\n", bib_w)); - } -} - -/* _worker_prof(): print memory profile. RETAIN. -*/ -c3_w -_worker_prof(FILE* fil_u, c3_w den, u3_noun mas) -{ - c3_w tot_w = 0; - u3_noun h_mas, t_mas; - - if ( c3n == u3r_cell(mas, &h_mas, &t_mas) ) { - _worker_space(fil_u, den); - fprintf(fil_u, "mistyped mass\r\n"); - return tot_w; - } - else if ( _(u3du(h_mas)) ) { - _worker_space(fil_u, den); - fprintf(fil_u, "mistyped mass head\r\n"); - { - c3_c* lab_c = u3m_pretty(h_mas); - fprintf(fil_u, "h_mas: %s", lab_c); - free(lab_c); - } - return tot_w; - } - else { - _worker_space(fil_u, den); - - { - c3_c* lab_c = u3m_pretty(h_mas); - fprintf(fil_u, "%s: ", lab_c); - free(lab_c); - } - - u3_noun it_mas, tt_mas; - - if ( c3n == u3r_cell(t_mas, &it_mas, &tt_mas) ) { - fprintf(fil_u, "mistyped mass tail\r\n"); - return tot_w; - } - else if ( c3y == it_mas ) { - tot_w += u3a_mark_noun(tt_mas); - _worker_print_memory(fil_u, tot_w); - -#if 1 - /* The basic issue here is that tt_mas is included in .sac - * (the whole profile), so they can't both be roots in the - * normal sense. When we mark .sac later on, we want tt_mas - * to appear unmarked, but its children should be already - * marked. - */ - if ( _(u3a_is_dog(tt_mas)) ) { - u3a_box* box_u = u3a_botox(u3a_to_ptr(tt_mas)); -#ifdef U3_MEMORY_DEBUG - if ( 1 == box_u->eus_w ) { - box_u->eus_w = 0xffffffff; - } - else { - box_u->eus_w -= 1; - } -#else - if ( -1 == (c3_w)box_u->use_w ) { - box_u->use_w = 0x80000000; - } - else { - box_u->use_w += 1; - } -#endif - } -#endif - - return tot_w; - } - else if ( c3n == it_mas ) { - fprintf(fil_u, "\r\n"); - - while ( _(u3du(tt_mas)) ) { - tot_w += _worker_prof(fil_u, den+2, u3h(tt_mas)); - tt_mas = u3t(tt_mas); - } - - _worker_space(fil_u, den); - fprintf(fil_u, "--"); - _worker_print_memory(fil_u, tot_w); - - return tot_w; - - } - else { - _worker_space(fil_u, den); - fprintf(fil_u, "mistyped (strange) mass tail\r\n"); - return tot_w; - } - } -} - -/* _worker_grab(): garbage collect, checking for profiling. RETAIN. -*/ -static void -_worker_grab(u3_noun sac, u3_noun ovo, u3_noun vir) -{ - if ( u3_nul == sac) { - if ( u3C.wag_w & (u3o_debug_ram | u3o_check_corrupt) ) { - u3m_grab(sac, ovo, vir, u3_none); - } - } - else { - c3_w usr_w = 0, man_w = 0, sac_w = 0, ova_w = 0, roe_w = 0, vir_w = 0; - - FILE* fil_u; - -#ifdef U3_MEMORY_LOG - { - u3_noun wen = u3dc("scot", c3__da, u3k(u3A->now)); - c3_c* wen_c = u3r_string(wen); - - c3_c nam_c[2048]; - snprintf(nam_c, 2048, "%s/.urb/put/mass", u3P.dir_c); - - struct stat st; - if ( -1 == stat(nam_c, &st) ) { - mkdir(nam_c, 0700); - } - - c3_c man_c[2048]; - snprintf(man_c, 2048, "%s/%s.txt", nam_c, wen_c); - - fil_u = fopen(man_c, "w"); - fprintf(fil_u, "%s\r\n", wen_c); - - free(wen_c); - u3z(wen); - } -#else - { - fil_u = stderr; - } -#endif - - c3_assert( u3R == &(u3H->rod_u) ); - - fprintf(fil_u, "\r\n"); - usr_w = _worker_prof(fil_u, 0, sac); - u3a_print_memory(fil_u, "total userspace", usr_w); - - man_w = u3m_mark(fil_u); - - sac_w = u3a_mark_noun(sac); - u3a_print_memory(fil_u, "space profile", sac_w); - - ova_w = u3a_mark_noun(ovo); - u3a_print_memory(fil_u, "event", ova_w); - - roe_w = u3a_mark_noun(u3V.roe); - u3a_print_memory(fil_u, "lifecycle events", roe_w); - - vir_w = u3a_mark_noun(vir); - u3a_print_memory(fil_u, "effects", vir_w); - - u3a_print_memory(fil_u, "total marked", usr_w + man_w + sac_w + ova_w + vir_w); - - u3a_print_memory(fil_u, "sweep", u3a_sweep()); - -#ifdef U3_MEMORY_LOG - { - fclose(fil_u); - } -#endif - } -} - -/* _worker_fail(): failure stub. -*/ -static void -_worker_fail(void* vod_p, const c3_c* wut_c) -{ - u3l_log("work: fail: %s\r\n", wut_c); - exit(1); -} - -/* _worker_send(): send result back to daemon. -*/ -static void -_worker_send(u3_noun job) -{ - u3_newt_write(&u3V.out_u, u3ke_jam(job), 0); -} - -/* _worker_send_replace(): send replacement job back to daemon. -*/ -static void -_worker_send_replace(c3_d evt_d, u3_noun job) -{ - u3l_log("worker_send_replace %" PRIu64 " %s\r\n", - evt_d, - u3r_string(u3h(u3t(u3t(job))))); - - _worker_send(u3nt(c3__work, - u3i_chubs(1, &evt_d), - u3ke_jam(u3nc(u3V.mug_l, job)))); -} - -/* _worker_send_complete(): report completion. -*/ -static void -_worker_send_complete(u3_noun vir) -{ - _worker_send(u3nq(c3__done, - u3i_chubs(1, &u3V.dun_d), - u3V.mug_l, - vir)); -} - -/* _worker_send_stdr(): send stderr output -*/ -static void -_worker_send_stdr(c3_c* str_c) -{ - _worker_send(u3nt(c3__stdr, u3i_chubs(1, &u3V.sen_d), u3i_string(str_c))); -} - -/* _worker_send_slog(): send hint output (hod is [priority tank]). -*/ -static void -_worker_send_slog(u3_noun hod) -{ - _worker_send(u3nt(c3__slog, u3i_chubs(1, &u3V.sen_d), hod)); -} - -/* _worker_lame(): event failed, replace with error event. -*/ -static void -_worker_lame(c3_d evt_d, u3_noun now, u3_noun ovo, u3_noun why, u3_noun tan) -{ - u3_noun rep; - u3_noun wir, tag, cad; - - u3x_trel(ovo, &wir, &tag, &cad); - - // a deterministic error (%exit) in a network packet (%hear) - // generates a negative-acknowlegement attempt (%hole). - // - // A comment from the old implementation: - // There should be a separate path for crypto failures, - // to prevent timing attacks, but isn't right now. To deal - // with a crypto failure, just drop the packet. - // - if ( (c3__hear == tag) && (c3__exit == why) ) { - rep = u3nt(u3k(wir), c3__hole, u3k(cad)); - } - // failed event notifications (%crud) are replaced with - // an even more generic notifications, on a generic arvo wire. - // N.B this must not be allowed to fail! - // - // [%warn original-event-tag=@tas combined-trace=(list tank)] - // - else if ( c3__crud == tag ) { - u3_noun lef = u3nc(c3__leaf, u3i_tape("crude crashed!")); - u3_noun nat = u3kb_weld(u3k(u3t(cad)), u3nc(lef, u3k(tan))); - rep = u3nc(u3nt(u3_blip, c3__arvo, u3_nul), - u3nt(c3__warn, u3k(u3h(cad)), nat)); - } - // failed failure failing fails - // - else if ( c3__warn == tag ) { - _worker_fail(0, "%warn replacement event failed"); - c3_assert(0); - } - // failure notifications are sent on the same wire - // - // [%crud event-tag=@tas event-trace=(list tank)] - // - else { - // prepend failure mote to tank - // - u3_noun lef = u3nc(c3__leaf, u3kb_weld(u3i_tape("bail: "), - u3qc_rip(3, why))); - u3_noun nat = u3kb_weld(u3k(tan), u3nc(lef, u3_nul)); - rep = u3nc(u3k(wir), u3nt(c3__crud, u3k(tag), nat)); - } - - _worker_send_replace(evt_d, u3nc(now, rep)); - - u3z(ovo); u3z(why); u3z(tan); -} - -/* _worker_sure(): event succeeded, report completion. -*/ -static void -_worker_sure(u3_noun ovo, u3_noun vir, u3_noun cor) -{ - u3z(u3A->roc); - u3A->roc = cor; - u3A->ent_d = u3V.dun_d; - u3V.mug_l = u3r_mug(u3A->roc); - - u3_noun sac = u3_nul; - - // intercept |mass, observe |reset - // - { - u3_noun riv = vir; - c3_w i_w = 0; - - while ( u3_nul != riv ) { - u3_noun fec = u3t(u3h(riv)); - - // assumes a max of one %mass effect per event - // - if ( c3__mass == u3h(fec) ) { - // save a copy of the %mass data - // - sac = u3k(u3t(fec)); - // replace the %mass data with ~ - // - // For efficient transmission to daemon. - // - riv = u3kb_weld(u3qb_scag(i_w, vir), - u3nc(u3nt(u3k(u3h(u3h(riv))), c3__mass, u3_nul), - u3qb_slag(1 + i_w, vir))); - u3z(vir); - vir = riv; - break; - } - - // reclaim memory from persistent caches on |reset - // - if ( c3__vega == u3h(fec) ) { - u3m_reclaim(); - } - - riv = u3t(riv); - i_w++; - } - } - - // XX this runs on replay too - // - _worker_grab(sac, ovo, vir); - _worker_send_complete(vir); - - u3z(sac); u3z(ovo); -} - -/* _worker_work_live(): apply event. -*/ -static void -_worker_work_live(c3_d evt_d, u3_noun job) -{ - u3_noun now, ovo, gon; - u3_noun last_date; - - c3_assert(evt_d == u3V.dun_d + 1ULL); - u3V.sen_d = evt_d; - - u3x_cell(job, &now, &ovo); - - last_date = u3A->now; - u3A->now = u3k(now); - -#ifdef U3_EVENT_TIME_DEBUG - { - struct timeval b4, f2, d0; - gettimeofday(&b4, 0); - - if ( c3__belt != u3h(u3t(ovo)) ) { - c3_c* txt_c = u3r_string(u3h(u3t(ovo))); - - u3l_log("work: %s (%" PRIu64 ") live\r\n", txt_c, evt_d); - } - } -#endif - - gon = u3m_soft(0, u3v_poke, u3k(ovo)); - -#ifdef U3_EVENT_TIME_DEBUG - { - c3_c* txt_c = u3r_string(u3h(u3t(ovo))); - c3_w ms_w; - c3_w clr_w; - - gettimeofday(&f2, 0); - timersub(&f2, &b4, &d0); - ms_w = (d0.tv_sec * 1000) + (d0.tv_usec / 1000); - clr_w = ms_w > 1000 ? 1 : ms_w < 100 ? 2 : 3; // red, green, yellow - if (c3__belt != u3h(u3t(ovo)) || clr_w != 2) { - u3l_log("\x1b[3%dm%%%s (%" PRIu64 ") %4d.%02dms\x1b[0m\n", - clr_w, txt_c, evt_d, ms_w, - (int) (d0.tv_usec % 1000) / 10); - } - free(txt_c); - } -#endif - - if ( u3_blip != u3h(gon) ) { - // event rejected - // - u3V.sen_d = u3V.dun_d; - // restore previous time - // - u3_noun nex = u3A->now; - u3A->now = last_date; - - u3_noun why, tan; - u3x_cell(gon, &why, &tan); - - u3k(ovo); u3k(why); u3k(tan); - u3z(gon); u3z(job); - - _worker_lame(evt_d, nex, ovo, why, tan); - } - else { - // event accepted - // - u3V.dun_d = u3V.sen_d; - u3z(last_date); - - // vir/(list ovum) list of effects - // cor/arvo arvo core - // - u3_noun vir, cor; - u3x_trel(gon, 0, &vir, &cor); - - u3k(ovo); u3k(vir); u3k(cor); - u3z(gon); u3z(job); - - _worker_sure(ovo, vir, cor); - - // reclaim memory from persistent caches periodically - // - // XX this is a hack to work around the fact that - // the bytecode caches grow rapidly and are not - // able to be simply capped (due to internal posts). - // - if ( 0 == (evt_d % 1000ULL) ) { - u3m_reclaim(); - } - } -} - -/* _worker_work_boot(): apply initial-stage event. -*/ -static void -_worker_work_boot(c3_d evt_d, u3_noun job) -{ - // here we asset on u3V.sen_d, because u3V.dun_d isn't set until - // after u3V.sen_d == u3V.len_w (ie, after the lifecycle evaluation) - // - c3_assert(evt_d == u3V.sen_d + 1ULL); - u3V.sen_d = evt_d; - - u3V.roe = u3nc(job, u3V.roe); - - u3l_log("work: (%" PRIu64 ")| boot\r\n", evt_d); - - if ( u3V.len_w == evt_d ) { - u3_noun eve = u3kb_flop(u3V.roe); - u3V.roe = u3_nul; - - u3l_log("work: (%" PRIu64 ")| pill: %x\r\n", evt_d, u3r_mug(eve)); - - if ( c3n == u3v_boot(eve) ) { - u3l_log("work: boot failed: invalid sequence (from pill)\r\n"); - exit(1); - } - - u3V.dun_d = evt_d; - u3V.mug_l = u3r_mug(u3A->roc); - u3A->ent_d = u3V.dun_d; - - u3l_log("work: (%" PRIu64 ")| core: %x\r\n", evt_d, u3V.mug_l); - } - else { - // prior to the evaluation of the entire lifecycle sequence, - // we simply use the mug of the formula as the kernel mug - // - u3V.mug_l = u3r_mug(job); - } - - _worker_send(u3nq(c3__done, - u3i_chubs(1, &evt_d), - u3V.mug_l, - u3_nul)); -} - -/* _worker_poke_work(): apply event. -*/ -static void -_worker_poke_work(c3_d evt_d, // event number - c3_l mug_l, // mug of state - u3_noun job) // full event -{ - if ( u3C.wag_w & u3o_trace ) { - if ( u3_Host.tra_u.con_w == 0 && u3_Host.tra_u.fun_w == 0 ) { - u3t_trace_open(u3V.dir_c); - } - else if ( u3_Host.tra_u.con_w >= 100000 ) { - u3t_trace_close(); - u3t_trace_open(u3V.dir_c); - } - } - - // Require mugs to match - // - // We use mugs to enforce that %work is always performed against - // the exact kernel we expect it to be. If it isn't, we have either - // event-log corruption or non-determism on replay, or programmer error - // in normal operation. In either case, we immediately exit. - // - if ( u3V.mug_l != mug_l ) { - u3l_log("work: invalid %%work for event %" PRIu64 ".\r\n", evt_d); - u3l_log("work: computed mug is %x but event %" PRIu64 " expected %x.\r\n", - u3V.mug_l, - evt_d, - mug_l); - _worker_fail(0, "bad jar"); - return; - } - - if ( evt_d <= u3V.len_w ) { - c3_c lab_c[8]; - snprintf(lab_c, 8, "boot: %" PRIu64 "", evt_d); - - u3t_event_trace(lab_c, 'B'); - _worker_work_boot(evt_d, job); - u3t_event_trace(lab_c, 'E'); - } - else { - u3_noun wir = u3h(u3t(job)); - u3_noun cad = u3h(u3t(u3t(job))); - - c3_c lab_c[2048]; - snprintf(lab_c, 2048, "event %" PRIu64 ": [%s %s]", evt_d, - u3m_pretty_path(wir), u3m_pretty(cad)); - - u3t_event_trace(lab_c, 'B'); - _worker_work_live(evt_d, job); - u3t_event_trace(lab_c, 'E'); - } -} - -/* _worker_poke_exit(): exit on command. -*/ -static void -_worker_poke_exit(c3_w cod_w) // exit code -{ - if ( u3C.wag_w & u3o_debug_cpu ) { - u3t_damp(); - } - - exit(cod_w); -} - -/* _worker_poke_boot(): prepare to boot. -*/ -static void -_worker_poke_boot(u3_noun who, u3_noun fak, c3_w len_w) -{ - c3_assert( u3_none == u3A->our ); - c3_assert( 0 != len_w ); - - u3A->our = who; - u3A->fak = fak; - u3V.len_w = len_w; -} - -/* _worker_poke(): -*/ -void -_worker_poke(void* vod_p, u3_noun mat) -{ - u3_noun jar = u3ke_cue(mat); - - if ( c3y != u3du(jar) ) { - goto error; - } - else { - switch ( u3h(jar) ) { - default: { - goto error; - } - - case c3__boot: { - u3_noun who, fak, len; - c3_w len_w; - - if ( (c3n == u3r_qual(jar, 0, &who, &fak, &len)) || - (c3n == u3ud(who)) || - (1 < u3r_met(7, who)) || - (c3n == u3ud(fak)) || - (1 < u3r_met(0, fak)) || - (c3n == u3ud(len)) || - (1 < u3r_met(3, len)) ) - { - goto error; - } - - len_w = u3r_word(0, len); - u3k(who); - u3k(fak); - u3z(jar); - - return _worker_poke_boot(who, fak, len_w); - } - - case c3__work: { - u3_noun evt, jammed_entry, mug, job; - c3_d evt_d; - c3_l mug_l; - - if ( (c3n == u3r_trel(jar, 0, &evt, &jammed_entry)) || - (c3n == u3ud(evt)) || - (1 != u3r_met(6, evt)) ) - { - goto error; - } - - u3_noun entry = u3qe_cue(jammed_entry); - if ( (c3y != u3du(entry)) || - (c3n == u3r_cell(entry, &mug, &job)) || - (c3n == u3ud(mug)) || - (1 < u3r_met(5, mug)) ) { - goto error; - } - - evt_d = u3r_chub(0, evt); - mug_l = u3r_word(0, mug); - u3k(job); - u3z(entry); - u3z(jar); - - return _worker_poke_work(evt_d, mug_l, job); - } - - case c3__exit: { - u3_noun cod; - c3_w cod_w; - - if ( (c3n == u3r_cell(jar, 0, &cod)) || - (c3n == u3ud(cod)) || - (1 < u3r_met(3, cod)) ) - { - goto error; - } - - cod_w = u3r_word(0, cod); - u3z(jar); - - return _worker_poke_exit(cod_w); - } - - case c3__save: { - u3_noun evt; - c3_d evt_d; - - if ( (c3n == u3r_cell(jar, 0, &evt)) || - (c3n == u3ud(evt)) ) - { - goto error; - } - - evt_d = u3r_chub(0, evt); - u3z(jar); - - c3_assert( evt_d == u3V.dun_d ); - - return u3e_save(); - } - } - } - - error: { - u3z(jar); - _worker_fail(0, "bad jar"); - } -} - -/* u3_worker_boot(): send startup message to manager. -*/ -void -u3_worker_boot(void) -{ - c3_d nex_d = 1ULL; - u3_noun dat = u3_nul; - - if ( u3_none != u3A->our ) { - u3V.mug_l = u3r_mug(u3A->roc); - nex_d = u3V.dun_d + 1ULL; - dat = u3nc(u3_nul, u3nt(u3i_chubs(1, &nex_d), - u3V.mug_l, - u3nc(u3k(u3A->our), u3k(u3A->fak)))); - - // disable hashboard for fake ships - // - if ( c3y == u3A->fak ) { - u3C.wag_w |= u3o_hashless; - } - - // no boot sequence expected - // - u3V.len_w = 0; - } - - u3l_log("work: play %" PRIu64 "\r\n", nex_d); - - _worker_send(u3nc(c3__play, dat)); -} - -/* main(): main() when run as urbit-worker -*/ -c3_i -main(c3_i argc, c3_c* argv[]) -{ - uv_loop_t* lup_u = uv_default_loop(); - c3_c* dir_c = argv[1]; - c3_c* key_c = argv[2]; - c3_c* wag_c = argv[3]; - - c3_assert(4 == argc); - - memset(&u3V, 0, sizeof(u3V)); - memset(&u3_Host.tra_u, 0, sizeof(u3_Host.tra_u)); - - /* load passkey - */ - { - sscanf(key_c, "%" PRIx64 ":%" PRIx64 ":%" PRIx64 ":%" PRIx64 "", - &u3V.key_d[0], - &u3V.key_d[1], - &u3V.key_d[2], - &u3V.key_d[3]); - } - - /* load runtime config - */ - { - sscanf(wag_c, "%" SCNu32, &u3C.wag_w); - } - - /* load pier directory - */ - { - u3V.dir_c = strdup(dir_c); - } - - /* boot image - */ - { - u3V.sen_d = u3V.dun_d = u3m_boot(dir_c); - u3C.stderr_log_f = _worker_send_stdr; - u3C.slog_f = _worker_send_slog; - } - - /* configure pipe to daemon process - */ - { - c3_i err_i; - - err_i = uv_pipe_init(lup_u, &u3V.inn_u.pyp_u, 0); - c3_assert(!err_i); - uv_pipe_open(&u3V.inn_u.pyp_u, 0); - - err_i = uv_pipe_init(lup_u, &u3V.out_u.pyp_u, 0); - c3_assert(!err_i); - uv_pipe_open(&u3V.out_u.pyp_u, 1); - } - - /* set up writing - */ - u3V.out_u.bal_f = _worker_fail; - - /* start reading - */ - u3V.inn_u.vod_p = &u3V; - u3V.inn_u.pok_f = _worker_poke; - u3V.inn_u.bal_f = _worker_fail; - - u3_newt_read(&u3V.inn_u); - - /* send start request - */ - u3_worker_boot(); - - /* enter loop - */ - uv_run(lup_u, UV_RUN_DEFAULT); - return 0; -} diff --git a/pkg/hair/.gitignore b/pkg/hs-hoon/.gitignore similarity index 100% rename from pkg/hair/.gitignore rename to pkg/hs-hoon/.gitignore diff --git a/pkg/hoon/lib/Language/Attila/AST/Parser.hs b/pkg/hs-hoon/lib/Language/Attila/AST/Parser.hs similarity index 100% rename from pkg/hoon/lib/Language/Attila/AST/Parser.hs rename to pkg/hs-hoon/lib/Language/Attila/AST/Parser.hs diff --git a/pkg/hoon/lib/Language/Attila/AST/Types.hs b/pkg/hs-hoon/lib/Language/Attila/AST/Types.hs similarity index 100% rename from pkg/hoon/lib/Language/Attila/AST/Types.hs rename to pkg/hs-hoon/lib/Language/Attila/AST/Types.hs diff --git a/pkg/hoon/lib/Language/Attila/IR.hs b/pkg/hs-hoon/lib/Language/Attila/IR.hs similarity index 100% rename from pkg/hoon/lib/Language/Attila/IR.hs rename to pkg/hs-hoon/lib/Language/Attila/IR.hs diff --git a/pkg/hoon/lib/Language/Hoon/AST/Parser.hs b/pkg/hs-hoon/lib/Language/Hoon/AST/Parser.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/AST/Parser.hs rename to pkg/hs-hoon/lib/Language/Hoon/AST/Parser.hs diff --git a/pkg/hoon/lib/Language/Hoon/AST/Types.hs b/pkg/hs-hoon/lib/Language/Hoon/AST/Types.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/AST/Types.hs rename to pkg/hs-hoon/lib/Language/Hoon/AST/Types.hs diff --git a/pkg/hoon/lib/Language/Hoon/Desugar.hs b/pkg/hs-hoon/lib/Language/Hoon/Desugar.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/Desugar.hs rename to pkg/hs-hoon/lib/Language/Hoon/Desugar.hs diff --git a/pkg/hoon/lib/Language/Hoon/IR/Desugar.hs b/pkg/hs-hoon/lib/Language/Hoon/IR/Desugar.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/IR/Desugar.hs rename to pkg/hs-hoon/lib/Language/Hoon/IR/Desugar.hs diff --git a/pkg/hoon/lib/Language/Hoon/IR/Infer.hs b/pkg/hs-hoon/lib/Language/Hoon/IR/Infer.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/IR/Infer.hs rename to pkg/hs-hoon/lib/Language/Hoon/IR/Infer.hs diff --git a/pkg/hoon/lib/Language/Hoon/IR/Ty.hs b/pkg/hs-hoon/lib/Language/Hoon/IR/Ty.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/IR/Ty.hs rename to pkg/hs-hoon/lib/Language/Hoon/IR/Ty.hs diff --git a/pkg/hoon/lib/Language/Hoon/IR/Wing.hs b/pkg/hs-hoon/lib/Language/Hoon/IR/Wing.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/IR/Wing.hs rename to pkg/hs-hoon/lib/Language/Hoon/IR/Wing.hs diff --git a/pkg/hoon/lib/Language/Hoon/LL/Gen.hs b/pkg/hs-hoon/lib/Language/Hoon/LL/Gen.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/LL/Gen.hs rename to pkg/hs-hoon/lib/Language/Hoon/LL/Gen.hs diff --git a/pkg/hoon/lib/Language/Hoon/LL/Run.hs b/pkg/hs-hoon/lib/Language/Hoon/LL/Run.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/LL/Run.hs rename to pkg/hs-hoon/lib/Language/Hoon/LL/Run.hs diff --git a/pkg/hoon/lib/Language/Hoon/LL/Types.hs b/pkg/hs-hoon/lib/Language/Hoon/LL/Types.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/LL/Types.hs rename to pkg/hs-hoon/lib/Language/Hoon/LL/Types.hs diff --git a/pkg/hoon/lib/Language/Hoon/Nock/Types.hs b/pkg/hs-hoon/lib/Language/Hoon/Nock/Types.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/Nock/Types.hs rename to pkg/hs-hoon/lib/Language/Hoon/Nock/Types.hs diff --git a/pkg/hoon/lib/Language/Hoon/SpecToBunt.hs b/pkg/hs-hoon/lib/Language/Hoon/SpecToBunt.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/SpecToBunt.hs rename to pkg/hs-hoon/lib/Language/Hoon/SpecToBunt.hs diff --git a/pkg/hoon/lib/Language/Hoon/SpecToMold.hs b/pkg/hs-hoon/lib/Language/Hoon/SpecToMold.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/SpecToMold.hs rename to pkg/hs-hoon/lib/Language/Hoon/SpecToMold.hs diff --git a/pkg/hoon/lib/Language/Hoon/Types.hs b/pkg/hs-hoon/lib/Language/Hoon/Types.hs similarity index 100% rename from pkg/hoon/lib/Language/Hoon/Types.hs rename to pkg/hs-hoon/lib/Language/Hoon/Types.hs diff --git a/pkg/hoon/package.yaml b/pkg/hs-hoon/package.yaml similarity index 100% rename from pkg/hoon/package.yaml rename to pkg/hs-hoon/package.yaml diff --git a/pkg/hoon/.gitignore b/pkg/hs-urbit/.gitignore similarity index 100% rename from pkg/hoon/.gitignore rename to pkg/hs-urbit/.gitignore diff --git a/pkg/hair/lib/Arvo.hs b/pkg/hs-urbit/lib/Arvo.hs similarity index 100% rename from pkg/hair/lib/Arvo.hs rename to pkg/hs-urbit/lib/Arvo.hs diff --git a/pkg/hair/lib/Data/Noun.hs b/pkg/hs-urbit/lib/Data/Noun.hs similarity index 100% rename from pkg/hair/lib/Data/Noun.hs rename to pkg/hs-urbit/lib/Data/Noun.hs diff --git a/pkg/hair/lib/Data/Noun/Atom.hs b/pkg/hs-urbit/lib/Data/Noun/Atom.hs similarity index 100% rename from pkg/hair/lib/Data/Noun/Atom.hs rename to pkg/hs-urbit/lib/Data/Noun/Atom.hs diff --git a/pkg/hair/lib/Data/Noun/Jam.hs b/pkg/hs-urbit/lib/Data/Noun/Jam.hs similarity index 100% rename from pkg/hair/lib/Data/Noun/Jam.hs rename to pkg/hs-urbit/lib/Data/Noun/Jam.hs diff --git a/pkg/hair/lib/Data/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs similarity index 100% rename from pkg/hair/lib/Data/Noun/Jam/Fast.hs rename to pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs diff --git a/pkg/hair/lib/Data/Noun/Pill.hs b/pkg/hs-urbit/lib/Data/Noun/Pill.hs similarity index 100% rename from pkg/hair/lib/Data/Noun/Pill.hs rename to pkg/hs-urbit/lib/Data/Noun/Pill.hs diff --git a/pkg/hair/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Data/Noun/Poet.hs similarity index 100% rename from pkg/hair/lib/Data/Noun/Poet.hs rename to pkg/hs-urbit/lib/Data/Noun/Poet.hs diff --git a/pkg/hair/lib/Data/Noun/Zip.hs b/pkg/hs-urbit/lib/Data/Noun/Zip.hs similarity index 100% rename from pkg/hair/lib/Data/Noun/Zip.hs rename to pkg/hs-urbit/lib/Data/Noun/Zip.hs diff --git a/pkg/hair/lib/NockRTS/Noun.hs b/pkg/hs-urbit/lib/NockRTS/Noun.hs similarity index 100% rename from pkg/hair/lib/NockRTS/Noun.hs rename to pkg/hs-urbit/lib/NockRTS/Noun.hs diff --git a/pkg/hair/lib/Urbit/Behn.hs b/pkg/hs-urbit/lib/Urbit/Behn.hs similarity index 100% rename from pkg/hair/lib/Urbit/Behn.hs rename to pkg/hs-urbit/lib/Urbit/Behn.hs diff --git a/pkg/hair/lib/Urbit/CTTP.hs b/pkg/hs-urbit/lib/Urbit/CTTP.hs similarity index 100% rename from pkg/hair/lib/Urbit/CTTP.hs rename to pkg/hs-urbit/lib/Urbit/CTTP.hs diff --git a/pkg/hair/lib/Urbit/Time.hs b/pkg/hs-urbit/lib/Urbit/Time.hs similarity index 100% rename from pkg/hair/lib/Urbit/Time.hs rename to pkg/hs-urbit/lib/Urbit/Time.hs diff --git a/pkg/hair/lib/Urbit/Timer.hs b/pkg/hs-urbit/lib/Urbit/Timer.hs similarity index 100% rename from pkg/hair/lib/Urbit/Timer.hs rename to pkg/hs-urbit/lib/Urbit/Timer.hs diff --git a/pkg/hair/lib/Vere.hs b/pkg/hs-urbit/lib/Vere.hs similarity index 100% rename from pkg/hair/lib/Vere.hs rename to pkg/hs-urbit/lib/Vere.hs diff --git a/pkg/hair/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs similarity index 100% rename from pkg/hair/lib/Vere/Http.hs rename to pkg/hs-urbit/lib/Vere/Http.hs diff --git a/pkg/hair/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs similarity index 100% rename from pkg/hair/lib/Vere/Http/Client.hs rename to pkg/hs-urbit/lib/Vere/Http/Client.hs diff --git a/pkg/hair/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs similarity index 100% rename from pkg/hair/lib/Vere/Http/Server.hs rename to pkg/hs-urbit/lib/Vere/Http/Server.hs diff --git a/pkg/hair/lib/Vere/Isle.hs b/pkg/hs-urbit/lib/Vere/Isle.hs similarity index 100% rename from pkg/hair/lib/Vere/Isle.hs rename to pkg/hs-urbit/lib/Vere/Isle.hs diff --git a/pkg/hair/lib/Vere/Isle/Util.hs b/pkg/hs-urbit/lib/Vere/Isle/Util.hs similarity index 100% rename from pkg/hair/lib/Vere/Isle/Util.hs rename to pkg/hs-urbit/lib/Vere/Isle/Util.hs diff --git a/pkg/hair/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs similarity index 100% rename from pkg/hair/lib/Vere/Log.hs rename to pkg/hs-urbit/lib/Vere/Log.hs diff --git a/pkg/hair/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs similarity index 100% rename from pkg/hair/lib/Vere/Pier.hs rename to pkg/hs-urbit/lib/Vere/Pier.hs diff --git a/pkg/hair/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs similarity index 100% rename from pkg/hair/lib/Vere/Pier/Types.hs rename to pkg/hs-urbit/lib/Vere/Pier/Types.hs diff --git a/pkg/hair/lib/Vere/Worker.hs b/pkg/hs-urbit/lib/Vere/Worker.hs similarity index 100% rename from pkg/hair/lib/Vere/Worker.hs rename to pkg/hs-urbit/lib/Vere/Worker.hs diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml new file mode 100644 index 000000000..e15747f0c --- /dev/null +++ b/pkg/hs-urbit/package.yaml @@ -0,0 +1,90 @@ +name: urbit +version: 0.1.0 +license: AGPL-3.0-only + +library: + source-dirs: lib + ghc-options: + - -fwarn-incomplete-patterns + - -O2 + +dependencies: + - async + - base + - bytestring + - case-insensitive + - classy-prelude + - containers + - data-fix + - extra + - flat + - ghc-prim + - hashtables + - http-client + - http-types + - integer-gmp + - largeword + - lens + - lmdb + - megaparsec + - mtl + - multimap + - para + - pretty-show + - primitive + - process + - QuickCheck + - sdl2 + - sdl2-image + - semigroups + - smallcheck + - stm + - stm-chans + - tasty + - tasty-quickcheck + - tasty-th + - text + - these + - time + - transformers + - unordered-containers + - vector + - wai + - warp + - warp-tls + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveDataTypeable + - DeriveFoldable + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - EmptyDataDecls + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - NoImplicitPrelude + - NumericUnderscores + - OverloadedStrings + - PartialTypeSignatures + - QuasiQuotes + - Rank2Types + - RankNTypes + - RecordWildCards + - StandaloneDeriving + - ScopedTypeVariables + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - UnicodeSyntax + - ViewPatterns diff --git a/pkg/hs-vere/.gitignore b/pkg/hs-vere/.gitignore new file mode 100644 index 000000000..c99ca9e13 --- /dev/null +++ b/pkg/hs-vere/.gitignore @@ -0,0 +1,2 @@ +.stack-work +*.cabal diff --git a/pkg/hair/app/test/Main.hs b/pkg/hs-vere/app/test/Main.hs similarity index 100% rename from pkg/hair/app/test/Main.hs rename to pkg/hs-vere/app/test/Main.hs diff --git a/pkg/hair/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs similarity index 100% rename from pkg/hair/app/uterm/Main.hs rename to pkg/hs-vere/app/uterm/Main.hs diff --git a/pkg/hair/app/vere/Main.hs b/pkg/hs-vere/app/vere/Main.hs similarity index 100% rename from pkg/hair/app/vere/Main.hs rename to pkg/hs-vere/app/vere/Main.hs diff --git a/pkg/hair/package.yaml b/pkg/hs-vere/package.yaml similarity index 91% rename from pkg/hair/package.yaml rename to pkg/hs-vere/package.yaml index 3516f8379..cbe718f9f 100644 --- a/pkg/hair/package.yaml +++ b/pkg/hs-vere/package.yaml @@ -2,17 +2,11 @@ name: vere version: 0.1.0 license: AGPL-3.0-only -library: - source-dirs: lib - ghc-options: - - -fwarn-incomplete-patterns - - -O2 - executables: test: main: Main.hs source-dirs: app/test - dependencies: ["vere"] + dependencies: ["urbit"] ghc-options: - -threaded - -rtsopts @@ -23,7 +17,7 @@ executables: uterm: main: Main.hs source-dirs: app/uterm - dependencies: ["vere"] + dependencies: ["urbit"] ghc-options: - -threaded - -rtsopts @@ -34,7 +28,7 @@ executables: vere: main: Main.hs source-dirs: app/vere - dependencies: ["vere"] + dependencies: ["urbit"] ghc-options: - -threaded - -rtsopts @@ -44,6 +38,7 @@ executables: dependencies: - async + - urbit - base - bytestring - case-insensitive diff --git a/stack.yaml b/stack.yaml index fe9c2bbee..e81620ad8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,17 +1,15 @@ resolver: lts-13.10 packages: - - pkg/hair - - pkg/hoon - -ghc-options: - vere: "-fobject-code" + - pkg/hs-urbit + - pkg/hs-vere + - pkg/hs-hoon extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 - flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38 -build: - library-profiling: true - executable-profiling: true - executable-stripping: false +# build: +# library-profiling: true +# executable-profiling: true +# executable-stripping: false From 3fd0ab427023fbca36bb697842fcc58469d5f8e5 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 12 Jun 2019 13:47:36 -0700 Subject: [PATCH 064/431] Whatever --- pkg/hs-conq/.gitignore | 2 + pkg/hs-conq/lib/Language/Conq.hs | 455 +++++++++++++++++++++++++++++++ pkg/hs-conq/package.yaml | 80 ++++++ pkg/hs-urbit/lib/Vere/Isle.hs | 133 ++++++--- pkg/hs-urbit/package.yaml | 2 + stack.yaml | 9 + 6 files changed, 648 insertions(+), 33 deletions(-) create mode 100644 pkg/hs-conq/.gitignore create mode 100644 pkg/hs-conq/lib/Language/Conq.hs create mode 100644 pkg/hs-conq/package.yaml diff --git a/pkg/hs-conq/.gitignore b/pkg/hs-conq/.gitignore new file mode 100644 index 000000000..c99ca9e13 --- /dev/null +++ b/pkg/hs-conq/.gitignore @@ -0,0 +1,2 @@ +.stack-work +*.cabal diff --git a/pkg/hs-conq/lib/Language/Conq.hs b/pkg/hs-conq/lib/Language/Conq.hs new file mode 100644 index 000000000..ea13f315e --- /dev/null +++ b/pkg/hs-conq/lib/Language/Conq.hs @@ -0,0 +1,455 @@ +module Language.Conq where + +import ClassyPrelude hiding (pure, (<.>), Left, Right) +import Data.Type.Equality +import Type.Reflection +import Data.Coerce +import GHC.Natural +import Control.Category + +import Data.Bits ((.|.), shiftL, shiftR) +import Text.Show (showString, showParen) + +-------------------------------------------------------------------------------- + +type Tup a b = (a, b) +data Sum a b = L a | R b + deriving (Eq, Ord) + +instance (Show a, Show b) => Show (Sum a b) where + show (L x) = case show x of { "()" → "L"; xs → "L" <> xs } + show (R x) = case show x of { "()" → "R"; xs → "R" <> xs } + +-------------------------------------------------------------------------------- + +data Lit + = Nil + | LTup Lit Lit + | LLef Lit + | LRit Lit + deriving (Eq, Ord) + +instance Show Lit where + show = \case + Nil -> "~" + LTup x y -> "[" <> show x <> " " <> show y <> "]" + LLef Nil -> "1" + LRit Nil -> "0" + LLef l -> " show l <> ">" + LRit r -> " show r <> ">" + +-------------------------------------------------------------------------------- + +class ToLit a where + toLit :: a -> Lit + +instance ToLit () where + toLit () = Nil + +instance (ToLit a, ToLit b) => ToLit (Sum a b) where + toLit (L l) = LLef (toLit l) + toLit (R r) = LRit (toLit r) + +instance (ToLit a, ToLit b) => ToLit (Tup a b) where + toLit (l, r) = LTup (toLit l) (toLit r) + +-------------------------------------------------------------------------------- + +data Exp + = ESubj + | ENull + | EEval + | ELeft + | EWrit + | EHead + | ETail + | EDist + | EWith Exp Exp + | ECons Exp Exp + | ECase Exp Exp + deriving (Eq, Ord) + +instance Show Exp where + showsPrec d = \case + ESubj -> showString "." + ENull -> showString "~" + EEval -> showString "!" + ELeft -> showString "L" + EWrit -> showString "R" + EHead -> showString "-" + ETail -> showString "+" + EDist -> showString "%" + EWith x y -> showsPrec d x . showsPrec d y + ECons x y -> showString "[" + . showsPrec d x + . showString " " + . showsPrec d y + . showString "]" + ECase x y -> showString "<" + . showsPrec d x + . showString " " + . showsPrec d y + . showString ">" + +-------------------------------------------------------------------------------- + +class ToConq a s r where + toConq :: a -> Conq s r + +instance ToConq (Conq s a, Conq a r) s r where + toConq (x,y) = With x y + +instance ToConq (Conq s a, Conq a b, Conq b r) s r where + toConq (x,y,z) = With (toConq (x,y)) z + +instance ToConq (Conq s a, Conq a b, Conq b c, Conq c r) s r where + toConq (x,y,z,p) = With (toConq (x,y,z)) p + +instance ToConq (Conq s a, Conq a b, Conq b c, Conq c d, Conq d r) s r where + toConq (x,y,z,p,q) = With (toConq (x,y,z,p)) q + +-------------------------------------------------------------------------------- + +data Conq s r where + Subj :: Conq s s + Null :: Conq s () + Left :: Conq a (Sum a b) + Writ :: Conq b (Sum a b) + Head :: Conq (Tup a b) a + Tail :: Conq (Tup a b) b + Cons :: Conq s a -> Conq s b -> Conq s (a, b) + Kase :: Conq a r -> Conq b r -> Conq (Sum a b) r + Dist :: Conq (Sum a b,s) (Sum (a,s) (b,s)) + With :: Conq s a -> Conq a r -> Conq s r + Eval :: Conq (a, Conq a r) r + + + + + + + + + -- Case :: Conq (a,s) r -> Conq (b,s) r -> Conq (Sum a b,s) r + +instance Category Conq where + id = Subj + (.) = flip With + +instance Show (Conq s r) where + show c = show (toExp c) + +-------------------------------------------------------------------------------- + +run :: s -> Conq s r -> r +run sut = \case + Null -> () + Subj -> sut + With x y -> run (run sut x) y + Eval -> case sut of (s,f) -> run s f + Cons x y -> (run sut x, run sut y) + Left -> L sut + Writ -> R sut + Head -> fst sut + Tail -> snd sut + Dist -> case sut of { (L l,x) -> L (l,x); (R r,x) -> R (r,x); } + Kase p q -> case sut of { L l -> run l p; R r -> run r q; } + + + + + + +--Case p q -> case sut of (L l,x) -> run (l,x) p +-- (R r,x) -> run (r,x) q + +times :: Int -> Conq s s -> Conq s s +times 0 _ = id +times 1 f = f +times n f = With f (times (n-1) f) + +runTimes :: Int -> s -> Conq s s -> s +runTimes n sut conq = go n + where + go 0 = sut + go 1 = run sut conq + go n = run (go (n-1)) conq + +-------------------------------------------------------------------------------- + +toExp :: Conq s r -> Exp +toExp = \case + Subj -> ESubj + Null -> ENull + Eval -> EEval + Left -> ELeft + Writ -> EWrit + Head -> EHead + Tail -> ETail + Dist -> EDist + Cons x y -> ECons (toExp x) (toExp y) +--Case l r -> ECase (toExp l) (toExp r) + Kase l r -> ECase (toExp l) (toExp r) + With x y -> EWith (toExp x) (toExp y) + +-------------------------------------------------------------------------------- + +fromExp :: forall s r. (Typeable s, Typeable r) => Exp -> Maybe (Conq s r) +fromExp = \case + ESubj -> + case testEquality (typeRep @s) (typeRep @r) of + Just Refl -> Just (coerce Subj) + Nothing -> Nothing + + _ -> + Nothing + +-- Axis Lookup ----------------------------------------------------------------- + +a1 :: Conq a a +a1 = Subj + +a2 :: Conq (Tup a b) a +a2 = Head + +a3 :: Conq (Tup a b) b +a3 = Tail + +a4 :: Conq (Tup (Tup a b) c) a +a4 = Head . Head + +a5 :: Conq (Tup (Tup a b) c) b +a5 = Tail . Head + +a6 :: Conq (Tup a (Tup b c)) b +a6 = Head . Tail + +a7 :: Conq (Tup a (Tup b c)) c +a7 = Tail . Tail + +a8 :: Conq (((a, b), c), d) a +a8 = Head . Head . Head + + +-- Eat Operations -------------------------------------------------------------- + +nothing :: Conq s (Sum () a) +nothing = Left . Null + +just :: Conq a (Sum () a) +just = Writ + +case' :: Conq (a,s) r -> Conq (b,s) r -> Conq (Sum a b,s) r +case' x y = Kase x y . Dist + +previewLeft :: Conq (Sum a b) (Sum () a) +previewLeft = Kase just nothing + +previewWrit :: Conq (Sum a b) (Sum () b) +previewWrit = Kase nothing just + + +-- Pair Operations ------------------------------------------------------------- + +curry' :: Conq (a, b) c -> Conq s a -> Conq s b -> Conq s c +curry' f x y = With (Cons x y) f + +both :: Conq a b -> Conq (a, a) (b, b) +both x = Cons (With Head x) (With Tail x) + +dub_equal :: Conq (a, a) Bit -> Conq ((a, a), (a, a)) Bit +dub_equal cmp = With results and' + where + results = Cons (With (both Head) cmp) (With (both Tail) cmp) + +dub_test :: Conq a Bit -> Conq (a, a) Bit +dub_test test = curry' and' (With Head test) (With Tail test) + +dub_inc :: Conq a a -> Conq a Bit -> Conq (a, a) (a, a) +dub_inc inc null = With bump_low (if' low_zero bump_hig id) + where + bump_low = Cons (With Head inc) Tail + bump_hig = Cons Head (With Tail inc) + low_zero = With Head null + +bit :: Int -> Bit +bit n = runTimes n val_bit_zero bit_inc + + +-- Boolean Operations ---------------------------------------------------------- + +type Bit = Sum () () + +true :: Conq s Bit +true = Writ . Null + +false :: Conq s Bit +false = Left . Null + +not' :: Conq Bit Bit +not' = Kase Writ Left + +id' :: Conq Bit Bit +id' = Kase Writ Left + +dup :: Conq a (a, a) +dup = Cons Subj Subj + +if' :: Conq s Bit -> Conq s r -> Conq s r -> Conq s r +if' c t f = case' (With Tail f) (With Tail t) . Cons c Subj + +and' :: Conq (Bit, Bit) Bit +and' = if' a2 a3 false + +or' :: Conq (Bit, Bit) Bit +or' = if' a2 true a3 + +xor' :: Conq (Bit, Bit) Bit +xor' = if' a2 (With a3 not') a3 + +bit_eq :: Conq (Bit, Bit) Bit +bit_eq = if' a2 a3 (With a3 not') + +bit_zero :: Conq s Bit +bit_zero = false + +val_bit_zero :: Bit +val_bit_zero = run () bit_zero + +bit_is_zero :: Conq Bit Bit +bit_is_zero = not' + +bit_inc :: Conq Bit Bit +bit_inc = not' + +-- Duo Operations (2 bit) ------------------------------------------------------ + +type Duo = (Bit, Bit) + +duo_zero :: Conq s Duo +duo_zero = Cons bit_zero bit_zero + +duo_is_zero :: Conq Duo Bit +duo_is_zero = dub_test bit_is_zero + +duo_inc :: Conq Duo Duo +duo_inc = Kase (Cons true Tail) (Cons false (not' . Tail)) . Dist + +factor :: Conq (Sum (a, c) (b, c)) (Sum a b, c) +factor = Kase (Cons (Left . Head) Tail) + (Cons (Writ . Head) Tail) + +duo :: Int -> Duo +duo n = runTimes n (run () duo_zero) duo_inc + +duo_equal :: Conq (Duo, Duo) Bit +duo_equal = dub_equal bit_eq + + +-- Nibble Operations (4 bit) --------------------------------------------------- + +type Nyb = (Duo, Duo) + +nyb_zero :: Conq a Nyb +nyb_zero = Cons duo_zero duo_zero + +nyb_is_zero :: Conq Nyb Bit +nyb_is_zero = dub_test duo_is_zero + +nyb_inc :: Conq Nyb Nyb +nyb_inc = dub_inc duo_inc duo_is_zero + +nyb :: Int -> Nyb +nyb n = runTimes n (run () nyb_zero) nyb_inc + +nyb_equal :: Conq (Nyb, Nyb) Bit +nyb_equal = dub_equal duo_equal + + +-- Byte Operations (8 bit) ----------------------------------------------------- + +type Byt = (Nyb, Nyb) + +byt_zero :: Conq a Byt +byt_zero = Cons nyb_zero nyb_zero + +byt_is_zero :: Conq Byt Bit +byt_is_zero = dub_test nyb_is_zero + +byt_inc :: Conq Byt Byt +byt_inc = dub_inc nyb_inc nyb_is_zero + +byt :: Int -> Byt +byt n = runTimes n (run () byt_zero) byt_inc + +byt_equal :: Conq (Byt, Byt) Bit +byt_equal = dub_equal nyb_equal + + +-- Short Operations (16 bit) --------------------------------------------------- + +type Short = (Byt, Byt) + +short_zero :: Conq a Short +short_zero = Cons byt_zero byt_zero + +short_is_zero :: Conq Short Bit +short_is_zero = dub_test byt_is_zero + +short_inc :: Conq Short Short +short_inc = dub_inc byt_inc byt_is_zero + +short :: Int -> Short +short n = runTimes n (run () short_zero) short_inc + +short_equal :: Conq (Short, Short) Bit +short_equal = dub_equal byt_equal + + +-- Wide Operations (32 bit) ---------------------------------------------------- + +type Wide = (Short, Short) + +wide_zero :: Conq a Wide +wide_zero = Cons short_zero short_zero + +wide_is_zero :: Conq Wide Bit +wide_is_zero = dub_test short_is_zero + +wide_inc :: Conq Wide Wide +wide_inc = dub_inc short_inc short_is_zero + +wide :: Int -> Wide +wide n = runTimes n (run () wide_zero) wide_inc + +wide_equal :: Conq (Wide, Wide) Bit +wide_equal = dub_equal short_equal + + +-- Long Operations (64 bit) ---------------------------------------------------- + +type Long = (Wide, Wide) + +long_zero :: Conq a Long +long_zero = Cons wide_zero wide_zero + +long_is_zero :: Conq Long Bit +long_is_zero = dub_test wide_is_zero + +long_inc :: Conq Long Long +long_inc = dub_inc wide_inc wide_is_zero + +long :: Int -> Long +long n = runTimes n (run () long_zero) long_inc + +long_equal :: Conq (Long, Long) Bit +long_equal = dub_equal wide_equal + +n0 :: Conq a (Sum () a) +n0 = Left . Null + +n1 :: Conq a (Sum () (Sum () a)) +n1 = Writ . n0 + +n2 :: Conq a (Sum () (Sum () (Sum () a))) +n2 = Writ . n1 diff --git a/pkg/hs-conq/package.yaml b/pkg/hs-conq/package.yaml new file mode 100644 index 000000000..a79c25f6e --- /dev/null +++ b/pkg/hs-conq/package.yaml @@ -0,0 +1,80 @@ +name: language-conq +version: 0.1.0 +license: AGPL-3.0-only + +library: + source-dirs: lib + ghc-options: + - -fwarn-incomplete-patterns + - -O2 + +dependencies: + - async + - base + - case-insensitive + - chunked-data + - classy-prelude + - containers + - data-fix + - extra + - flat + - ghc-prim + - http-client + - http-types + - integer-gmp + - largeword + - lens + - megaparsec + - mtl + - multimap + - para + - pretty-show + - QuickCheck + - semigroups + - smallcheck + - stm + - stm-chans + - tasty + - tasty-quickcheck + - tasty-th + - text + - these + - time + - transformers + - unordered-containers + - vector + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveDataTypeable + - DeriveFoldable + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - EmptyDataDecls + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - NoImplicitPrelude + - NumericUnderscores + - OverloadedStrings + - PartialTypeSignatures + - QuasiQuotes + - Rank2Types + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - UnicodeSyntax + - ViewPatterns diff --git a/pkg/hs-urbit/lib/Vere/Isle.hs b/pkg/hs-urbit/lib/Vere/Isle.hs index 00a3e5227..f18d90af6 100644 --- a/pkg/hs-urbit/lib/Vere/Isle.hs +++ b/pkg/hs-urbit/lib/Vere/Isle.hs @@ -1,49 +1,116 @@ module Vere.Isle where import ClassyPrelude +import Data.Word import qualified Vere.Isle.Util as C import qualified SDL as SDL +import qualified Data.Vector as V -import Data.Flat (Flat) +import Data.Bits (testBit) +import Data.Vector ((!)) +import Data.Flat (Flat) -------------------------------------------------------------------------------- -data Color - = Black | DarkGray - | Blue | LightBlue - | Green | LightGreen - | Cyan | LightCyan - | Red | LightRed - | Magenta | LightMagenta - | Brown | Yellow - | LightGray | White - deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) - deriving anyclass Flat +newtype Word4 = Word4 Word8 + deriving newtype (Eq, Ord, Num, Integral, Real, Enum) -type Blit = Vector (Vector Color) +newtype Word10 = Word10 Word16 + deriving newtype (Eq, Ord, Num, Integral, Real, Enum) -solid :: Color -> Blit -solid c = replicate 640 (replicate 480 c) +data RGB = RGB !Word8 !Word8 !Word8 -toRGB :: Color -> (Word8, Word8, Word8) -toRGB = \case - Black -> (0x00, 0x00, 0x00) - DarkGray -> (0x55, 0x55, 0x55) - Blue -> (0x00, 0x00, 0xAA) - LightBlue -> (0x55, 0x55, 0xFF) - Green -> (0x00, 0xAA, 0x00) - LightGreen -> (0x55, 0xFF, 0x55) - Cyan -> (0x00, 0xAA, 0xAA) - LightCyan -> (0x55, 0xFF, 0xFF) - Red -> (0xAA, 0x00, 0x00) - LightRed -> (0xFF, 0x55, 0x55) - Magenta -> (0xAA, 0x00, 0xAA) - LightMagenta -> (0xFF, 0x55, 0xFF) - Brown -> (0xAA, 0x55, 0x00) - Yellow -> (0xFF, 0xFF, 0x55) - LightGray -> (0xAA, 0xAA, 0xAA) - White -> (0xFF, 0xFF, 0xFF) +type Bitmap = Word64 -- 8x8 bitmap + +{- + TODO Storable instance? + (Then I can use an unboxed vector) +-} +data Tile = Tile + { tFore :: !Word4 + , tBack :: !Word4 + , tSpry :: !Word10 + } + +data Display = Display + { dColors :: V.Vector RGB -- size: 16 + , dSprites :: V.Vector Bitmap -- size: 1024 + , dTiles :: V.Vector Tile -- size: 3600 (80x45) + , dSurf :: V.Vector SDL.Surface -- size: 3600 (80x45) + } + +initializeSurfaces :: IO (V.Vector SDL.Surface) +initializeSurfaces = + V.generateM 3600 + $ const + $ SDL.createRGBSurface (SDL.V2 8 8) + $ SDL.RGB888 + +initialDisplay :: IO Display +initialDisplay = + do + surf <- initializeSurfaces + pure $ Display (V.generate 16 initialColors) + (V.generate 1024 initialSprites) + (V.generate 3600 initialTiles) + surf + where + initialSprites :: Int -> Bitmap + initialSprites = fromIntegral + + green = 4 + white = 15 + + initialTiles :: Int -> Tile + initialTiles i = + Tile green white (fromIntegral i `mod` 1024) + + initialColors :: Int -> RGB + initialColors = \case + 0 -> RGB 0x00 0x00 0x00 -- Black + 1 -> RGB 0x55 0x55 0x55 -- DarkGray + 2 -> RGB 0x00 0x00 0xAA -- Blue + 3 -> RGB 0x55 0x55 0xFF -- LightBlue + 4 -> RGB 0x00 0xAA 0x00 -- Green + 5 -> RGB 0x55 0xFF 0x55 -- LightGreen + 6 -> RGB 0x00 0xAA 0xAA -- Cyan + 7 -> RGB 0x55 0xFF 0xFF -- LightCyan + 8 -> RGB 0xAA 0x00 0x00 -- Red + 9 -> RGB 0xFF 0x55 0x55 -- LightRed + 10 -> RGB 0xAA 0x00 0xAA -- Magenta + 11 -> RGB 0xFF 0x55 0xFF -- LightMagenta + 12 -> RGB 0xAA 0x55 0x00 -- Brown + 13 -> RGB 0xFF 0xFF 0x55 -- Yellow + 14 -> RGB 0xAA 0xAA 0xAA -- LightGray + 15 -> RGB 0xFF 0xFF 0xFF -- White + n -> error ("bad color: " <> show n) + +renderTile :: Display -> Tile -> SDL.Surface -> IO () +renderTile d (Tile fg bg tx) surf = do + let for = dColors d ! fromIntegral fg + let bac = dColors d ! fromIntegral bg + let spry = dSprites d ! fromIntegral tx + for_ [0..63] $ \i -> do + let col = if testBit spry i then for else bac + renderPixel i surf col + +renderPixel :: Int -> SDL.Surface -> RGB -> IO () +renderPixel = undefined + + +-- data Display = Display + {-dColors :: V.Vector RGB -- size: 16 + , dSprites :: V.Vector Bitmap -- size: 1024 + , dTiles :: V.Vector Tile -- size: 3600 (80x45) + , dSurf :: V.Vector SDL.Surface -- size: 3600 (80x45) + -} + +render :: Display -> IO () +render = undefined + +draw :: Display -> IO () +draw = undefined -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index e15747f0c..fb9c7efa8 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -17,6 +17,7 @@ dependencies: - containers - data-fix - extra + - fixed-vector - flat - ghc-prim - hashtables @@ -55,6 +56,7 @@ dependencies: default-extensions: - ApplicativeDo + - DataKinds - BangPatterns - BlockArguments - DeriveAnyClass diff --git a/stack.yaml b/stack.yaml index e81620ad8..e67d32b9a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,11 +4,20 @@ packages: - pkg/hs-urbit - pkg/hs-vere - pkg/hs-hoon + - pkg/hs-conq extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 - flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38 +nix: + packages: + - pkgconfig + - SDL2 + - SDL2_image + - zlib + + # build: # library-profiling: true # executable-profiling: true From 5d69eb0a5a7dbc4a7b69a7c65ab57b13fcf67467 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 16 Jun 2019 13:30:00 -0700 Subject: [PATCH 065/431] Implemented eval, gates, cores, and a step-debugger. --- pkg/hs-conq/lib/Language/Conq.hs | 473 +++++++++++++++++++++++++------ 1 file changed, 394 insertions(+), 79 deletions(-) diff --git a/pkg/hs-conq/lib/Language/Conq.hs b/pkg/hs-conq/lib/Language/Conq.hs index ea13f315e..4daedc180 100644 --- a/pkg/hs-conq/lib/Language/Conq.hs +++ b/pkg/hs-conq/lib/Language/Conq.hs @@ -17,8 +17,8 @@ data Sum a b = L a | R b deriving (Eq, Ord) instance (Show a, Show b) => Show (Sum a b) where - show (L x) = case show x of { "()" → "L"; xs → "L" <> xs } - show (R x) = case show x of { "()" → "R"; xs → "R" <> xs } + show (L x) = case show x of { "()" → "0"; xs → "0" <> xs } + show (R x) = case show x of { "()" → "1"; xs → "1" <> xs } -------------------------------------------------------------------------------- @@ -55,6 +55,27 @@ instance (ToLit a, ToLit b) => ToLit (Tup a b) where -------------------------------------------------------------------------------- +data Val + = VN + | V0 Val + | V1 Val + | VP Val Val + +instance Show Val where + show = show . valExp + +valExp :: Val -> Exp +valExp VN = ENull +valExp v = EWith ENull (go v) + where + go = \case + VN → ENull + V0 VN → ELeft + V1 VN → EWrit + V0 l → EWith (go l) ELeft + V1 r → EWith (go r) EWrit + VP x y → ECons (go x) (go y) + data Exp = ESubj | ENull @@ -69,27 +90,170 @@ data Exp | ECase Exp Exp deriving (Eq, Ord) +runExp :: Val -> Exp -> Val +runExp s ESubj = s +runExp s e = uncurry runExp (step s e) + +-- Get a formula from a Val ---------------------------------------------------- + +{- + for = + opk = < > + dir = + get = <- +> + sim = <~ .> + otr = + plx = <@ :> +-} + +flattenExp :: Exp -> Exp +flattenExp = go + where + go (EWith (EWith x y) z) = go (EWith x (EWith y z)) + go (EWith x y) = EWith x (go y) + go x = x + +forVal :: Exp -> Val +forVal = \e -> + case flattenExp e of + EWith x y -> V1 $ VP (opkVal x) (forVal y) + x -> V0 (opkVal x) + where + opkVal :: Exp -> Val + opkVal = \case + EWith _ _ -> error "forVal: broken invariant" + ELeft -> V0 $ V0 $ V0 VN + EWrit -> V0 $ V0 $ V1 VN + EHead -> V0 $ V1 $ V0 VN + ETail -> V0 $ V1 $ V1 VN + ENull -> V1 $ V0 $ V0 VN + ESubj -> V1 $ V0 $ V1 VN + EEval -> V1 $ V1 $ V0 $ V0 VN + EDist -> V1 $ V1 $ V0 $ V1 VN + ECase x y -> V1 $ V1 $ V1 $ V0 $ VP (forVal x) (forVal y) + ECons x y -> V1 $ V1 $ V1 $ V1 $ VP (forVal x) (forVal y) + + +valFor :: Val -> Exp +valFor (V0 l) = valOpk l +valFor (V1 (VP x y)) = EWith (valOpk x) (valFor y) +valFor _ = ENull + +valOpk :: Val -> Exp +valOpk (V0 (V0 x)) = valDir x +valOpk (V0 (V1 x)) = valGet x +valOpk (V1 (V0 x)) = valSim x +valOpk (V1 (V1 (V0 x))) = valOtr x +valOpk (V1 (V1 (V1 x))) = valPlx x +valOpk _ = ENull + +valDir :: Val -> Exp +valDir (V0 VN) = ELeft +valDir (V1 VN) = EWrit +valDir _ = ENull + +valGet :: Val -> Exp +valGet (V0 VN) = EHead +valGet (V1 VN) = ETail +valGet _ = ENull + +valSim :: Val -> Exp +valSim (V0 VN) = ENull +valSim (V1 VN) = ESubj +valSim _ = ENull + +valOtr :: Val -> Exp +valOtr (V0 VN) = EEval +valOtr (V1 VN) = EDist +valOtr _ = ENull + +valPlx :: Val -> Exp +valPlx (V0 (VP x y)) = ECase (valFor x) (valFor y) +valPlx (V1 (VP x y)) = ECons (valFor x) (valFor y) +valPlx _ = ENull + +-- Small-Step Interpreter ------------------------------------------------------ + +step :: Val -> Exp -> (Val, Exp) +step s = \case + ENull -> (VN, ESubj) + ESubj -> (s, ESubj) + EWith ESubj y -> (s, y) + EWith x y -> case step s x of + (s', ESubj) -> (s', y) + (s', x' ) -> (s', EWith x' y) + EEval -> case s of + VP s' f' -> (s', valFor f') + _ -> (VN, ESubj) + ECons ESubj ESubj -> (VP s s, ESubj) + ECons x y -> (VP (runExp s x) (runExp s y), ESubj) + ELeft -> (V0 s, ESubj) + EWrit -> (V1 s, ESubj) + EHead -> case s of + VP x _ -> (x, ESubj) + _ -> (VN, ESubj) + ETail -> case s of + VP _ y -> (y, ESubj) + _ -> (VN, ESubj) + EDist -> case s of + VP (V0 l) x -> (V0 (VP l x), ESubj) + VP (V1 r) x -> (V1 (VP r x), ESubj) + _ -> (VN, ESubj) + ECase p q -> case s of + V0 l -> (l, p) + V1 r -> (r, q) + _ -> (VN, ESubj) + +displayExp :: Exp -> String +displayExp (EWith x y) = displayExp x <> "\n" <> displayExp y +displayExp x = "\t" <> show x + +traceRunExp :: Val -> Exp -> IO () +traceRunExp s e = do + putStrLn (tshow (valExp s)) + putStrLn (pack $ displayExp e) + void getLine + case e of + ESubj -> putStrLn "DONE" + _ -> uncurry traceRunExp (step s e) + +traceRun :: Conq () r -> IO () +traceRun = traceRunExp VN . toExp + +{- +run sut = \case + Null -> () + Subj -> sut + With x y -> run (run sut x) y + Eval -> case sut of (s,f) -> run s f + Cons x y -> (run sut x, run sut y) + Left -> L sut + Writ -> R sut + Head -> fst sut + Tail -> snd sut + Dist -> case sut of { (L l,x) -> L (l,x); (R r,x) -> R (r,x); } + Case p q -> case sut of { L l -> run l p; R r -> run r q; } +-} + +flattenCons :: Exp -> Exp -> [Exp] +flattenCons = \x -> go [x] + where + go acc (ECons x y) = go (x:acc) y + go acc x = reverse (x:acc) + instance Show Exp where - showsPrec d = \case - ESubj -> showString "." - ENull -> showString "~" - EEval -> showString "!" - ELeft -> showString "L" - EWrit -> showString "R" - EHead -> showString "-" - ETail -> showString "+" - EDist -> showString "%" - EWith x y -> showsPrec d x . showsPrec d y - ECons x y -> showString "[" - . showsPrec d x - . showString " " - . showsPrec d y - . showString "]" - ECase x y -> showString "<" - . showsPrec d x - . showString " " - . showsPrec d y - . showString ">" + show = \case + ESubj -> "." + ENull -> "~" + EEval -> "!" + ELeft -> "0" + EWrit -> "1" + EHead -> "-" + ETail -> "+" + EDist -> "%" + EWith x y -> show y <> show x + ECons x y -> "(" <> show x <> " " <> show y <> ")" + ECase x y -> "<" <> show x <> " " <> show y <> ">" -------------------------------------------------------------------------------- @@ -118,20 +282,11 @@ data Conq s r where Head :: Conq (Tup a b) a Tail :: Conq (Tup a b) b Cons :: Conq s a -> Conq s b -> Conq s (a, b) - Kase :: Conq a r -> Conq b r -> Conq (Sum a b) r + Case :: Conq a r -> Conq b r -> Conq (Sum a b) r Dist :: Conq (Sum a b,s) (Sum (a,s) (b,s)) With :: Conq s a -> Conq a r -> Conq s r Eval :: Conq (a, Conq a r) r - - - - - - - - -- Case :: Conq (a,s) r -> Conq (b,s) r -> Conq (Sum a b,s) r - instance Category Conq where id = Subj (.) = flip With @@ -153,15 +308,7 @@ run sut = \case Head -> fst sut Tail -> snd sut Dist -> case sut of { (L l,x) -> L (l,x); (R r,x) -> R (r,x); } - Kase p q -> case sut of { L l -> run l p; R r -> run r q; } - - - - - - ---Case p q -> case sut of (L l,x) -> run (l,x) p --- (R r,x) -> run (r,x) q + Case p q -> case sut of { L l -> run l p; R r -> run r q; } times :: Int -> Conq s s -> Conq s s times 0 _ = id @@ -188,8 +335,7 @@ toExp = \case Tail -> ETail Dist -> EDist Cons x y -> ECons (toExp x) (toExp y) ---Case l r -> ECase (toExp l) (toExp r) - Kase l r -> ECase (toExp l) (toExp r) + Case l r -> ECase (toExp l) (toExp r) With x y -> EWith (toExp x) (toExp y) -------------------------------------------------------------------------------- @@ -240,13 +386,13 @@ just :: Conq a (Sum () a) just = Writ case' :: Conq (a,s) r -> Conq (b,s) r -> Conq (Sum a b,s) r -case' x y = Kase x y . Dist +case' x y = Case x y . Dist previewLeft :: Conq (Sum a b) (Sum () a) -previewLeft = Kase just nothing +previewLeft = Case just nothing previewWrit :: Conq (Sum a b) (Sum () b) -previewWrit = Kase nothing just +previewWrit = Case nothing just -- Pair Operations ------------------------------------------------------------- @@ -258,24 +404,80 @@ both :: Conq a b -> Conq (a, a) (b, b) both x = Cons (With Head x) (With Tail x) dub_equal :: Conq (a, a) Bit -> Conq ((a, a), (a, a)) Bit -dub_equal cmp = With results and' +dub_equal cmp = With results bit_and where results = Cons (With (both Head) cmp) (With (both Tail) cmp) dub_test :: Conq a Bit -> Conq (a, a) Bit -dub_test test = curry' and' (With Head test) (With Tail test) +dub_test test = curry' bit_and (With Head test) (With Tail test) dub_inc :: Conq a a -> Conq a Bit -> Conq (a, a) (a, a) dub_inc inc null = With bump_low (if' low_zero bump_hig id) where - bump_low = Cons (With Head inc) Tail - bump_hig = Cons Head (With Tail inc) - low_zero = With Head null + bump_low = Cons (inc . Head) Tail + bump_hig = Cons Head (inc . Tail) + low_zero = null . Head + +type Tag a = Sum a a -- Tag with a bit: <0 1> +type Inc a = Conq a (Tag a) + +bit_incer :: Inc Bit +bit_incer = Case (Left . Writ) (Writ . Left) + +duo_incer' :: Inc Duo +duo_incer' = incer bit_incer + +duo_incer :: Inc Duo +duo_incer = Case (Left . Cons true Tail) carry . Dist + where + carry = Case (Left . Cons Left Writ) (Writ . Cons Left Left) . Tail + +incer :: forall a. Inc a -> Inc (a, a) +incer i = + Case Left hig . low + where + low, hig :: Inc (a, a) + low = Dist . Cons (i . Head) Tail + hig = Case (Left . flip') Writ . Dist . Cons (i . Tail) Head + +nyb_incer :: Inc Nyb +nyb_incer = incer duo_incer + +byt_incer :: Inc Byt +byt_incer = incer nyb_incer + +short_incer :: Inc Short +short_incer = incer byt_incer + +wide_incer :: Inc Wide +wide_incer = incer short_incer + +long_incer :: Inc Long +long_incer = incer wide_incer bit :: Int -> Bit bit n = runTimes n val_bit_zero bit_inc +-- Random Combinators ---------------------------------------------------------- + +dup :: Conq a (a, a) +dup = Cons Subj Subj + +eat :: Conq (Sum a a) a +eat = Case Subj Subj + +flip' :: Conq (a, b) (b, a) +flip' = Cons Tail Head + +if' :: Conq s Bit -> Conq s r -> Conq s r -> Conq s r +if' c t f = case' (f . Tail) (t . Tail) . Cons c Subj + +factor :: Conq (Sum (a, c) (b, c)) (Sum a b, c) +factor = Case (Cons (Left . Head) Tail) + (Cons (Writ . Head) Tail) + + -- Boolean Operations ---------------------------------------------------------- type Bit = Sum () () @@ -286,29 +488,23 @@ true = Writ . Null false :: Conq s Bit false = Left . Null -not' :: Conq Bit Bit -not' = Kase Writ Left +bit_not :: Conq Bit Bit +bit_not = Case Writ Left -id' :: Conq Bit Bit -id' = Kase Writ Left +bit_id :: Conq Bit Bit +bit_id = Case Left Writ -dup :: Conq a (a, a) -dup = Cons Subj Subj +bit_and :: Conq (Bit, Bit) Bit +bit_and = Case false Tail . Dist -if' :: Conq s Bit -> Conq s r -> Conq s r -> Conq s r -if' c t f = case' (With Tail f) (With Tail t) . Cons c Subj +bit_or :: Conq (Bit, Bit) Bit +bit_or = Case Tail true . Dist -and' :: Conq (Bit, Bit) Bit -and' = if' a2 a3 false +bit_xor :: Conq (Bit, Bit) Bit +bit_xor = Case Tail (bit_not . Tail) . Dist -or' :: Conq (Bit, Bit) Bit -or' = if' a2 true a3 - -xor' :: Conq (Bit, Bit) Bit -xor' = if' a2 (With a3 not') a3 - -bit_eq :: Conq (Bit, Bit) Bit -bit_eq = if' a2 a3 (With a3 not') +bit_equal :: Conq (Bit, Bit) Bit +bit_equal = Case (bit_not . Tail) Tail . Dist bit_zero :: Conq s Bit bit_zero = false @@ -317,10 +513,10 @@ val_bit_zero :: Bit val_bit_zero = run () bit_zero bit_is_zero :: Conq Bit Bit -bit_is_zero = not' +bit_is_zero = bit_not bit_inc :: Conq Bit Bit -bit_inc = not' +bit_inc = bit_not -- Duo Operations (2 bit) ------------------------------------------------------ @@ -333,17 +529,13 @@ duo_is_zero :: Conq Duo Bit duo_is_zero = dub_test bit_is_zero duo_inc :: Conq Duo Duo -duo_inc = Kase (Cons true Tail) (Cons false (not' . Tail)) . Dist - -factor :: Conq (Sum (a, c) (b, c)) (Sum a b, c) -factor = Kase (Cons (Left . Head) Tail) - (Cons (Writ . Head) Tail) +duo_inc = Case (Cons true Tail) (Cons false (bit_not . Tail)) . Dist duo :: Int -> Duo duo n = runTimes n (run () duo_zero) duo_inc duo_equal :: Conq (Duo, Duo) Bit -duo_equal = dub_equal bit_eq +duo_equal = dub_equal bit_equal -- Nibble Operations (4 bit) --------------------------------------------------- @@ -451,5 +643,128 @@ n0 = Left . Null n1 :: Conq a (Sum () (Sum () a)) n1 = Writ . n0 -n2 :: Conq a (Sum () (Sum () (Sum () a))) -n2 = Writ . n1 +n2 = Writ . n1 +n3 = Writ . n2 +n4 = Writ . n3 +n5 = Writ . n4 +n6 = Writ . n5 +n7 = Writ . n6 +n8 = Writ . n7 +n9 = Writ . n8 +n10 = Writ . n9 + + +-------------------------------------------------------------------------------- + +-- ctx for -> (ctx for) +gate :: Val -> Exp -> Val +gate v e = VP v (forVal e) + +-- `$-(a a)`: Identity +identFn :: Val +identFn = gate VN (toExp Head) + +-- `$-(a b)`: Trivial-Loop +spinFn :: Val +spinFn = gate VN fire + +-- `$-((list a) @)`: List-Length +lenFn :: Val +lenFn = gate (V0 VN) lenFnBody + +lenFnBody :: Exp +lenFnBody = EWith EDist + $ ECase (EWith ETail EHead) + $ EWith (ECons (EWith EHead ETail) + (EWith ETail (ECons (EWith EHead EWrit) ETail))) + $ fire + +swapFn :: Val +swapFn = gate VN (toExp swapFnBody) + +swapFnBody :: Conq ((a,b),x) (b,a) +swapFnBody = Cons Tail Head . Head + +-- ctx lFor rFor -> (ctx (lfor rfor)) +coreTwo :: Val -> Exp -> Exp -> Val +coreTwo v l r = VP v (VP (forVal l) (forVal r)) + +evenOddCore :: Val +evenOddCore = coreTwo VN evArm odArm + +evArm :: Exp +evArm = EWith EDist + $ ECase (toExp true) + $ fireRit + +odArm :: Exp +odArm = EWith EDist + $ ECase (toExp false) + $ fireLef + +-- (arg (ctx for)) -> ((arg (ctx for)) for)! +fire :: Exp +fire = EWith (toExp reOrg) EEval + where + reOrg :: Conq (a,(c,f)) ((a,(c,f)),f) + reOrg = Cons Subj (Tail . Tail) + +-- (arg (ctx (lfor rfor))) -> ((arg (ctx (lfor rfor))) lfor)! +fireLef :: Exp +fireLef = EWith (toExp reOrg) EEval + where + reOrg :: Conq (a,(c,(l,r))) ((a,(c,(l,r))),l) + reOrg = Cons Subj (Head . Tail . Tail) + +-- (arg (ctx (lfor rfor))) -> ((arg (ctx (lfor rfor))) rfor)! +fireRit :: Exp +fireRit = EWith (toExp reOrg) EEval + where + reOrg :: Conq (a,(c,(l,r))) ((a,(c,(l,r))),r) + reOrg = Cons Subj (Tail . Tail . Tail) + +-- Demos ----------------------------------------------------------------------- + +type Payload = (Val, Exp) + +demo :: Payload -> IO () +demo (s,f) = traceRunExp s f + +dumbLoop :: Exp +dumbLoop = EWith (ECons ESubj ESubj) EEval + +dumbLoopP :: Payload +dumbLoopP = (forVal dumbLoop, dumbLoop) + +demo_dumb_loop :: IO () +demo_dumb_loop = demo dumbLoopP + +demo_duo_overflow :: IO () +demo_duo_overflow = traceRun (duo_incer . times 3 (eat . duo_incer) . duo_zero) + +demo_nat_constr :: IO () +demo_nat_constr = traceRun n10 + +-- [[-e +] +]! +fix :: Val -> Exp -> Payload +fix x e = (VP x (forVal fe), fe) + where + fe = EWith (ECons (ECons (EWith EHead e) ETail) ETail) EEval + +natOverflow :: Exp +natOverflow = EWith (ECons (ECons (EWith EHead EWrit) ETail) ETail) EEval + +natOverflowPay :: Payload +natOverflowPay = fix (V0 VN) EWrit + +demo_nat_inc_loop :: IO () +demo_nat_inc_loop = demo natOverflowPay + +duo_zero_val :: Val +duo_zero_val = VP (V0 VN) (V0 (VN)) + +short_zero_val :: Val +short_zero_val = runExp VN (toExp short_zero) + +short_inc_loop :: IO () +short_inc_loop = demo $ fix (V0 short_zero_val) (toExp (short_incer . eat)) From 2f7e31f671e4cc7c1c43adeb0836af5769c23f95 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 16 Jun 2019 18:04:43 -0700 Subject: [PATCH 066/431] Basic type inference. --- pkg/hs-conq/lib/Language/Conq.hs | 150 ++++++++++++++++++++++++++++++- 1 file changed, 149 insertions(+), 1 deletion(-) diff --git a/pkg/hs-conq/lib/Language/Conq.hs b/pkg/hs-conq/lib/Language/Conq.hs index 4daedc180..f3501ae21 100644 --- a/pkg/hs-conq/lib/Language/Conq.hs +++ b/pkg/hs-conq/lib/Language/Conq.hs @@ -1,15 +1,21 @@ module Language.Conq where -import ClassyPrelude hiding (pure, (<.>), Left, Right) +import ClassyPrelude hiding ((<.>), Left, Right) import Data.Type.Equality import Type.Reflection import Data.Coerce import GHC.Natural import Control.Category +import Control.Monad.State (State, get, put, evalState, runState) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Except (throwE) +import Control.Lens ((&)) import Data.Bits ((.|.), shiftL, shiftR) import Text.Show (showString, showParen) +import qualified Prelude as P + -------------------------------------------------------------------------------- type Tup a b = (a, b) @@ -76,6 +82,148 @@ valExp v = EWith ENull (go v) V1 r → EWith (go r) EWrit VP x y → ECons (go x) (go y) +data TyExp + = TENil + | TESum TyExp TyExp + | TETup TyExp TyExp + | TEFor TyExp TyExp + | TEAll TyExp + | TEFix TyExp + | TERef Int + +data Ty + = TNil + | TSum Ty Ty + | TTup Ty Ty + | TFor Ty Ty + | TVar Int + +instance Show Ty where + show = \case + TNil -> "~" + TSum x y -> "<" <> show x <> " " <> show y <> ">" + TTup x y -> "[" <> show x <> " " <> show y <> "]" + TFor x y -> "(" <> show x <> " => " <> show y <> ")" + TVar x -> show x + +type Unique = Int +type Infer a = ExceptT () (State (Map Int Ty, Unique)) a +type Unify a = Maybe a + +forAll :: Infer Ty +forAll = do + (env, n) <- get + put (env, n+1) + pure (TVar n) + +varIs :: Int -> Ty -> Infer Ty +varIs v (TVar x) | x==v = do + pure (TVar x) +varIs v t = do + (env, n) <- get + put (insertMap v t env, n) + pure t + +finalize :: Ty -> Infer Ty +finalize (TVar v) = resolve v >>= finalize' +finalize t = finalize' t + +finalize' :: Ty -> Infer Ty +finalize' = \case + TNil -> pure TNil + TVar x -> pure (TVar x) + TSum x y -> TSum <$> finalize x <*> finalize y + TTup x y -> TTup <$> finalize x <*> finalize y + TFor x y -> TFor <$> finalize x <*> finalize y + +unify :: Ty -> Ty -> Infer Ty +unify x y = do + x <- case x of { TVar v -> resolve v; x -> pure x } + y <- case y of { TVar v -> resolve v; y -> pure y } + unify' x y + +unify' :: Ty -> Ty -> Infer Ty +unify' = curry \case + ( TNil, TNil ) -> pure TNil + ( TSum a1 b1, TSum a2 b2 ) -> TSum <$> unify a1 a2 <*> unify b1 b2 + ( TTup a1 b1, TTup a2 b2 ) -> TTup <$> unify a1 a2 <*> unify b1 b2 + ( TFor a1 b1, TFor a2 b2 ) -> TFor <$> unify a1 a2 <*> unify b1 b2 + ( ty, TVar x ) -> varIs x ty + ( TVar x, ty ) -> varIs x ty + ( _x, _y ) -> throwE () + +resolve :: Int -> Infer Ty +resolve v = do + (env, _) <- get + lookup v env & \case + Nothing -> pure (TVar v) + Just (TVar x) -> resolve x + Just x -> pure x + +expectFor :: Ty -> Infer (Ty, Ty, Ty) +expectFor = \case + ty@(TFor x y) -> pure (ty, x, y) + _ -> throwE () + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (P.Left _) = Nothing +eitherToMaybe (P.Right x) = Just x + +runInfer :: Infer a -> Maybe a +runInfer = eitherToMaybe . flip evalState (mempty, 0) . runExceptT + +infer :: Exp -> Infer Ty +infer = \case + ENull -> do + a <- forAll + pure (TFor a TNil) + + ESubj -> do + a <- forAll + pure (TFor a a) + + ELeft -> do + (a, b) <- (,) <$> forAll <*> forAll + pure (TFor a (TSum a b)) + + EWrit -> do + (a, b) <- (,) <$> forAll <*> forAll + pure (TFor b (TSum a b)) + + EHead -> do + (a, b) <- (,) <$> forAll <*> forAll + pure $ TFor (TTup a b) a + + ETail -> do + (a, b) <- (,) <$> forAll <*> forAll + pure $ TFor (TTup a b) b + + EDist -> do + (a, b, c) <- (,,) <$> forAll <*> forAll <*> forAll + pure $ TFor (TTup (TSum a b) c) (TSum (TTup a c) (TTup b c)) + + EEval -> do + (a, b) <- (,) <$> forAll <*> forAll + pure $ TFor (TTup a (TFor a b)) b + + EWith x y -> do + (xt, xi, xo) <- infer x >>= expectFor + (yt, yi, yo) <- infer y >>= expectFor + unify xo yi + pure (TFor xi yo) + + ECons x y -> do + (xt, xi, xo) <- infer x >>= expectFor + (yt, yi, yo) <- infer y >>= expectFor + unify xi yi + pure (TFor xi (TTup xo yo)) + + ECase p q -> do + (pt, pi, po) <- infer p >>= expectFor + (qt, qi, qo) <- infer q >>= expectFor + unify po qo + pure (TFor (TSum pi qi) po) + data Exp = ESubj | ENull From 8a16fdd8641418a2bf2f95d015e69d011ca471d6 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Mon, 17 Jun 2019 16:47:20 -0700 Subject: [PATCH 067/431] Continue translating pier.c into Worker.hs --- pkg/hs-urbit/lib/Vere/Pier.hs | 26 +++++++- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 10 ++- pkg/hs-urbit/lib/Vere/Worker.hs | 98 ++++++++++++++++++----------- 3 files changed, 95 insertions(+), 39 deletions(-) diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 5b8c709c7..185419f0f 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -4,8 +4,28 @@ import ClassyPrelude import Vere.Pier.Types import qualified Vere.Log as Log -initPier :: FilePath -> IO Pier -initPier top = do + +-- This is ugly and wrong +newPier :: FilePath -> LogIdentity -> IO Pier +newPier top id = do + let logPath = top <> "/log" + + computeQueue <- newTQueueIO + persistQueue <- newTQueueIO + releaseQueue <- newTQueueIO + + -- What we really want to do is write the log identity and then do normal + -- startup, but writeLogIdentity requires a full log state including + -- input/output queues. + logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) + + Log.writeLogIdentity logState id + + pure (Pier{..}) + + +restartPier :: FilePath -> IO Pier +restartPier top = do let logPath = top <> "/log" computeQueue <- newTQueueIO @@ -14,5 +34,7 @@ initPier top = do logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) + -- When we create a worker, we should take arguments indicating the identity. + pure (Pier{..}) diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index a4e501702..46b34057b 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -45,4 +45,12 @@ data LogIdentity = LogIdentity { who :: Noun , is_fake :: Noun , life :: Noun - } deriving Show + } deriving (Show) + +instance ToNoun LogIdentity where + toNoun LogIdentity{..} = toNoun (who, is_fake, life) + +instance FromNoun LogIdentity where + parseNoun n = do + (who, is_fake, life) <- parseNoun n + pure (LogIdentity{..}) diff --git a/pkg/hs-urbit/lib/Vere/Worker.hs b/pkg/hs-urbit/lib/Vere/Worker.hs index 17fb08f72..1f8e8251e 100644 --- a/pkg/hs-urbit/lib/Vere/Worker.hs +++ b/pkg/hs-urbit/lib/Vere/Worker.hs @@ -14,11 +14,22 @@ import Data.Noun.Pill import Vere.Pier.Types import System.Process +import Data.ByteString (hGet) +import Data.ByteString.Unsafe (unsafeUseAsCString) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek) + +import qualified Vere.Log as Log + data Worker = Worker { sendHandle :: Handle , recvHandle :: Handle , process :: ProcessHandle + , identity :: LogIdentity + -- TODO: This shouldn't be here. + , wLogState :: LogState + -- , getInput :: STM (Writ ()) -- , onComputed :: Writ [Effect] -> STM () @@ -32,11 +43,11 @@ data Worker = Worker -- Think about how to handle process exit -- Tear down subprocess on exit? (terminiteProcess) -start :: IO Worker -start = +start :: LogIdentity -> LogState -> IO Worker +start id s = do (Just i, Just o, _, p) <- createProcess pSpec - pure (Worker i o p) + pure (Worker i o p id s) where pSpec = (proc "urbit-worker" []) { std_in = CreatePipe @@ -97,8 +108,6 @@ instance FromNoun Plea where type CompletedEventId = Word64 type NextEventId = Word64 -type LogState = Maybe EventId - type WorkerState = (EventId, Mug) type ReplacementEv = (EventId, Mug, Job) @@ -113,6 +122,9 @@ data WorkerExn | UnexpectedPlay EventId Play | BadPleaAtom Atom | BadPleaNoun Noun + | ReplacedEventDuringReplay EventId ReplacementEv + | WorkerConnectionClosed + | UnexpectedInitialPlea Plea deriving (Show) instance Exception WorkerExn @@ -131,9 +143,6 @@ fromJustExn (Just x) exn = pure x -------------------------------------------------------------------------------- -boot :: a -> IO b -boot = undefined - sendAndRecv :: Worker -> EventId -> Atom -> IO WorkerResp sendAndRecv w eventId event = do @@ -159,8 +168,9 @@ sendAndRecv w eventId event = Slog _ pri t -> printTank pri t >> loop sendBootEvent :: Worker -> IO () -sendBootEvent = do - undefined +sendBootEvent w = do + sendAtom w $ jam $ toNoun (Cord "boot", (identity w)) + -- the ship is booted, but it is behind. shove events to the worker until it is -- caught up. @@ -170,35 +180,46 @@ replay :: Worker -> WorkerState -> EventId replay w (wid, wmug) lastCommitedId getEvents = do when (wid == 1) (sendBootEvent w) - -- todo: we want to stream these in chunks - events <- getEvents wid (1 + lastCommitedId - wid) - - for_ events $ \(eventId, event) -> do - (Right (i, mug, ovum)) <- sendAndRecv w eventId event - undefined - - -- todo: these actually have to happen concurrently - -computeThread :: Worker -> IO () -computeThread w = start + loop wid where - start = do - Play p <- recvPlea w - let (eventId, mug) = playWorkerState p - -- fuck it, we'll do it liv_o + -- Replay events in batches of 1000. + loop curEvent = do + let toRead = min 1000 (1 + lastCommitedId - curEvent) + when (toRead > 0) do + events <- getEvents curEvent toRead + + for_ events $ \(eventId, event) -> do + sendAndRecv w eventId event >>= \case + (Left ev) -> throwIO (ReplacedEventDuringReplay eventId ev) + (Right _) -> pure () + + loop (curEvent + toRead) + +startPier :: Worker -> IO (EventId) +startPier w = + do + ws@(eventId, mug) <- recvPlea w >>= \case + Play Nil -> pure (1, Mug 0) + Play (NotNil (e, m, _)) -> pure (e, m) + x -> throwIO (UnexpectedInitialPlea x) + + logLatestEventNumber <- Log.latestEventNumber (wLogState w) + + when (logLatestEventNumber == 0) $ do + -- todo: boot. we need a pill. undefined - boot :: WorkerState -> IO () - boot workState = do - undefined - writ <- undefined -- getWrit w - sendAtom w (work (eventId writ) (event writ)) + replay w ws logLatestEventNumber (Log.readEvents (wLogState w)) - playWorkerState :: Play -> WorkerState - playWorkerState = \case - Nil -> (1, Mug 0) - NotNil (e, m, _) -> (e, m) + requestSnapshot w + pure (logLatestEventNumber) + +workerThread :: Worker -> IO (Async ()) +workerThread w = undefined + +requestSnapshot :: Worker -> IO () +requestSnapshot w = undefined -- The flow here is that we start the worker and then we receive a play event -- with the current worker state: @@ -235,10 +256,15 @@ unpackAtom :: Atom -> ByteString unpackAtom = view atomBytes recvLen :: Worker -> IO Word64 -recvLen = undefined +recvLen w = do + bs <- hGet (recvHandle w) 8 + case length bs of + -- This is not big endian safe + 8 -> unsafeUseAsCString bs (peek . castPtr) + _ -> throwIO WorkerConnectionClosed recvBytes :: Worker -> Word64 -> IO ByteString -recvBytes = undefined +recvBytes w = hGet (recvHandle w) . fromIntegral recvAtom :: Worker -> IO Atom recvAtom w = do From 7caadf43bccef6bfc4f5e1d681e675441c8da3fc Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Tue, 18 Jun 2019 15:38:24 -0700 Subject: [PATCH 068/431] More of pier startup factored correctly. --- pkg/hs-urbit/lib/Vere.hs | 12 ++++- pkg/hs-urbit/lib/Vere/Log.hs | 7 +-- pkg/hs-urbit/lib/Vere/Pier.hs | 69 +++++++++++++++++++++++++---- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 14 +++--- pkg/hs-urbit/lib/Vere/Worker.hs | 69 ++++++++++++++++++----------- 5 files changed, 127 insertions(+), 44 deletions(-) diff --git a/pkg/hs-urbit/lib/Vere.hs b/pkg/hs-urbit/lib/Vere.hs index 9d5ba5a9f..9cd0b539d 100644 --- a/pkg/hs-urbit/lib/Vere.hs +++ b/pkg/hs-urbit/lib/Vere.hs @@ -2,17 +2,18 @@ module Vere where import ClassyPrelude import Data.Void +import Data.Noun import qualified Vere.Http.Server as Server import qualified Vere.Http.Client as Client -- +vere ----------------------------------------------------------------------- data WTFIsThis - = WTFIsThis (Maybe Varience) TheActualFuckingThing + = WTFIsThis (Maybe Varience) Eff data Varience = Gold | Iron | Lead -data TheActualFuckingThing +data Eff = HttpServer Server.Eff | HttpClient Client.Eff | Behn Void @@ -24,3 +25,10 @@ data TheActualFuckingThing | Init Void | Term Void + +type Perform = Eff -> IO () + +data IODriver = IODriver + { bornEvent :: IO Noun + , startDriver :: (Noun -> STM ()) -> IO (Async (), Perform) + } diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index 719d147e0..71f0e8719 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -21,6 +21,7 @@ import Data.Void import Database.LMDB.Raw import Foreign.Ptr import Foreign.Marshal.Alloc +import Vere import Vere.Pier.Types import Control.Lens ((^.)) @@ -34,7 +35,7 @@ import qualified Data.Vector.Mutable as MV -------------------------------------------------------------------------------- -- TODO: Handle throws on the async -init :: FilePath -> TQueue (Writ [Effect]) -> (Writ [Effect] -> STM ()) +init :: FilePath -> TQueue (Writ [Eff]) -> (Writ [Eff] -> STM ()) -> IO LogState init dir inp cb = do env <- mdb_env_create @@ -130,8 +131,8 @@ withWordPtr w cb = do -- TODO: We need to be able to send back an exception to the main thread on an -- exception on the persistence thread. persistThread :: MDB_env - -> TQueue (Writ [Effect]) - -> (Writ [Effect] -> STM ()) + -> TQueue (Writ [Eff]) + -> (Writ [Eff] -> STM ()) -> IO (Async ()) persistThread env inputQueue onPersist = asyncBound $ forever do diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 185419f0f..010a24984 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -1,13 +1,21 @@ module Vere.Pier where import ClassyPrelude + +import Data.Noun +import Data.Noun.Pill +import Vere import Vere.Pier.Types + import qualified Vere.Log as Log +import qualified Vere.Worker as Worker +ioDrivers = [] :: [IODriver] --- This is ugly and wrong -newPier :: FilePath -> LogIdentity -> IO Pier -newPier top id = do +-- This is called to make a freshly booted pier. It assigns an identity to an +-- event log and takes a chill pill. +newPier :: Pill -> FilePath -> LogIdentity -> IO Pier +newPier pill top id = do let logPath = top <> "/log" computeQueue <- newTQueueIO @@ -19,22 +27,67 @@ newPier top id = do -- input/output queues. logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) + -- In first boot, we need to write this! Log.writeLogIdentity logState id - pure (Pier{..}) + let logLatestEventNumber = 0 + let getEvents = Log.readEvents logState + + workerState <- Worker.startWorkerProcess + + Worker.bootWorker workerState id pill + + performCommonPierStartup workerState computeQueue persistQueue releaseQueue logState -restartPier :: FilePath -> IO Pier -restartPier top = do +-- This reads in a pier +runPierFromDisk :: FilePath -> IO Pier +runPierFromDisk top = do let logPath = top <> "/log" computeQueue <- newTQueueIO persistQueue <- newTQueueIO releaseQueue <- newTQueueIO + -- What we really want to do is write the log identity and then do normal + -- startup, but writeLogIdentity requires a full log state including + -- input/output queues. logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) - -- When we create a worker, we should take arguments indicating the identity. + -- In first boot, we need to write this! + id <- Log.readLogIdentity logState + logLatestEventNumber <- Log.latestEventNumber logState + + let getEvents = Log.readEvents logState + + workerState <- Worker.startWorkerProcess + Worker.resumeWorker workerState id logLatestEventNumber getEvents + + performCommonPierStartup workerState computeQueue persistQueue releaseQueue logState + + +performCommonPierStartup :: Worker.Worker + -> TQueue Noun + -> TQueue (Writ [Eff]) + -> TQueue (Writ [Eff]) + -> LogState + -> IO Pier +performCommonPierStartup workerState computeQueue persistQueue releaseQueue logState = do + for ioDrivers $ \x -> do + bootMessage <- bornEvent x + atomically $ writeTQueue computeQueue bootMessage + + driverThreads <- for ioDrivers $ \x -> do + startDriver x (writeTQueue computeQueue) + + -- TODO: Don't do a bunch of extra work; we send all events to all drivers + portingThread <- async $ do + forever $ do + r <- atomically (readTQueue releaseQueue) + for_ driverThreads $ \(_, k) -> + for_ (payload r) $ \eff -> + k eff + + Worker.workerThread workerState pure (Pier{..}) - diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 46b34057b..e03a8e197 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -7,8 +7,8 @@ import Data.Noun.Atom import Data.Noun.Poet import Database.LMDB.Raw import Urbit.Time +import Vere -data Effect newtype Ovum = Ovum Void deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) @@ -25,10 +25,12 @@ data Writ a = Writ } data Pier = Pier - { computeQueue :: TQueue (Writ Word) - , persistQueue :: TQueue (Writ [Effect]) - , releaseQueue :: TQueue (Writ [Effect]) + { computeQueue :: TQueue Noun + , persistQueue :: TQueue (Writ [Eff]) + , releaseQueue :: TQueue (Writ [Eff]) , logState :: LogState + , driverThreads :: [(Async (), Perform)] + , portingThread :: Async () } -- TODO: We are uncertain about q's type. There's some serious entanglement @@ -36,8 +38,8 @@ data Pier = Pier -- away with anything less than passing the full u3_writ around. data LogState = LogState { env :: MDB_env - , inputQueue :: TQueue (Writ [Effect]) - , onPersist :: Writ [Effect] -> STM () + , inputQueue :: TQueue (Writ [Eff]) + , onPersist :: Writ [Eff] -> STM () , writer :: Async () } diff --git a/pkg/hs-urbit/lib/Vere/Worker.hs b/pkg/hs-urbit/lib/Vere/Worker.hs index 1f8e8251e..3f9b3cc3f 100644 --- a/pkg/hs-urbit/lib/Vere/Worker.hs +++ b/pkg/hs-urbit/lib/Vere/Worker.hs @@ -26,10 +26,6 @@ data Worker = Worker , recvHandle :: Handle , process :: ProcessHandle - , identity :: LogIdentity - -- TODO: This shouldn't be here. - , wLogState :: LogState - -- , getInput :: STM (Writ ()) -- , onComputed :: Writ [Effect] -> STM () @@ -43,11 +39,11 @@ data Worker = Worker -- Think about how to handle process exit -- Tear down subprocess on exit? (terminiteProcess) -start :: LogIdentity -> LogState -> IO Worker -start id s = +startWorkerProcess :: IO Worker +startWorkerProcess = do (Just i, Just o, _, p) <- createProcess pSpec - pure (Worker i o p id s) + pure (Worker i o p) where pSpec = (proc "urbit-worker" []) { std_in = CreatePipe @@ -124,7 +120,8 @@ data WorkerExn | BadPleaNoun Noun | ReplacedEventDuringReplay EventId ReplacementEv | WorkerConnectionClosed - | UnexpectedInitialPlea Plea + | UnexpectedPleaOnNewShip Plea + | InvalidInitialPlea Plea deriving (Show) instance Exception WorkerExn @@ -167,18 +164,21 @@ sendAndRecv w eventId event = Stdr _ cord -> print cord >> loop Slog _ pri t -> printTank pri t >> loop -sendBootEvent :: Worker -> IO () -sendBootEvent w = do - sendAtom w $ jam $ toNoun (Cord "boot", (identity w)) +sendBootEvent :: LogIdentity -> Worker -> IO () +sendBootEvent id w = do + sendAtom w $ jam $ toNoun (Cord "boot", id) -- the ship is booted, but it is behind. shove events to the worker until it is -- caught up. -replay :: Worker -> WorkerState -> EventId +replay :: Worker + -> WorkerState + -> LogIdentity + -> EventId -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) -> IO () -replay w (wid, wmug) lastCommitedId getEvents = do - when (wid == 1) (sendBootEvent w) +replay w (wid, wmug) identity lastCommitedId getEvents = do + when (wid == 1) (sendBootEvent identity w) loop wid where @@ -195,25 +195,44 @@ replay w (wid, wmug) lastCommitedId getEvents = do loop (curEvent + toRead) -startPier :: Worker -> IO (EventId) -startPier w = + +bootWorker :: Worker + -> LogIdentity + -> Pill + -> IO () +bootWorker w identity pill = + do + recvPlea w >>= \case + Play Nil -> pure () + x@(Play _) -> throwIO (UnexpectedPleaOnNewShip x) + x -> throwIO (InvalidInitialPlea x) + + -- TODO: actually boot the pill + undefined + + requestSnapshot w + + -- Maybe return the current event id ? But we'll have to figure that out + -- later. + pure () + +resumeWorker :: Worker + -> LogIdentity + -> EventId + -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) + -> IO () +resumeWorker w identity logLatestEventNumber eventFetcher = do ws@(eventId, mug) <- recvPlea w >>= \case Play Nil -> pure (1, Mug 0) Play (NotNil (e, m, _)) -> pure (e, m) - x -> throwIO (UnexpectedInitialPlea x) + x -> throwIO (InvalidInitialPlea x) - logLatestEventNumber <- Log.latestEventNumber (wLogState w) - - when (logLatestEventNumber == 0) $ do - -- todo: boot. we need a pill. - undefined - - replay w ws logLatestEventNumber (Log.readEvents (wLogState w)) + replay w ws identity logLatestEventNumber eventFetcher requestSnapshot w - pure (logLatestEventNumber) + pure () workerThread :: Worker -> IO (Async ()) workerThread w = undefined From 4f52382a757729f02b48553780bcef798feb4678 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Tue, 18 Jun 2019 17:04:57 -0700 Subject: [PATCH 069/431] Various Fixes and Improvements. --- pkg/hs-urbit/lib/Vere.hs | 28 +--------------- pkg/hs-urbit/lib/Vere/Http.hs | 6 ++++ pkg/hs-urbit/lib/Vere/Http/Client.hs | 1 + pkg/hs-urbit/lib/Vere/Http/Server.hs | 11 ++++-- pkg/hs-urbit/lib/Vere/Pier.hs | 4 +-- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 50 +++++++++++++++++++++++++--- pkg/hs-urbit/lib/Vere/Worker.hs | 44 ++++++++++++++++-------- 7 files changed, 95 insertions(+), 49 deletions(-) diff --git a/pkg/hs-urbit/lib/Vere.hs b/pkg/hs-urbit/lib/Vere.hs index 9cd0b539d..5a68023aa 100644 --- a/pkg/hs-urbit/lib/Vere.hs +++ b/pkg/hs-urbit/lib/Vere.hs @@ -3,32 +3,6 @@ module Vere where import ClassyPrelude import Data.Void import Data.Noun -import qualified Vere.Http.Server as Server -import qualified Vere.Http.Client as Client +import Vere.Pier.Types -- +vere ----------------------------------------------------------------------- - -data WTFIsThis - = WTFIsThis (Maybe Varience) Eff - -data Varience = Gold | Iron | Lead - -data Eff - = HttpServer Server.Eff - | HttpClient Client.Eff - | Behn Void - | Clay Void - | Boat Void - | Sync Void - | Newt Void - | Ames Void - | Init Void - | Term Void - - -type Perform = Eff -> IO () - -data IODriver = IODriver - { bornEvent :: IO Noun - , startDriver :: (Noun -> STM ()) -> IO (Async (), Perform) - } diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index 6d034840a..0b1197f6a 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -10,6 +10,7 @@ import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Method as H data Header = Header Text Text + deriving (Eq, Ord, Show) type Method = H.StdMethod @@ -19,17 +20,22 @@ data Request = Request , headerList :: [Header] , body :: Maybe ByteString } + deriving (Eq, Ord, Show) data ResponseHeader = ResponseHeader { statusCode :: Int , headers :: [Header] } + deriving (Eq, Ord, Show) + data Event = Started ResponseHeader -- [%start hdr (unit octs) ?] | Received ByteString -- [%continue [~ octs] %.n] | Done -- [%continue ~ %.y] | Canceled -- %cancel | Failed Text -- %cancel + deriving (Eq, Ord, Show) + convertHeaders :: [HT.Header] -> [Header] convertHeaders = fmap f diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index 2261c1ab4..247b41670 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Client.hs @@ -21,6 +21,7 @@ data Ev = Receive ReqId Event -- [%receive @ todo] data Eff = NewReq ReqId Request -- [%request @ todo] | CancelReq ReqId -- [%cancel-request @] + deriving (Eq, Ord, Show) data State = State { sManager :: H.Manager diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index 2e1586a29..bc1ccb82b 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -21,11 +21,13 @@ type ConnectionId = Word type RequestId = Word data Eff = Eff ServerId ConnectionId RequestId ServerRequest + deriving (Eq, Ord, Show) -- | An http server effect is configuration, or it sends an outbound response data ServerRequest = SetConfig Config | Response Event + deriving (Eq, Ord, Show) data Config = Config { secure :: Maybe (Key, Cert) @@ -33,14 +35,17 @@ data Config = Config , log :: Bool , redirect :: Bool } + deriving (Eq, Ord, Show) + -- Note: We need to parse PEM-encoded RSA private keys and cert or cert chain -- from Wain -newtype Key = Key PEM -newtype Cert = Cert PEM +type Key = PEM +type Cert = PEM data Wain = Wain [Text] newtype PEM = PEM ByteString + deriving newtype (Eq, Ord, Show) data ClientResponse = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString) @@ -80,7 +85,7 @@ startServer :: State -> Config -> IO () startServer s c = do tls <- case (secure c) of Nothing -> error "no wai" - Just (Key (PEM key), Cert (PEM cert)) -> + Just (PEM key, PEM cert) -> pure (W.tlsSettingsMemory cert key) -- we need to do the dance where we do the socket checking dance. or shove a diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 010a24984..3a9ae2b96 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -67,7 +67,7 @@ runPierFromDisk top = do performCommonPierStartup :: Worker.Worker - -> TQueue Noun + -> TQueue Ovum -> TQueue (Writ [Eff]) -> TQueue (Writ [Eff]) -> LogState @@ -88,6 +88,6 @@ performCommonPierStartup workerState computeQueue persistQueue releaseQueue logS for_ (payload r) $ \eff -> k eff - Worker.workerThread workerState + Worker.workerThread workerState (readTQueue computeQueue) undefined pure (Pier{..}) diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index e03a8e197..20128806d 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -7,16 +7,58 @@ import Data.Noun.Atom import Data.Noun.Poet import Database.LMDB.Raw import Urbit.Time -import Vere -newtype Ovum = Ovum Void - deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) +import qualified Vere.Http.Server as Server +import qualified Vere.Http.Client as Client + +data WTFIsThis + = WTFIsThis (Maybe Varience) Eff + +data Event + = BehnBorn + | HttpBorn + | CttpBorn + deriving (Eq, Ord, Show) + +data Eff + = HttpServer Server.Eff + | HttpClient Client.Eff + | Behn Void + | Clay Void + | Boat Void + | Sync Void + | Newt Void + | Ames Void + | Init Void + | Term Void + deriving (Eq, Ord, Show) + +instance ToNoun Eff where + +instance FromNoun Eff where + + +data Varience = Gold | Iron | Lead + +type Perform = Eff -> IO () + +newtype Path = Path [Text] + deriving (Eq, Ord, Show) + +data Ovum = Ovum Path Event + deriving (Eq, Ord, Show, ToNoun, FromNoun) newtype Mug = Mug Word32 deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) newtype Jam = Jam Atom +data IODriver = IODriver + { bornEvent :: IO Ovum + , startDriver :: (Ovum -> STM ()) -> IO (Async (), Perform) + } + + data Writ a = Writ { eventId :: Word64 , timeout :: Maybe Word @@ -25,7 +67,7 @@ data Writ a = Writ } data Pier = Pier - { computeQueue :: TQueue Noun + { computeQueue :: TQueue Ovum , persistQueue :: TQueue (Writ [Eff]) , releaseQueue :: TQueue (Writ [Eff]) , logState :: LogState diff --git a/pkg/hs-urbit/lib/Vere/Worker.hs b/pkg/hs-urbit/lib/Vere/Worker.hs index 3f9b3cc3f..a9354194a 100644 --- a/pkg/hs-urbit/lib/Vere/Worker.hs +++ b/pkg/hs-urbit/lib/Vere/Worker.hs @@ -14,6 +14,8 @@ import Data.Noun.Pill import Vere.Pier.Types import System.Process +import qualified Urbit.Time as Time + import Data.ByteString (hGet) import Data.ByteString.Unsafe (unsafeUseAsCString) import Foreign.Ptr (castPtr) @@ -76,7 +78,7 @@ type Play = Nullable (EventId, Mug, ShipId) data Plea = Play Play | Work EventId Mug Job - | Done EventId Mug [Ovum] + | Done EventId Mug [Eff] | Stdr EventId Cord | Slog EventId Word32 Tank deriving (Eq, Show) @@ -107,7 +109,7 @@ type NextEventId = Word64 type WorkerState = (EventId, Mug) type ReplacementEv = (EventId, Mug, Job) -type WorkResult = (EventId, Mug, [Ovum]) +type WorkResult = (EventId, Mug, [Eff]) type WorkerResp = (Either ReplacementEv WorkResult) -- Exceptions ------------------------------------------------------------------ @@ -176,24 +178,26 @@ replay :: Worker -> LogIdentity -> EventId -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) - -> IO () + -> IO (EventId, Mug) replay w (wid, wmug) identity lastCommitedId getEvents = do when (wid == 1) (sendBootEvent identity w) - loop wid + vLast <- newIORef (wid, wmug) + loop vLast wid + readIORef vLast where -- Replay events in batches of 1000. - loop curEvent = do + loop vLast curEvent = do let toRead = min 1000 (1 + lastCommitedId - curEvent) when (toRead > 0) do events <- getEvents curEvent toRead for_ events $ \(eventId, event) -> do sendAndRecv w eventId event >>= \case - (Left ev) -> throwIO (ReplacedEventDuringReplay eventId ev) - (Right _) -> pure () + Left ev -> throwIO (ReplacedEventDuringReplay eventId ev) + Right (id, mug, _) -> writeIORef vLast (id, mug) - loop (curEvent + toRead) + loop vLast (curEvent + toRead) bootWorker :: Worker @@ -220,7 +224,7 @@ resumeWorker :: Worker -> LogIdentity -> EventId -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) - -> IO () + -> IO (EventId, Mug) resumeWorker w identity logLatestEventNumber eventFetcher = do ws@(eventId, mug) <- recvPlea w >>= \case @@ -228,14 +232,28 @@ resumeWorker w identity logLatestEventNumber eventFetcher = Play (NotNil (e, m, _)) -> pure (e, m) x -> throwIO (InvalidInitialPlea x) - replay w ws identity logLatestEventNumber eventFetcher + r <- replay w ws identity logLatestEventNumber eventFetcher requestSnapshot w - pure () + pure r -workerThread :: Worker -> IO (Async ()) -workerThread w = undefined +workerThread :: Worker -> STM Ovum -> (EventId, Mug) -> IO (Async ()) +workerThread w getEvent (evendId, mug) = async $ forever do + ovum <- atomically $ getEvent + + currentDate <- Time.now + + let mat = jam (undefined (mug, currentDate, ovum)) + + undefined + + -- Writ (eventId + 1) Nothing mat + -- -- assign a new event id. + -- -- assign a date + -- -- get current mug state + -- -- (jam [mug event]) + -- sendAndRecv requestSnapshot :: Worker -> IO () requestSnapshot w = undefined From f0848ee769794a5f8038d0691bfde2faec9c75a2 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 19 Jun 2019 16:16:07 -0700 Subject: [PATCH 070/431] Cleanup --- pkg/hs-conq/lib/Language/Conq.hs | 331 ++++++++++++++++++------------- 1 file changed, 195 insertions(+), 136 deletions(-) diff --git a/pkg/hs-conq/lib/Language/Conq.hs b/pkg/hs-conq/lib/Language/Conq.hs index f3501ae21..34e1c0e65 100644 --- a/pkg/hs-conq/lib/Language/Conq.hs +++ b/pkg/hs-conq/lib/Language/Conq.hs @@ -18,85 +18,75 @@ import qualified Prelude as P -------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- + type Tup a b = (a, b) + data Sum a b = L a | R b deriving (Eq, Ord) -instance (Show a, Show b) => Show (Sum a b) where - show (L x) = case show x of { "()" → "0"; xs → "0" <> xs } - show (R x) = case show x of { "()" → "1"; xs → "1" <> xs } - --------------------------------------------------------------------------------- - -data Lit - = Nil - | LTup Lit Lit - | LLef Lit - | LRit Lit - deriving (Eq, Ord) - -instance Show Lit where - show = \case - Nil -> "~" - LTup x y -> "[" <> show x <> " " <> show y <> "]" - LLef Nil -> "1" - LRit Nil -> "0" - LLef l -> " show l <> ">" - LRit r -> " show r <> ">" - --------------------------------------------------------------------------------- - -class ToLit a where - toLit :: a -> Lit - -instance ToLit () where - toLit () = Nil - -instance (ToLit a, ToLit b) => ToLit (Sum a b) where - toLit (L l) = LLef (toLit l) - toLit (R r) = LRit (toLit r) - -instance (ToLit a, ToLit b) => ToLit (Tup a b) where - toLit (l, r) = LTup (toLit l) (toLit r) - --------------------------------------------------------------------------------- - data Val - = VN - | V0 Val - | V1 Val - | VP Val Val + = VV -- Void + | VN -- Null + | V0 Val -- Left + | V1 Val -- Right + | VP Val Val -- Pair + deriving (Eq, Ord) instance Show Val where show = show . valExp +crash :: Exp +crash = EWith ENull (EWith EEval EEval) + valExp :: Val -> Exp -valExp VN = ENull -valExp v = EWith ENull (go v) +valExp VN = ENull +valExp VV = crash +valExp v = EWith ENull (go v) where go = \case + VV → crash VN → ENull - V0 VN → ELeft - V1 VN → EWrit + V0 VN → ELeft + V1 VN → EWrit V0 l → EWith (go l) ELeft V1 r → EWith (go r) EWrit VP x y → ECons (go x) (go y) data TyExp - = TENil - | TESum TyExp TyExp - | TETup TyExp TyExp - | TEFor TyExp TyExp - | TEAll TyExp - | TEFix TyExp - | TERef Int + = TENil + | TESum TyExp TyExp + | TETup TyExp TyExp + | TEFor TyExp TyExp + | TEAll TyExp + | TEFix TyExp + | TERef Int + deriving (Eq, Ord) + +instance Show TyExp where + show = \case + TESum TENil TENil -> "?" + TENil -> "~" + TESum x y -> "<" <> show x <> " " <> show y <> ">" + TETup x y -> "(" <> show x <> " " <> show y <> ")" + TEFor x y -> "[" <> show x <> " " <> show y <> "]" + TEAll x -> "A" <> show x + TEFix x -> "F" <> show x + TERef x -> show x data Ty - = TNil - | TSum Ty Ty - | TTup Ty Ty - | TFor Ty Ty - | TVar Int + = TNil + | TSum Ty Ty + | TTup Ty Ty + | TFor Ty Ty + | TVar Int + deriving (Eq, Ord) + +tBit :: TyExp +tBit = TESum TENil TENil + +tBitOp :: TyExp +tBitOp = TEFor tBit tBit instance Show Ty where show = \case @@ -106,15 +96,41 @@ instance Show Ty where TFor x y -> "(" <> show x <> " => " <> show y <> ")" TVar x -> show x +tyExpTy :: TyExp -> Infer Ty +tyExpTy = go [] + where + go :: [Int] -> TyExp -> Infer Ty + go t = \case + TENil -> pure TNil + TESum x y -> TSum <$> go t x <*> go t y + TETup x y -> TTup <$> go t x <*> go t y + TEFor x y -> TFor <$> go t x <*> go t y + TEAll x -> do t' <- (:t) <$> mkTVar + go t' x + TEFix x -> do t' <- (:t) <$> mkTVar + go t' x + TERef i -> pure $ TVar (t P.!! i) + +declare :: Ty -> TyExp -> Infer Ty +declare t e = do + te <- tyExpTy e + unify t te + +checkType :: Exp -> Either Text Ty +checkType e = runInfer (infer e >>= finalize) + type Unique = Int -type Infer a = ExceptT () (State (Map Int Ty, Unique)) a +type Infer a = ExceptT Text (State (Map Int Ty, Unique)) a type Unify a = Maybe a -forAll :: Infer Ty -forAll = do +mkTVar :: Infer Int +mkTVar = do (env, n) <- get put (env, n+1) - pure (TVar n) + pure n + +forAll :: Infer Ty +forAll = TVar <$> mkTVar varIs :: Int -> Ty -> Infer Ty varIs v (TVar x) | x==v = do @@ -138,19 +154,21 @@ finalize' = \case unify :: Ty -> Ty -> Infer Ty unify x y = do + -- traceM $ "UNIFY " <> show x <> " " <> show y x <- case x of { TVar v -> resolve v; x -> pure x } y <- case y of { TVar v -> resolve v; y -> pure y } unify' x y unify' :: Ty -> Ty -> Infer Ty unify' = curry \case - ( TNil, TNil ) -> pure TNil - ( TSum a1 b1, TSum a2 b2 ) -> TSum <$> unify a1 a2 <*> unify b1 b2 - ( TTup a1 b1, TTup a2 b2 ) -> TTup <$> unify a1 a2 <*> unify b1 b2 - ( TFor a1 b1, TFor a2 b2 ) -> TFor <$> unify a1 a2 <*> unify b1 b2 - ( ty, TVar x ) -> varIs x ty - ( TVar x, ty ) -> varIs x ty - ( _x, _y ) -> throwE () + ( TNil, TNil ) → pure TNil + ( TSum a1 b1, TSum a2 b2 ) → TSum <$> unify a1 a2 <*> unify b1 b2 + ( TTup a1 b1, TTup a2 b2 ) → TTup <$> unify a1 a2 <*> unify b1 b2 + ( TFor a1 b1, TFor a2 b2 ) → TFor <$> unify a1 a2 <*> unify b1 b2 + ( ty, TVar x ) → varIs x ty + ( TVar x, ty ) → varIs x ty + ( x, y ) → throwE + $ "Bad unify: " <> tshow x <> " " <> tshow y resolve :: Int -> Infer Ty resolve v = do @@ -163,14 +181,10 @@ resolve v = do expectFor :: Ty -> Infer (Ty, Ty, Ty) expectFor = \case ty@(TFor x y) -> pure (ty, x, y) - _ -> throwE () + t -> throwE ("Not a formula: " <> tshow t) -eitherToMaybe :: Either a b -> Maybe b -eitherToMaybe (P.Left _) = Nothing -eitherToMaybe (P.Right x) = Just x - -runInfer :: Infer a -> Maybe a -runInfer = eitherToMaybe . flip evalState (mempty, 0) . runExceptT +runInfer :: Infer a -> Either Text a +runInfer = flip evalState (mempty, 0) . runExceptT infer :: Exp -> Infer Ty infer = \case @@ -224,6 +238,10 @@ infer = \case unify po qo pure (TFor (TSum pi qi) po) + EType t -> do + tt <- tyExpTy t + pure (TFor tt tt) + data Exp = ESubj | ENull @@ -236,6 +254,7 @@ data Exp | EWith Exp Exp | ECons Exp Exp | ECase Exp Exp + | EType TyExp deriving (Eq, Ord) runExp :: Val -> Exp -> Val @@ -280,49 +299,51 @@ forVal = \e -> EDist -> V1 $ V1 $ V0 $ V1 VN ECase x y -> V1 $ V1 $ V1 $ V0 $ VP (forVal x) (forVal y) ECons x y -> V1 $ V1 $ V1 $ V1 $ VP (forVal x) (forVal y) + EType _ -> V1 $ V0 $ V1 VN -- Subj valFor :: Val -> Exp -valFor (V0 l) = valOpk l +valFor (V0 l) = valOpk l valFor (V1 (VP x y)) = EWith (valOpk x) (valFor y) -valFor _ = ENull +valFor _ = ENull valOpk :: Val -> Exp -valOpk (V0 (V0 x)) = valDir x -valOpk (V0 (V1 x)) = valGet x -valOpk (V1 (V0 x)) = valSim x +valOpk (V0 (V0 x)) = valDir x +valOpk (V0 (V1 x)) = valGet x +valOpk (V1 (V0 x)) = valSim x valOpk (V1 (V1 (V0 x))) = valOtr x valOpk (V1 (V1 (V1 x))) = valPlx x -valOpk _ = ENull +valOpk _ = ENull valDir :: Val -> Exp valDir (V0 VN) = ELeft valDir (V1 VN) = EWrit -valDir _ = ENull +valDir _ = ENull valGet :: Val -> Exp valGet (V0 VN) = EHead valGet (V1 VN) = ETail -valGet _ = ENull +valGet _ = ENull valSim :: Val -> Exp valSim (V0 VN) = ENull valSim (V1 VN) = ESubj -valSim _ = ENull +valSim _ = ENull valOtr :: Val -> Exp valOtr (V0 VN) = EEval valOtr (V1 VN) = EDist -valOtr _ = ENull +valOtr _ = ENull valPlx :: Val -> Exp valPlx (V0 (VP x y)) = ECase (valFor x) (valFor y) valPlx (V1 (VP x y)) = ECons (valFor x) (valFor y) -valPlx _ = ENull +valPlx _ = ENull -- Small-Step Interpreter ------------------------------------------------------ step :: Val -> Exp -> (Val, Exp) +step VV = const (VV, ESubj) step s = \case ENull -> (VN, ESubj) ESubj -> (s, ESubj) @@ -332,57 +353,44 @@ step s = \case (s', x' ) -> (s', EWith x' y) EEval -> case s of VP s' f' -> (s', valFor f') - _ -> (VN, ESubj) + _ -> (VV, ESubj) ECons ESubj ESubj -> (VP s s, ESubj) ECons x y -> (VP (runExp s x) (runExp s y), ESubj) ELeft -> (V0 s, ESubj) EWrit -> (V1 s, ESubj) EHead -> case s of VP x _ -> (x, ESubj) - _ -> (VN, ESubj) + _ -> (VV, ESubj) ETail -> case s of VP _ y -> (y, ESubj) - _ -> (VN, ESubj) + _ -> (VV, ESubj) EDist -> case s of VP (V0 l) x -> (V0 (VP l x), ESubj) VP (V1 r) x -> (V1 (VP r x), ESubj) - _ -> (VN, ESubj) + _ -> (VV, ESubj) ECase p q -> case s of V0 l -> (l, p) V1 r -> (r, q) - _ -> (VN, ESubj) + _ -> (VV, ESubj) + EType _ -> (s, ESubj) displayExp :: Exp -> String displayExp (EWith x y) = displayExp x <> "\n" <> displayExp y displayExp x = "\t" <> show x -traceRunExp :: Val -> Exp -> IO () +traceRunExp :: Val -> Exp -> IO Val traceRunExp s e = do putStrLn (tshow (valExp s)) putStrLn (pack $ displayExp e) void getLine case e of - ESubj -> putStrLn "DONE" + ESubj -> do putStrLn "DONE" + pure s _ -> uncurry traceRunExp (step s e) -traceRun :: Conq () r -> IO () +traceRun :: Conq () r -> IO Val traceRun = traceRunExp VN . toExp -{- -run sut = \case - Null -> () - Subj -> sut - With x y -> run (run sut x) y - Eval -> case sut of (s,f) -> run s f - Cons x y -> (run sut x, run sut y) - Left -> L sut - Writ -> R sut - Head -> fst sut - Tail -> snd sut - Dist -> case sut of { (L l,x) -> L (l,x); (R r,x) -> R (r,x); } - Case p q -> case sut of { L l -> run l p; R r -> run r q; } --} - flattenCons :: Exp -> Exp -> [Exp] flattenCons = \x -> go [x] where @@ -402,23 +410,64 @@ instance Show Exp where EWith x y -> show y <> show x ECons x y -> "(" <> show x <> " " <> show y <> ")" ECase x y -> "<" <> show x <> " " <> show y <> ">" + EType t -> "{" <> show t <> "}" --------------------------------------------------------------------------------- +parseSimpl :: String -> Maybe (Exp, String) +parseSimpl = \case + '.' : xs -> pure (ESubj, xs) + '~' : xs -> pure (ENull, xs) + '!' : xs -> pure (EEval, xs) + '0' : xs -> pure (ELeft, xs) + '1' : xs -> pure (EWrit, xs) + '-' : xs -> pure (EHead, xs) + '+' : xs -> pure (ETail, xs) + '%' : xs -> pure (EDist, xs) + _ -> Nothing -class ToConq a s r where - toConq :: a -> Conq s r +parseExp :: String -> Either String (Exp, String) +parseExp str = do + case parseSimpl str of + Just (e, xs) -> pure (e, xs) + Nothing -> + case str of + '(':xs -> parseTwo ECons ')' xs + '<':xs -> parseTwo ECase '>' xs + '`':xs -> parseSeq '`' xs <&> \(e,cs) -> (valExp (forVal e), cs) + _ -> P.Left "bad" -instance ToConq (Conq s a, Conq a r) s r where - toConq (x,y) = With x y +repl :: IO () +repl = go VN + where + go sut = do + ln <- unpack <$> getLine + P.Right (exp,"") <- pure (parseSeq '\n' ln) + sut <- pure (runExp sut exp) + putStrLn ("-> " <> tshow sut) + putStrLn "" + go sut -instance ToConq (Conq s a, Conq a b, Conq b r) s r where - toConq (x,y,z) = With (toConq (x,y)) z +parseSeq :: Char -> String -> Either String (Exp, String) +parseSeq end = go >=> \case + (Just x, buf) -> pure (x, buf) + (Nothing, buf) -> P.Left "empty sequence" + where + go :: String -> Either String (Maybe Exp, String) + go = \case + [] -> pure (Nothing, []) + c : cd | c == end -> pure (Nothing, cd) + cs -> do + (x, buf) <- parseExp cs + (y, buf) <- go buf + case y of + Nothing -> pure (Just x, buf) + Just y -> pure (Just (EWith y x), buf) -instance ToConq (Conq s a, Conq a b, Conq b c, Conq c r) s r where - toConq (x,y,z,p) = With (toConq (x,y,z)) p - -instance ToConq (Conq s a, Conq a b, Conq b c, Conq c d, Conq d r) s r where - toConq (x,y,z,p,q) = With (toConq (x,y,z,p)) q +parseTwo :: (Exp -> Exp -> Exp) -> Char -> String + -> Either String (Exp, String) +parseTwo cntr end buf = do + (xs, buf) <- parseSeq ' ' buf + (ys, buf) <- parseSeq end buf + pure (cntr xs ys, buf) -------------------------------------------------------------------------------- @@ -429,11 +478,11 @@ data Conq s r where Writ :: Conq b (Sum a b) Head :: Conq (Tup a b) a Tail :: Conq (Tup a b) b - Cons :: Conq s a -> Conq s b -> Conq s (a, b) + Cons :: Conq s a -> Conq s b -> Conq s (Tup a b) Case :: Conq a r -> Conq b r -> Conq (Sum a b) r - Dist :: Conq (Sum a b,s) (Sum (a,s) (b,s)) - With :: Conq s a -> Conq a r -> Conq s r - Eval :: Conq (a, Conq a r) r + Dist :: Conq (Tup (Sum a b) s) (Sum (Tup a s) (Tup b s)) + With :: (Conq s a) -> ((Conq a r) -> (Conq s r)) + Eval :: Conq (Tup a (Conq a r)) r instance Category Conq where id = Subj @@ -455,8 +504,8 @@ run sut = \case Writ -> R sut Head -> fst sut Tail -> snd sut - Dist -> case sut of { (L l,x) -> L (l,x); (R r,x) -> R (r,x); } - Case p q -> case sut of { L l -> run l p; R r -> run r q; } + Dist -> case sut of (L l, x) -> L (l, x); (R r, x) -> R (r, x) + Case p q -> case sut of L l -> run l p; R r -> run r q times :: Int -> Conq s s -> Conq s s times 0 _ = id @@ -493,7 +542,7 @@ fromExp = \case ESubj -> case testEquality (typeRep @s) (typeRep @r) of Just Refl -> Just (coerce Subj) - Nothing -> Nothing + Nothing -> Nothing _ -> Nothing @@ -804,6 +853,16 @@ n10 = Writ . n9 -------------------------------------------------------------------------------- +type Tramp c a r = Conq (a,c) (Sum a r) + +spinTr :: Tramp c a () +spinTr = Left . Head + + +-- ((arg (ctx for)) fireTramp) -> %(!((arg ctx) for) (ctx for)) +-- fireTramp = Payload +-- fireTramp = undefined + -- ctx for -> (ctx for) gate :: Val -> Exp -> Val gate v e = VP v (forVal e) @@ -875,7 +934,7 @@ fireRit = EWith (toExp reOrg) EEval type Payload = (Val, Exp) -demo :: Payload -> IO () +demo :: Payload -> IO Val demo (s,f) = traceRunExp s f dumbLoop :: Exp @@ -884,13 +943,13 @@ dumbLoop = EWith (ECons ESubj ESubj) EEval dumbLoopP :: Payload dumbLoopP = (forVal dumbLoop, dumbLoop) -demo_dumb_loop :: IO () +demo_dumb_loop :: IO Val demo_dumb_loop = demo dumbLoopP -demo_duo_overflow :: IO () +demo_duo_overflow :: IO Val demo_duo_overflow = traceRun (duo_incer . times 3 (eat . duo_incer) . duo_zero) -demo_nat_constr :: IO () +demo_nat_constr :: IO Val demo_nat_constr = traceRun n10 -- [[-e +] +]! @@ -905,7 +964,7 @@ natOverflow = EWith (ECons (ECons (EWith EHead EWrit) ETail) ETail) EEval natOverflowPay :: Payload natOverflowPay = fix (V0 VN) EWrit -demo_nat_inc_loop :: IO () +demo_nat_inc_loop :: IO Val demo_nat_inc_loop = demo natOverflowPay duo_zero_val :: Val @@ -914,5 +973,5 @@ duo_zero_val = VP (V0 VN) (V0 (VN)) short_zero_val :: Val short_zero_val = runExp VN (toExp short_zero) -short_inc_loop :: IO () +short_inc_loop :: IO Val short_inc_loop = demo $ fix (V0 short_zero_val) (toExp (short_incer . eat)) From f3cf0688c9e4cf594b82143e65b9e7e01ff07377 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 20 Jun 2019 10:13:34 -0700 Subject: [PATCH 071/431] Conq: jets, lazy thunks, and grains. --- pkg/hs-conq/lib/Language/Conq.hs | 245 ++++++++++++++++++++++++++----- pkg/hs-conq/package.yaml | 2 + stack.yaml | 1 + 3 files changed, 212 insertions(+), 36 deletions(-) diff --git a/pkg/hs-conq/lib/Language/Conq.hs b/pkg/hs-conq/lib/Language/Conq.hs index 34e1c0e65..4e9ad5f80 100644 --- a/pkg/hs-conq/lib/Language/Conq.hs +++ b/pkg/hs-conq/lib/Language/Conq.hs @@ -1,22 +1,24 @@ module Language.Conq where -import ClassyPrelude hiding ((<.>), Left, Right) +import ClassyPrelude hiding ((<.>), Left, Right, hash) import Data.Type.Equality import Type.Reflection import Data.Coerce import GHC.Natural import Control.Category -import Control.Monad.State (State, get, put, evalState, runState) -import Control.Monad.Except (ExceptT, runExceptT) +import Data.Flat + +import Control.Lens ((&)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.State (State, get, put, evalState, runState) import Control.Monad.Trans.Except (throwE) +import Data.Bits ((.|.), shiftL, shiftR) +import System.IO.Unsafe (unsafePerformIO) +import Text.Show (showString, showParen) -import Control.Lens ((&)) -import Data.Bits ((.|.), shiftL, shiftR) -import Text.Show (showString, showParen) - -import qualified Prelude as P - --------------------------------------------------------------------------------- +import qualified Prelude as P +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base58 as Base58 -------------------------------------------------------------------------------- @@ -25,13 +27,19 @@ type Tup a b = (a, b) data Sum a b = L a | R b deriving (Eq, Ord) +-- SHA256 +newtype SHA256 = SHA256 { unSHA256 :: ByteString } + deriving newtype (Eq, Ord, Flat, Show, Hashable, NFData) + data Val - = VV -- Void - | VN -- Null - | V0 Val -- Left - | V1 Val -- Right - | VP Val Val -- Pair - deriving (Eq, Ord) + = VV -- Void + | VN -- Null + | V0 !Val -- Left + | V1 !Val -- Right + | VP !Val !Val -- Pair + | VT !Val !Exp Val + | VR !SHA256 + deriving (Eq, Ord, Generic, Flat) instance Show Val where show = show . valExp @@ -39,19 +47,77 @@ instance Show Val where crash :: Exp crash = EWith ENull (EWith EEval EEval) +grainery :: IORef (HashMap SHA256 ByteString) +grainery = unsafePerformIO (newIORef grainsFromJets) + +grainsFromJets :: HashMap SHA256 ByteString +grainsFromJets = do + mapFromList $ jetReg <&> \(h,e,_) -> (h, flat (forVal e)) + +jetReg :: [(SHA256, Exp, Val -> Val)] +jetReg = + [ ( SHA256 (encodeBase58 "FWz5mTGmuVz2b4TLNa7yMjTKL7wihsEWakoUD2nzqP6q") + , ESubj + , id + ) + ] + +jets :: HashMap SHA256 (Val -> Val) +jets = mapFromList (jetReg <&> \(h,_,f) -> (h,f)) + +runTent :: SHA256 -> Exp -> Val -> Val +runTent k exp arg = + lookup k jets & \case + Nothing -> runExp arg exp + Just fn -> trace ("running jet " <> show (ETent k)) (fn arg) + +decodeBase58 :: ByteString -> Text +decodeBase58 = decodeUtf8 . Base58.encodeBase58 Base58.bitcoinAlphabet + +fromJust (Just x) = x +fromJust _ = error "fromJust: Nothing" + +encodeBase58 :: Text -> ByteString +encodeBase58 = fromJust + . Base58.decodeBase58 Base58.bitcoinAlphabet + . encodeUtf8 + +putGrain :: Val -> Val +putGrain v = unsafePerformIO $ do + (bs, k) <- evaluate $ force (hashVal v) + traceM ("Putting Grain: " <> unpack (decodeBase58 $ unSHA256 k)) + atomicModifyIORef' grainery (\t -> (insertMap k bs t, ())) + evaluate (VR k) + +getGrain :: SHA256 -> Val +getGrain k = unsafePerformIO $ do + traceM ("Getting Grain: " <> unpack (decodeBase58 $ unSHA256 k)) + + t <- readIORef grainery + + Just (P.Right v) <- pure (unflat <$> lookup k t) + + pure v + valExp :: Val -> Exp valExp VN = ENull valExp VV = crash valExp v = EWith ENull (go v) where go = \case - VV → crash - VN → ENull - V0 VN → ELeft - V1 VN → EWrit - V0 l → EWith (go l) ELeft - V1 r → EWith (go r) EWrit - VP x y → ECons (go x) (go y) + VV → crash + VN → ESubj + V0 VN → ELeft + V1 VN → EWrit + V0 l → EWith (go l) ELeft + V1 r → EWith (go r) EWrit + VP x y → ECons (go x) (go y) + VT _ _ v → go v + VR k → EWith (go (getGrain k)) EHash + +hashVal :: Val -> (ByteString, SHA256) +hashVal x = (bs, SHA256 (SHA256.hash bs)) + where bs = flat x data TyExp = TENil @@ -61,7 +127,7 @@ data TyExp | TEAll TyExp | TEFix TyExp | TERef Int - deriving (Eq, Ord) + deriving (Eq, Ord, Generic, Flat) instance Show TyExp where show = \case @@ -242,6 +308,12 @@ infer = \case tt <- tyExpTy t pure (TFor tt tt) + EPush -> throwE "infer: EPush" -- TODO + EPull -> throwE "infer: EPull" -- TODO + EHash -> throwE "infer: EHash" -- TODO + EFall -> throwE "infer: EFall" -- TODO + ETent _ -> throwE "infer: ETent" -- TODO + data Exp = ESubj | ENull @@ -255,7 +327,12 @@ data Exp | ECons Exp Exp | ECase Exp Exp | EType TyExp - deriving (Eq, Ord) + | ETent SHA256 + | EPush + | EPull + | EHash + | EFall + deriving (Eq, Ord, Generic, Flat) runExp :: Val -> Exp -> Val runExp s ESubj = s @@ -265,10 +342,11 @@ runExp s e = uncurry runExp (step s e) {- for = - opk = < > + opk = < < > dir = get = <- +> sim = <~ .> + hin = < <@ ^>> otr = plx = <@ :> -} @@ -293,13 +371,18 @@ forVal = \e -> EWrit -> V0 $ V0 $ V1 VN EHead -> V0 $ V1 $ V0 VN ETail -> V0 $ V1 $ V1 VN - ENull -> V1 $ V0 $ V0 VN - ESubj -> V1 $ V0 $ V1 VN + ENull -> V1 $ V0 $ V0 $ V0 VN + ESubj -> V1 $ V0 $ V0 $ V1 VN + EPush -> V1 $ V0 $ V1 $ V0 $ V0 VN + EPull -> V1 $ V0 $ V1 $ V0 $ V1 VN + EHash -> V1 $ V0 $ V1 $ V1 $ V0 VN + EFall -> V1 $ V0 $ V1 $ V1 $ V1 $ V0 VN + ETent ref -> V1 $ V0 $ V1 $ V1 $ V1 $ V1 (hashToVal ref) EEval -> V1 $ V1 $ V0 $ V0 VN EDist -> V1 $ V1 $ V0 $ V1 VN ECase x y -> V1 $ V1 $ V1 $ V0 $ VP (forVal x) (forVal y) ECons x y -> V1 $ V1 $ V1 $ V1 $ VP (forVal x) (forVal y) - EType _ -> V1 $ V0 $ V1 VN -- Subj + EType _ -> opkVal ESubj valFor :: Val -> Exp @@ -310,7 +393,8 @@ valFor _ = ENull valOpk :: Val -> Exp valOpk (V0 (V0 x)) = valDir x valOpk (V0 (V1 x)) = valGet x -valOpk (V1 (V0 x)) = valSim x +valOpk (V1 (V0 (V0 x))) = valSim x +valOpk (V1 (V0 (V1 x))) = valHin x valOpk (V1 (V1 (V0 x))) = valOtr x valOpk (V1 (V1 (V1 x))) = valPlx x valOpk _ = ENull @@ -340,6 +424,24 @@ valPlx (V0 (VP x y)) = ECase (valFor x) (valFor y) valPlx (V1 (VP x y)) = ECons (valFor x) (valFor y) valPlx _ = ENull +valHin :: Val -> Exp +valHin = \case + V0 (V0 VN) -> EPush + V0 (V1 VN) -> EPull + V1 (V0 VN) -> EHash + V1 (V1 (V0 VN)) -> EFall + V1 (V1 (V1 hv)) -> ETent (valHash hv) + _ -> crash + +-------------------------------------------------------------------------------- + +valHash :: Val -> SHA256 +valHash = error "valHash" + +hashToVal :: SHA256 -> Val +hashToVal = error "hashToVal" + + -- Small-Step Interpreter ------------------------------------------------------ step :: Val -> Exp -> (Val, Exp) @@ -351,9 +453,15 @@ step s = \case EWith x y -> case step s x of (s', ESubj) -> (s', y) (s', x' ) -> (s', EWith x' y) - EEval -> case s of - VP s' f' -> (s', valFor f') - _ -> (VV, ESubj) + + ETent ref -> + (runTent ref (valFor (getGrain ref)) s, ESubj) + + EEval -> + case s of + VP s' f' -> (s', valFor f') + _ -> (VV, ESubj) + ECons ESubj ESubj -> (VP s s, ESubj) ECons x y -> (VP (runExp s x) (runExp s y), ESubj) ELeft -> (V0 s, ESubj) @@ -373,6 +481,17 @@ step s = \case V1 r -> (r, q) _ -> (VV, ESubj) EType _ -> (s, ESubj) + EPush -> case s of + VP s' f' -> let e = valFor f' + in traceShowId (VT s' e (runExp s' e), ESubj) + _ -> (VV, ESubj) + EPull -> case s of + VT _ _ x -> (x, ESubj) + _ -> (VV, ESubj) + EHash -> (putGrain s, ESubj) + EFall -> case s of + VR k -> (getGrain k, ESubj) + _ -> (VV, ESubj) displayExp :: Exp -> String displayExp (EWith x y) = displayExp x <> "\n" <> displayExp y @@ -411,6 +530,11 @@ instance Show Exp where ECons x y -> "(" <> show x <> " " <> show y <> ")" ECase x y -> "<" <> show x <> " " <> show y <> ">" EType t -> "{" <> show t <> "}" + EPush -> "?" + EPull -> "*" + EHash -> "@" + EFall -> "^" + ETent ref -> "|" <> take 8 (unpack $ decodeBase58 $ unSHA256 ref) <> "|" parseSimpl :: String -> Maybe (Exp, String) parseSimpl = \case @@ -422,8 +546,19 @@ parseSimpl = \case '-' : xs -> pure (EHead, xs) '+' : xs -> pure (ETail, xs) '%' : xs -> pure (EDist, xs) + '?' : xs -> pure (EPush, xs) + '*' : xs -> pure (EPull, xs) + '@' : xs -> pure (EHash, xs) + '^' : xs -> pure (EFall, xs) _ -> Nothing +parseHash :: String -> Either String (SHA256, String) +parseHash b = do + let (h,r) = splitAt 44 b + let sha = SHA256 (encodeBase58 $ pack h) + when (length h /= 44) (P.Left "short tent") + pure (sha, r) + parseExp :: String -> Either String (Exp, String) parseExp str = do case parseSimpl str of @@ -433,15 +568,21 @@ parseExp str = do '(':xs -> parseTwo ECons ')' xs '<':xs -> parseTwo ECase '>' xs '`':xs -> parseSeq '`' xs <&> \(e,cs) -> (valExp (forVal e), cs) + '|':xs -> parseHash xs >>= \case + (s, '|':xs) -> pure (ETent s, xs) + (_, _ ) -> P.Left "bad tent" _ -> P.Left "bad" repl :: IO () repl = go VN where go sut = do - ln <- unpack <$> getLine - P.Right (exp,"") <- pure (parseSeq '\n' ln) - sut <- pure (runExp sut exp) + ln <- unpack <$> getLine + exp <- parseSeq '\n' ln & \case + P.Right (e,"") -> pure e + P.Right (e,_) -> trace "extra chars" (pure e) + P.Left msg -> error msg + sut <- pure (runExp sut exp) putStrLn ("-> " <> tshow sut) putStrLn "" go sut @@ -469,6 +610,26 @@ parseTwo cntr end buf = do (ys, buf) <- parseSeq end buf pure (cntr xs ys, buf) +-- Thunks are Easy ------------------------------------------------------------- + +data Thunk a = forall s. Thunk !s !(Conq s a) a + +push :: s -> Conq s a -> Thunk a +push s f = Thunk s f (run s f) + +pull :: Thunk a -> a +pull (Thunk _ _ r) = r + +-- Refs need Serialization ----------------------------------------------------- + +data Ref a = Ref Int a -- TODO s/Int/Sha256/ + +hash :: a -> Ref a +hash x = Ref 0 x + +fall :: Ref a -> a +fall (Ref h x) = x + -------------------------------------------------------------------------------- data Conq s r where @@ -483,6 +644,10 @@ data Conq s r where Dist :: Conq (Tup (Sum a b) s) (Sum (Tup a s) (Tup b s)) With :: (Conq s a) -> ((Conq a r) -> (Conq s r)) Eval :: Conq (Tup a (Conq a r)) r + Hash :: Conq a (Ref a) + Fall :: Conq (Ref a) a + Push :: Conq (Tup s (Conq s a)) (Thunk a) + Pull :: Conq (Thunk a) a instance Category Conq where id = Subj @@ -506,6 +671,10 @@ run sut = \case Tail -> snd sut Dist -> case sut of (L l, x) -> L (l, x); (R r, x) -> R (r, x) Case p q -> case sut of L l -> run l p; R r -> run r q + Push -> uncurry push sut + Pull -> pull sut + Hash -> hash sut + Fall -> fall sut times :: Int -> Conq s s -> Conq s s times 0 _ = id @@ -534,6 +703,10 @@ toExp = \case Cons x y -> ECons (toExp x) (toExp y) Case l r -> ECase (toExp l) (toExp r) With x y -> EWith (toExp x) (toExp y) + Push -> EPush + Pull -> EPull + Hash -> EHash + Fall -> EFall -------------------------------------------------------------------------------- diff --git a/pkg/hs-conq/package.yaml b/pkg/hs-conq/package.yaml index a79c25f6e..3aa88a3d5 100644 --- a/pkg/hs-conq/package.yaml +++ b/pkg/hs-conq/package.yaml @@ -15,6 +15,8 @@ dependencies: - chunked-data - classy-prelude - containers + - cryptohash + - base58-bytestring - data-fix - extra - flat diff --git a/stack.yaml b/stack.yaml index e67d32b9a..152439f36 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,6 +9,7 @@ packages: extra-deps: - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81 - flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38 + - base58-bytestring-0.1.0@sha256:a1da72ee89d5450bac1c792d9fcbe95ed7154ab7246f2172b57bd4fd9b5eab79 nix: packages: From 4d11547c6a758430b63cd48931578ac4d8c20ae6 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 20 Jun 2019 13:00:53 -0700 Subject: [PATCH 072/431] Error recovery and inline tents. --- pkg/hs-conq/lib/Language/Conq.hs | 138 +++++++++++++++++++++++++------ pkg/hs-conq/package.yaml | 3 +- 2 files changed, 115 insertions(+), 26 deletions(-) diff --git a/pkg/hs-conq/lib/Language/Conq.hs b/pkg/hs-conq/lib/Language/Conq.hs index 4e9ad5f80..27342b219 100644 --- a/pkg/hs-conq/lib/Language/Conq.hs +++ b/pkg/hs-conq/lib/Language/Conq.hs @@ -7,6 +7,8 @@ import Data.Coerce import GHC.Natural import Control.Category import Data.Flat +import Data.Bits +import Data.Vector (generate) import Control.Lens ((&)) import Control.Monad.Except (ExceptT, runExceptT) @@ -19,6 +21,8 @@ import Text.Show (showString, showParen) import qualified Prelude as P import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B -------------------------------------------------------------------------------- @@ -343,12 +347,13 @@ runExp s e = uncurry runExp (step s e) {- for = opk = < < > + opk-alt = >> dir = get = <- +> sim = <~ .> - hin = < <@ ^>> otr = - plx = <@ :> + plx = <◆ ●> + hin = < <@ <^ |>>> -} flattenExp :: Exp -> Exp @@ -376,8 +381,8 @@ forVal = \e -> EPush -> V1 $ V0 $ V1 $ V0 $ V0 VN EPull -> V1 $ V0 $ V1 $ V0 $ V1 VN EHash -> V1 $ V0 $ V1 $ V1 $ V0 VN - EFall -> V1 $ V0 $ V1 $ V1 $ V1 $ V0 VN - ETent ref -> V1 $ V0 $ V1 $ V1 $ V1 $ V1 (hashToVal ref) + EFall -> V1 $ V0 $ V1 $ V1 $ V1 VN + ETent ref -> VR ref EEval -> V1 $ V1 $ V0 $ V0 VN EDist -> V1 $ V1 $ V0 $ V1 VN ECase x y -> V1 $ V1 $ V1 $ V0 $ VP (forVal x) (forVal y) @@ -387,6 +392,7 @@ forVal = \e -> valFor :: Val -> Exp valFor (V0 l) = valOpk l +valFor (VR r) = ETent r valFor (V1 (VP x y)) = EWith (valOpk x) (valFor y) valFor _ = ENull @@ -426,20 +432,89 @@ valPlx _ = ENull valHin :: Val -> Exp valHin = \case - V0 (V0 VN) -> EPush - V0 (V1 VN) -> EPull - V1 (V0 VN) -> EHash - V1 (V1 (V0 VN)) -> EFall - V1 (V1 (V1 hv)) -> ETent (valHash hv) - _ -> crash + V0 (V0 VN) -> EPush + V0 (V1 VN) -> EPull + V1 (V0 VN) -> EHash + V1 (V1 VN) -> EFall + _ -> crash -------------------------------------------------------------------------------- -valHash :: Val -> SHA256 -valHash = error "valHash" +-- tag :: Bool -> Val -> Val +-- tag False = V0 +-- tag True = V1 -hashToVal :: SHA256 -> Val -hashToVal = error "hashToVal" +-- unTag :: Val -> (Bool, Val) +-- unTag (V0 x) = (False, x) +-- unTag (V1 x) = (True, x) +-- unTag _ = error "unTag" + +-- toBits :: (Bits b, FiniteBits b) => b -> Vector Bool +-- toBits b = +-- generate (finiteBitSize b) (testBit b) + +-- byteVal :: Word8 -> Val +-- byteVal b = +-- foldl' (flip tag) VN (toBits b) + +-- valByte :: Val -> Word8 +-- valByte v = runIdentity $ do +-- (a, v) <- pure $ unTag v +-- (b, v) <- pure $ unTag v +-- (c, v) <- pure $ unTag v +-- (d, v) <- pure $ unTag v +-- (e, v) <- pure $ unTag v +-- (f, v) <- pure $ unTag v +-- (g, v) <- pure $ unTag v +-- (h, v) <- pure $ unTag v +-- let bits = [a, b, c, d, e, f, g, h] +-- unless (VN == v) (error "valByte: bad byte") +-- pure $ foldl' (\acc (i, x) -> if x then setBit acc (7-i) else acc) +-- 0 +-- (zip [0..] bits) + +-- data Pair a = Pair a a +-- deriving (Functor) + +-- data Quad a = Quad (Pair a) (Pair a) +-- deriving (Functor) + +-- data Oct a = Oct (Quad a) (Quad a) +-- deriving (Functor) + +-- pairVal :: Pair Val -> Val +-- pairVal (Pair x y) = VP x y + +-- quadVal :: Quad Val -> Val +-- quadVal (Quad x y) = VP (pairVal x) (pairVal y) + +-- octVal :: Oct Val -> Val +-- octVal (Oct x y) = VP (quadVal x) (quadVal y) + +-- -- Needs to be four times as big -- This throws away data +-- hashOct :: SHA256 -> Oct Word8 +-- hashOct (SHA256 bs) = +-- Oct (Quad (Pair a b) (Pair c d)) +-- (Quad (Pair e f) (Pair g h)) +-- where +-- a = B.unsafeIndex bs 0 +-- b = B.unsafeIndex bs 1 +-- c = B.unsafeIndex bs 2 +-- d = B.unsafeIndex bs 3 +-- e = B.unsafeIndex bs 4 +-- f = B.unsafeIndex bs 5 +-- g = B.unsafeIndex bs 6 +-- h = B.unsafeIndex bs 7 + +-- valHash :: Val -> SHA256 +-- valHash = \case +-- VP (VP (VP a b) (VP c d)) (VP (VP e f) (VP g h)) -> +-- SHA256 (B.pack $ valByte <$> [a, b, c, d, e, f, g, h]) +-- _ -> +-- SHA256 "" + +-- hashToVal :: SHA256 -> Val +-- hashToVal = octVal . fmap byteVal . hashOct -- Small-Step Interpreter ------------------------------------------------------ @@ -574,18 +649,31 @@ parseExp str = do _ -> P.Left "bad" repl :: IO () -repl = go VN +repl = r VN where - go sut = do - ln <- unpack <$> getLine - exp <- parseSeq '\n' ln & \case - P.Right (e,"") -> pure e - P.Right (e,_) -> trace "extra chars" (pure e) - P.Left msg -> error msg - sut <- pure (runExp sut exp) - putStrLn ("-> " <> tshow sut) - putStrLn "" - go sut + r sut = do + ln <- unpack <$> getLine + parseSeq '\n' ln & \case + P.Right (e,"") -> do + epl sut e + P.Right (e,cs) -> do + traceM ("ignoring trailing chars: " <> cs) + epl sut e + P.Left msg -> do + traceM msg + traceM "Try again\n" + r sut + + epl sut exp = do + sut' <- pure (runExp sut exp) + if (sut' == VV) + then do + putStrLn "Crash! Try again\n" + r sut + else do + putStrLn ("-> " <> tshow sut') + putStrLn "" + r sut' parseSeq :: Char -> String -> Either String (Exp, String) parseSeq end = go >=> \case diff --git a/pkg/hs-conq/package.yaml b/pkg/hs-conq/package.yaml index 3aa88a3d5..193342a87 100644 --- a/pkg/hs-conq/package.yaml +++ b/pkg/hs-conq/package.yaml @@ -11,12 +11,13 @@ library: dependencies: - async - base + - base58-bytestring + - bytestring - case-insensitive - chunked-data - classy-prelude - containers - cryptohash - - base58-bytestring - data-fix - extra - flat From de8e02f572d63c20f98509b91b6655c1adfeea4a Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 21 Jun 2019 14:17:24 -0700 Subject: [PATCH 073/431] Misc --- pkg/hs-conq/lib/Language/Conq.hs | 104 ++++++++++++++++++------------- pkg/hs-conq/package.yaml | 1 + 2 files changed, 63 insertions(+), 42 deletions(-) diff --git a/pkg/hs-conq/lib/Language/Conq.hs b/pkg/hs-conq/lib/Language/Conq.hs index 27342b219..186346e58 100644 --- a/pkg/hs-conq/lib/Language/Conq.hs +++ b/pkg/hs-conq/lib/Language/Conq.hs @@ -1,6 +1,6 @@ module Language.Conq where -import ClassyPrelude hiding ((<.>), Left, Right, hash) +import ClassyPrelude hiding ((<.>), Left, Right, hash, cons) import Data.Type.Equality import Type.Reflection import Data.Coerce @@ -9,6 +9,7 @@ import Control.Category import Data.Flat import Data.Bits import Data.Vector (generate) +import Data.Monoid.Unicode ((∅)) import Control.Lens ((&)) import Control.Monad.Except (ExceptT, runExceptT) @@ -49,7 +50,7 @@ instance Show Val where show = show . valExp crash :: Exp -crash = EWith ENull (EWith EEval EEval) +crash = EEval <> EEval <> ENull grainery :: IORef (HashMap SHA256 ByteString) grainery = unsafePerformIO (newIORef grainsFromJets) @@ -106,18 +107,18 @@ getGrain k = unsafePerformIO $ do valExp :: Val -> Exp valExp VN = ENull valExp VV = crash -valExp v = EWith ENull (go v) +valExp v = go v <> ENull where go = \case VV → crash VN → ESubj V0 VN → ELeft V1 VN → EWrit - V0 l → EWith (go l) ELeft - V1 r → EWith (go r) EWrit + V0 l → ELeft <> go l + V1 r → EWrit <> go r VP x y → ECons (go x) (go y) VT _ _ v → go v - VR k → EWith (go (getGrain k)) EHash + VR k → EHash <> go (getGrain k) hashVal :: Val -> (ByteString, SHA256) hashVal x = (bs, SHA256 (SHA256.hash bs)) @@ -138,8 +139,8 @@ instance Show TyExp where TESum TENil TENil -> "?" TENil -> "~" TESum x y -> "<" <> show x <> " " <> show y <> ">" - TETup x y -> "(" <> show x <> " " <> show y <> ")" - TEFor x y -> "[" <> show x <> " " <> show y <> "]" + TETup x y -> "[" <> show x <> " " <> show y <> "]" + TEFor x y -> "(" <> show x <> " " <> show y <> ")" TEAll x -> "A" <> show x TEFix x -> "F" <> show x TERef x -> show x @@ -254,7 +255,7 @@ expectFor = \case t -> throwE ("Not a formula: " <> tshow t) runInfer :: Infer a -> Either Text a -runInfer = flip evalState (mempty, 0) . runExceptT +runInfer = flip evalState ((∅), 0) . runExceptT infer :: Exp -> Infer Ty infer = \case @@ -338,6 +339,15 @@ data Exp | EFall deriving (Eq, Ord, Generic, Flat) +instance Semigroup Exp where + ENull <> ESubj = ENull + x <> ESubj = x + ESubj <> y = y + x <> y = EWith y x + +instance Monoid Exp where + mempty = ESubj + runExp :: Val -> Exp -> Val runExp s ESubj = s runExp s e = uncurry runExp (step s e) @@ -602,7 +612,7 @@ instance Show Exp where ETail -> "+" EDist -> "%" EWith x y -> show y <> show x - ECons x y -> "(" <> show x <> " " <> show y <> ")" + ECons x y -> "[" <> show x <> " " <> show y <> "]" ECase x y -> "<" <> show x <> " " <> show y <> ">" EType t -> "{" <> show t <> "}" EPush -> "?" @@ -640,9 +650,10 @@ parseExp str = do Just (e, xs) -> pure (e, xs) Nothing -> case str of - '(':xs -> parseTwo ECons ')' xs + '[':xs -> parseTwo ECons ']' xs '<':xs -> parseTwo ECase '>' xs - '`':xs -> parseSeq '`' xs <&> \(e,cs) -> (valExp (forVal e), cs) + '(':xs -> parseSeq ')' xs <&> \case + (e,cs) -> (valExp (forVal e), cs) '|':xs -> parseHash xs >>= \case (s, '|':xs) -> pure (ETent s, xs) (_, _ ) -> P.Left "bad tent" @@ -689,7 +700,7 @@ parseSeq end = go >=> \case (y, buf) <- go buf case y of Nothing -> pure (Just x, buf) - Just y -> pure (Just (EWith y x), buf) + Just y -> pure (Just (x <> y), buf) parseTwo :: (Exp -> Exp -> Exp) -> Char -> String -> Either String (Exp, String) @@ -1114,16 +1125,18 @@ n10 = Writ . n9 -------------------------------------------------------------------------------- -type Tramp c a r = Conq (a,c) (Sum a r) - -spinTr :: Tramp c a () -spinTr = Left . Head - - -- ((arg (ctx for)) fireTramp) -> %(!((arg ctx) for) (ctx for)) -- fireTramp = Payload -- fireTramp = undefined +-- [Lx y] -> R[x y] +-- [R[x y] z] -> R[x (compose y z)] +compose :: Exp +compose = ECase EWrit (EWrit <> recur) <> EDist + where + recur = ECons (EHead <> EHead) + (ECons (ETail <> EHead) ETail) + -- ctx for -> (ctx for) gate :: Val -> Exp -> Val gate v e = VP v (forVal e) @@ -1136,16 +1149,32 @@ identFn = gate VN (toExp Head) spinFn :: Val spinFn = gate VN fire +call :: Exp -> Exp -> Exp +call g a = fire <> ECons a g + +spin :: Exp +spin = call (valExp spinFn) ENull + -- `$-((list a) @)`: List-Length lenFn :: Val lenFn = gate (V0 VN) lenFnBody +caseHead x y = ECase x y <> EDist + +hep, lus :: Exp +hep = EHead +lus = ETail +zer = ELeft +one = EWrit + +cons :: Exp -> Exp -> Exp +cons = ECons + lenFnBody :: Exp -lenFnBody = EWith EDist - $ ECase (EWith ETail EHead) - $ EWith (ECons (EWith EHead ETail) - (EWith ETail (ECons (EWith EHead EWrit) ETail))) - $ fire +lenFnBody = caseHead (hep <> lus) + $ (fire <>) + $ cons (lus <> hep) + $ cons (one<>hep) lus <> lus swapFn :: Val swapFn = gate VN (toExp swapFnBody) @@ -1160,33 +1189,24 @@ coreTwo v l r = VP v (VP (forVal l) (forVal r)) evenOddCore :: Val evenOddCore = coreTwo VN evArm odArm -evArm :: Exp -evArm = EWith EDist - $ ECase (toExp true) - $ fireRit - -odArm :: Exp -odArm = EWith EDist - $ ECase (toExp false) - $ fireLef +evArm, odArm :: Exp +evArm = caseHead (toExp true) fireRit +odArm = caseHead (toExp false) fireLef -- (arg (ctx for)) -> ((arg (ctx for)) for)! fire :: Exp -fire = EWith (toExp reOrg) EEval - where - reOrg :: Conq (a,(c,f)) ((a,(c,f)),f) - reOrg = Cons Subj (Tail . Tail) +fire = EEval <> cons (∅) (lus <> lus) -- (arg (ctx (lfor rfor))) -> ((arg (ctx (lfor rfor))) lfor)! fireLef :: Exp -fireLef = EWith (toExp reOrg) EEval +fireLef = EEval <> toExp reOrg where reOrg :: Conq (a,(c,(l,r))) ((a,(c,(l,r))),l) reOrg = Cons Subj (Head . Tail . Tail) -- (arg (ctx (lfor rfor))) -> ((arg (ctx (lfor rfor))) rfor)! fireRit :: Exp -fireRit = EWith (toExp reOrg) EEval +fireRit = EEval <> toExp reOrg where reOrg :: Conq (a,(c,(l,r))) ((a,(c,(l,r))),r) reOrg = Cons Subj (Tail . Tail . Tail) @@ -1199,7 +1219,7 @@ demo :: Payload -> IO Val demo (s,f) = traceRunExp s f dumbLoop :: Exp -dumbLoop = EWith (ECons ESubj ESubj) EEval +dumbLoop = EEval <> ECons (∅) (∅) dumbLoopP :: Payload dumbLoopP = (forVal dumbLoop, dumbLoop) @@ -1217,10 +1237,10 @@ demo_nat_constr = traceRun n10 fix :: Val -> Exp -> Payload fix x e = (VP x (forVal fe), fe) where - fe = EWith (ECons (ECons (EWith EHead e) ETail) ETail) EEval + fe = EEval <> cons (cons (e <> hep) lus) lus natOverflow :: Exp -natOverflow = EWith (ECons (ECons (EWith EHead EWrit) ETail) ETail) EEval +natOverflow = EEval <> cons (cons (one <> hep) lus) lus natOverflowPay :: Payload natOverflowPay = fix (V0 VN) EWrit diff --git a/pkg/hs-conq/package.yaml b/pkg/hs-conq/package.yaml index 193342a87..798edf130 100644 --- a/pkg/hs-conq/package.yaml +++ b/pkg/hs-conq/package.yaml @@ -12,6 +12,7 @@ dependencies: - async - base - base58-bytestring + - base-unicode-symbols - bytestring - case-insensitive - chunked-data From f6c6cb3e71d4e39a10cf4cbd6bbbde44e4dbcf9a Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 24 Jun 2019 16:00:03 -0700 Subject: [PATCH 074/431] Unfinished refactoring. --- pkg/hs-conq/lib/Language/Conq/Axe.hs | 138 +++ pkg/hs-conq/lib/Language/Conq/Exp.hs | 130 ++ pkg/hs-conq/lib/Language/Conq/ForVal.hs | 32 + pkg/hs-conq/lib/Language/Conq/Grainary.hs | 180 +++ pkg/hs-conq/lib/Language/Conq/Mess.hs | 1356 +++++++++++++++++++++ pkg/hs-conq/lib/Language/Conq/Types.hs | 157 +++ 6 files changed, 1993 insertions(+) create mode 100644 pkg/hs-conq/lib/Language/Conq/Axe.hs create mode 100644 pkg/hs-conq/lib/Language/Conq/Exp.hs create mode 100644 pkg/hs-conq/lib/Language/Conq/ForVal.hs create mode 100644 pkg/hs-conq/lib/Language/Conq/Grainary.hs create mode 100644 pkg/hs-conq/lib/Language/Conq/Mess.hs create mode 100644 pkg/hs-conq/lib/Language/Conq/Types.hs diff --git a/pkg/hs-conq/lib/Language/Conq/Axe.hs b/pkg/hs-conq/lib/Language/Conq/Axe.hs new file mode 100644 index 000000000..a434bf340 --- /dev/null +++ b/pkg/hs-conq/lib/Language/Conq/Axe.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Conq.Axe where + +import ClassyPrelude hiding ((<.>), Left, Right, hash, cons) + +import Language.Conq.Types +import Language.Conq.Exp + +import Data.Type.Equality +import Type.Reflection +import Data.Coerce +import GHC.Natural +import Control.Category +import Data.Flat +import Data.Flat.Bits +import Data.Bits +import Data.Vector (generate) +import Data.Monoid.Unicode ((∅)) +import Data.List.NonEmpty (NonEmpty(..)) + +import Control.Lens ((&)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.State (State, get, put, evalState, runState) +import Control.Monad.Trans.Except (throwE) +import Data.Bits ((.|.), shiftL, shiftR) +import System.IO.Unsafe (unsafePerformIO) +import Text.Show (showString, showParen) + +import qualified Prelude as P +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B + + +-- Utils ----------------------------------------------------------------------- + +lef = ATong (singleton F) +rit = ATong (singleton T) + +sut = AAxis [] +hed = AAxis [F] +tel = AAxis [T] + +showFlatAxe :: Axe -> IO () +showFlatAxe a = putStrLn $ pack + $ filter (\x -> x=='0' || x=='1') + $ show + $ fmap (\x -> if x then 1 else 0) + $ toList (bits a) + + +-- Encode Axes to Vals --------------------------------------------------------- + +intVal :: Int -> Val +intVal n | n <= 0 = V0 VN +intVal n = V1 (intVal (n-1)) + +typeVal :: TyExp -> Val +typeVal = \case + TENil -> V0 $ V0 $ V0 $ VN + TESum x y -> V0 $ V0 $ V1 $ VP (typeVal x) (typeVal y) + TETup x y -> V0 $ V1 $ V0 $ VP (typeVal x) (typeVal y) + TEFor x y -> V0 $ V1 $ V1 $ VP (typeVal x) (typeVal y) + TEAll x -> V1 $ V0 $ V0 $ typeVal x + TEFix x -> V1 $ V0 $ V1 $ typeVal x + TERef i -> V1 $ V1 $ V0 $ intVal i + +axeVal :: Axe -> Val +axeVal = \case + AAxis ds -> V0 $ V0 $ V0 $ flagsVal ds + APure v -> V0 $ V0 $ V1 $ v + AEval -> V0 $ V1 $ V0 $ VN + ATong ts -> V0 $ V1 $ V1 $ flagsValNE ts + ACons x y -> V1 $ V0 $ V0 $ VP (axeVal x) (axeVal y) + ACase x y -> V1 $ V0 $ V1 $ VP (axeVal x) (axeVal y) + AWith x y -> V1 $ V1 $ V0 $ VP (axeVal x) (axeVal y) + AHint h -> V1 $ V1 $ V1 $ hintVal h + where + hintVal :: Hint -> Val + hintVal HLazy = V0 $ V0 VN + hintVal HMark = V0 $ V1 VN + hintVal (HType t) = V1 $ V0 (typeVal t) + hintVal HFast = V1 $ V1 VN + + flagsVal :: [Flag] -> Val + flagsVal [] = V0 VN + flagsVal (F:bs) = V1 (VP (V0 VN) (flagsVal bs)) + flagsVal (T:bs) = V1 (VP (V1 VN) (flagsVal bs)) + + flagsValNE :: NonEmpty Flag -> Val + flagsValNE (F :| []) = V0 (V0 VN) + flagsValNE (T :| []) = V0 (V1 VN) + flagsValNE (F :| b:bs) = V1 (VP (V0 VN) (flagsValNE (b :| bs))) + flagsValNE (T :| b:bs) = V1 (VP (V1 VN) (flagsValNE (b :| bs))) + +axeExp :: Axe -> Exp +axeExp = \case + AAxis [] -> ESubj + AAxis [F] -> EHead + AAxis [T] -> ETail + AAxis (F:ds) -> axeExp (AAxis ds) <> EHead + AAxis (T:ds) -> axeExp (AAxis ds) <> ETail + APure VN -> EPure VN + APure v -> valExp v + AEval -> EEval + ATong (F :| []) -> ELeft + ATong (T :| []) -> EWrit + ATong (F :| t:ts) -> axeExp (ATong (t :| ts)) <> ELeft + ATong (T :| t:ts) -> axeExp (ATong (t :| ts)) <> EWrit + ACons x y -> ECons (axeExp x) (axeExp y) + ACase x y -> ECase (axeExp x) (axeExp y) + AWith x y -> axeExp y <> axeExp x + AHint HLazy -> ELazy + AHint HMark -> EMark + AHint (HType ty) -> EType ty + AHint HFast -> EFast + +expAxe :: Exp -> Axe +expAxe = \case + ESubj -> AAxis [] + EPure v -> APure v + EEval -> AEval + ELeft -> ATong (singleton F) + EWrit -> ATong (singleton T) + EHead -> AAxis (singleton F) + ETail -> AAxis (singleton T) + EDist -> ACase (expAxe ELeft) (expAxe EWrit) + EWith x y -> AWith (expAxe x) (expAxe y) + ECons x y -> ACons (expAxe x) (expAxe y) + ECase x y -> ACase (expAxe x) (expAxe y) -- TODO Wrong + EType ty -> AHint (HType ty) + EMark -> AHint HMark + ELazy -> AHint HMark -- TODO + EFast -> AHint HFast + EQuot e -> APure (axeVal (expAxe e)) -- TODO Unquoting + ETape e -> expAxe (EQuot (ETape e)) diff --git a/pkg/hs-conq/lib/Language/Conq/Exp.hs b/pkg/hs-conq/lib/Language/Conq/Exp.hs new file mode 100644 index 000000000..e7d9dcfff --- /dev/null +++ b/pkg/hs-conq/lib/Language/Conq/Exp.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Conq.Exp where + +import Language.Conq.Types +import Language.Conq.Grainary + +import ClassyPrelude hiding ((<.>), Left, Right, hash, cons) +import Data.Type.Equality +import Type.Reflection +import Data.Coerce +import GHC.Natural +import Control.Category +import Data.Flat +import Data.Flat.Bits +import Data.Bits +import Data.Vector (generate) +import Data.Monoid.Unicode ((∅)) +import Data.List.NonEmpty (NonEmpty(..)) + +import Control.Lens ((&)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.State (State, get, put, evalState, runState) +import Control.Monad.Trans.Except (throwE) +import Data.Bits ((.|.), shiftL, shiftR) +import System.IO.Unsafe (unsafePerformIO) +import Text.Show (showString, showParen) + +import qualified Prelude as P +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B + + +-- Unparsing ------------------------------------------------------------------- + +dispExp :: Exp -> String +dispExp = \case + ESubj -> "." + EPure VN -> "~" + EPure v -> show (valExp v) + EEval -> "!" + ELeft -> "0" + EWrit -> "1" + EHead -> "-" + ETail -> "+" + EDist -> "%" + EWith x y -> show y <> show x + ECons x y -> "[" <> show x <> " " <> show y <> "]" + ECase x y -> "<" <> show x <> " " <> show y <> ">" + EType t -> "{" <> show t <> "}" + ELazy -> "?" + EFast -> "_" + ETape e -> "$(" <> dispExp e <> ")" + EMark -> "@" + EQuot x -> "(" <> show x <> ")" + +valExp :: Val -> Exp +valExp (valFor' -> Just e) = EQuot e +valExp VN = EPure VN +valExp VV = crash +valExp v = go v <> EPure VN + where + go = \case + (valFor' → Just e) → EQuot e + VV → crash + VN → ESubj + V0 VN → ELeft + V1 VN → EWrit + V0 l → ELeft <> go l + V1 r → EWrit <> go r + VP x y → ECons (go x) (go y) + VT x y _r → ECons (go x) y + VR k → EMark <> go (getGrain k) + +crash :: Exp +crash = EEval <> EEval <> (EPure VN) + + +-- Parsing --------------------------------------------------------------------- + +parseSimpl :: String -> Maybe (Exp, String) +parseSimpl = \case + '.' : xs -> pure (ESubj, xs) + '~' : xs -> pure (EPure VN, xs) -- TODO EPure + '!' : xs -> pure (EEval, xs) + '0' : xs -> pure (ELeft, xs) + '1' : xs -> pure (EWrit, xs) + '-' : xs -> pure (EHead, xs) + '+' : xs -> pure (ETail, xs) + '%' : xs -> pure (EDist, xs) + '?' : xs -> pure (ELazy, xs) + '@' : xs -> pure (EMark, xs) + _ -> Nothing + +parseExp :: String -> Either String (Exp, String) +parseExp str = do + case parseSimpl str of + Just (e, xs) -> pure (e, xs) + Nothing -> + case str of + '[':xs -> parseTwo ECons ']' xs + '<':xs -> parseTwo ECase '>' xs + '(':xs -> parseSeq ')' xs <&> \case + (e,cs) -> (EQuot e, cs) + _ -> P.Left "bad" + +parseSeq :: Char -> String -> Either String (Exp, String) +parseSeq end = go >=> \case + (Just x, buf) -> pure (x, buf) + (Nothing, buf) -> P.Left "empty sequence" + where + go :: String -> Either String (Maybe Exp, String) + go = \case + [] -> pure (Nothing, []) + c : cd | c == end -> pure (Nothing, cd) + cs -> do + (x, buf) <- parseExp cs + (y, buf) <- go buf + case y of + Nothing -> pure (Just x, buf) + Just y -> pure (Just (x <> y), buf) + +parseTwo :: (Exp -> Exp -> Exp) -> Char -> String + -> Either String (Exp, String) +parseTwo cntr end buf = do + (xs, buf) <- parseSeq ' ' buf + (ys, buf) <- parseSeq end buf + pure (cntr xs ys, buf) diff --git a/pkg/hs-conq/lib/Language/Conq/ForVal.hs b/pkg/hs-conq/lib/Language/Conq/ForVal.hs new file mode 100644 index 000000000..5b0a071e3 --- /dev/null +++ b/pkg/hs-conq/lib/Language/Conq/ForVal.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Conq.ForVal where + +import Language.Conq.Types + +import ClassyPrelude hiding ((<.>), Left, Right, hash, cons) +import Data.Type.Equality +import Type.Reflection +import Data.Coerce +import GHC.Natural +import Control.Category +import Data.Flat +import Data.Flat.Bits +import Data.Bits +import Data.Vector (generate) +import Data.Monoid.Unicode ((∅)) +import Data.List.NonEmpty (NonEmpty(..)) + +import Control.Lens ((&)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.State (State, get, put, evalState, runState) +import Control.Monad.Trans.Except (throwE) +import Data.Bits ((.|.), shiftL, shiftR) +import System.IO.Unsafe (unsafePerformIO) +import Text.Show (showString, showParen) + +import qualified Prelude as P +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B diff --git a/pkg/hs-conq/lib/Language/Conq/Grainary.hs b/pkg/hs-conq/lib/Language/Conq/Grainary.hs new file mode 100644 index 000000000..312906e43 --- /dev/null +++ b/pkg/hs-conq/lib/Language/Conq/Grainary.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Conq.Grainary where + +import Language.Conq.Types +import Language.Conq.ForVal + +import ClassyPrelude hiding ((<.>), Left, Right, hash, cons) +import Data.Type.Equality +import Type.Reflection +import Data.Coerce +import GHC.Natural +import Control.Category +import Data.Flat +import Data.Flat.Bits +import Data.Bits +import Data.Vector (generate) +import Data.Monoid.Unicode ((∅)) +import Data.List.NonEmpty (NonEmpty(..)) + +import Control.Lens ((&)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.State (State, get, put, evalState, runState) +import Control.Monad.Trans.Except (throwE) +import Data.Bits ((.|.), shiftL, shiftR) +import System.IO.Unsafe (unsafePerformIO) +import Text.Show (showString, showParen) + +import qualified Prelude as P +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B + + +-- Jets ------------------------------------------------------------------------ + +jetReg :: [(SHA256, Exp, Val -> Val)] +jetReg = + [ ( SHA256 (encodeBase58 "FWz5mTGmuVz2b4TLNa7yMjTKL7wihsEWakoUD2nzqP6q") + , ESubj + , id + ) + ] + +jets :: HashMap SHA256 (Val -> Val) +jets = mapFromList (jetReg <&> \(h,_,f) -> (h,f)) + +grainsFromJets :: HashMap SHA256 ByteString +grainsFromJets = do + mapFromList $ jetReg <&> \(h,e,_) -> (h, flat (forVal e)) + +-- The Grainary ---------------------------------------------------------------- + +grainery :: IORef (HashMap SHA256 ByteString) +grainery = unsafePerformIO (newIORef grainsFromJets) + + +-- Utilities ------------------------------------------------------------------- + +decodeBase58 :: ByteString -> Text +decodeBase58 = decodeUtf8 . Base58.encodeBase58 Base58.bitcoinAlphabet + +fromJust (Just x) = x +fromJust _ = error "fromJust: Nothing" + +encodeBase58 :: Text -> ByteString +encodeBase58 = fromJust + . Base58.decodeBase58 Base58.bitcoinAlphabet + . encodeUtf8 + + +-- Create Grains --------------------------------------------------------------- + +putGrain :: Val -> Val +putGrain v = unsafePerformIO $ do + (bs, k) <- evaluate $ force (hashVal v) + traceM ("Putting Grain: " <> unpack (decodeBase58 $ unSHA256 k)) + atomicModifyIORef' grainery (\t -> (insertMap k bs t, ())) + evaluate (VR k) + where + hashVal :: Val -> (ByteString, SHA256) + hashVal x = (bs, SHA256 (SHA256.hash bs)) + where bs = flat x + + +-- Read Grains ----------------------------------------------------------------- + +getGrain :: SHA256 -> Val +getGrain k = unsafePerformIO $ do + traceM ("Getting Grain: " <> unpack (decodeBase58 $ unSHA256 k)) + + t <- readIORef grainery + + Just (P.Right v) <- pure (unflat <$> lookup k t) + + pure v + + +-- Encode/Decode Formulas ------------------------------------------------------ + +flattenExp :: Exp -> Exp +flattenExp = go + where + go (EWith (EWith x y) z) = go (EWith x (EWith y z)) + go (EWith x y) = EWith x (go y) + go x = x + +forVal :: Exp -> Val +forVal = \e -> + case flattenExp e of + EWith x y -> V1 $ VP (opkVal x) (forVal y) + x -> V0 (opkVal x) + where + opkVal :: Exp -> Val + opkVal = \case + EWith _ _ -> error "forVal: broken invariant" + ELeft -> V0 $ V0 $ V0 VN + EWrit -> V0 $ V0 $ V1 VN + EHead -> V0 $ V1 $ V0 VN + ETail -> V0 $ V1 $ V1 VN + EPure v -> V1 $ V0 $ V0 $ V0 v + ESubj -> V1 $ V0 $ V0 $ V1 VN + ELazy -> V1 $ V0 $ V1 $ V0 $ V0 VN + EMark -> V1 $ V0 $ V1 $ V1 $ V0 VN + EEval -> V1 $ V1 $ V0 $ V0 VN + EDist -> V1 $ V1 $ V0 $ V1 VN + ECase x y -> V1 $ V1 $ V1 $ V0 $ VP (forVal x) (forVal y) + ECons x y -> V1 $ V1 $ V1 $ V1 $ VP (forVal x) (forVal y) + EType _ -> opkVal ESubj + _ -> undefined + +valFor' :: Val -> Maybe Exp +valFor' (V0 l) = valOpk l +valFor' (VR r) = valFor' (getGrain r) +valFor' (V1 (VP x y)) = (<>) <$> valFor' y <*> valOpk x +valFor' _ = Nothing + +valFor :: Val -> Exp +valFor = maybe (EPure VN) id . valFor' + +valOpk :: Val -> Maybe Exp +valOpk (V0 (V0 x)) = valDir x +valOpk (V0 (V1 x)) = valGet x +valOpk (V1 (V0 (V0 x))) = valSim x +valOpk (V1 (V0 (V1 x))) = valHin x +valOpk (V1 (V1 (V0 x))) = valOtr x +valOpk (V1 (V1 (V1 x))) = valPlx x +valOpk _ = Nothing + +valDir :: Val -> Maybe Exp +valDir (V0 VN) = pure ELeft +valDir (V1 VN) = pure EWrit +valDir _ = Nothing + +valGet :: Val -> Maybe Exp +valGet (V0 VN) = pure EHead +valGet (V1 VN) = pure ETail +valGet _ = Nothing + +valSim :: Val -> Maybe Exp +valSim (V0 v) = pure (EPure v) +valSim (V1 VN) = pure ESubj +valSim _ = Nothing + +valOtr :: Val -> Maybe Exp +valOtr (V0 VN) = pure EEval +valOtr (V1 VN) = pure EDist +valOtr _ = Nothing + +valPlx :: Val -> Maybe Exp +valPlx (V0 (VP x y)) = pure $ ECase (valFor x) (valFor y) +valPlx (V1 (VP x y)) = pure $ ECons (valFor x) (valFor y) +valPlx _ = Nothing + +valHin :: Val -> Maybe Exp +valHin = \case + V0 (V0 VN) -> pure ELazy + V1 (V0 VN) -> pure EMark + _ -> Nothing diff --git a/pkg/hs-conq/lib/Language/Conq/Mess.hs b/pkg/hs-conq/lib/Language/Conq/Mess.hs new file mode 100644 index 000000000..bc8c4e7d6 --- /dev/null +++ b/pkg/hs-conq/lib/Language/Conq/Mess.hs @@ -0,0 +1,1356 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Conq.Mess where + +import ClassyPrelude hiding ((<.>), Left, Right, hash, cons) +import Data.Type.Equality +import Type.Reflection +import Data.Coerce +import GHC.Natural +import Control.Category +import Data.Flat +import Data.Flat.Bits +import Data.Bits +import Data.Vector (generate) +import Data.Monoid.Unicode ((∅)) +import Data.List.NonEmpty (NonEmpty(..)) + +import Control.Lens ((&)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.State (State, get, put, evalState, runState) +import Control.Monad.Trans.Except (throwE) +import Data.Bits ((.|.), shiftL, shiftR) +import System.IO.Unsafe (unsafePerformIO) +import Text.Show (showString, showParen) + +import qualified Prelude as P +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B + +-------------------------------------------------------------------------------- + +type Tup a b = (a, b) + +data Sum a b = L a | R b + deriving (Eq, Ord) + +-- SHA256 +newtype SHA256 = SHA256 { unSHA256 :: ByteString } + deriving newtype (Eq, Ord, Flat, Show, Hashable, NFData) + +data Val + = VV -- Void + | VN -- Null + | V0 !Val -- Left + | V1 !Val -- Right + | VP !Val !Val -- Pair + | VT !Val !Exp Val + | VR !SHA256 + deriving (Eq, Ord, Generic, Flat) + +instance Show Val where + show = show . valExp + +crash :: Exp +crash = EEval <> EEval <> (EPure VN) + +grainery :: IORef (HashMap SHA256 ByteString) +grainery = unsafePerformIO (newIORef grainsFromJets) + +grainsFromJets :: HashMap SHA256 ByteString +grainsFromJets = do + mapFromList $ jetReg <&> \(h,e,_) -> (h, flat (forVal e)) + +jetReg :: [(SHA256, Exp, Val -> Val)] +jetReg = + [ ( SHA256 (encodeBase58 "FWz5mTGmuVz2b4TLNa7yMjTKL7wihsEWakoUD2nzqP6q") + , ESubj + , id + ) + ] + +jets :: HashMap SHA256 (Val -> Val) +jets = mapFromList (jetReg <&> \(h,_,f) -> (h,f)) + +{- +runTent :: SHA256 -> Exp -> Val -> Val +runTent k exp arg = + lookup k jets & \case + Nothing -> runExp arg exp + Just fn -> trace ("running jet " <> show (ETent k)) (fn arg) +-} + +decodeBase58 :: ByteString -> Text +decodeBase58 = decodeUtf8 . Base58.encodeBase58 Base58.bitcoinAlphabet + +fromJust (Just x) = x +fromJust _ = error "fromJust: Nothing" + +encodeBase58 :: Text -> ByteString +encodeBase58 = fromJust + . Base58.decodeBase58 Base58.bitcoinAlphabet + . encodeUtf8 + +putGrain :: Val -> Val +putGrain v = unsafePerformIO $ do + (bs, k) <- evaluate $ force (hashVal v) + traceM ("Putting Grain: " <> unpack (decodeBase58 $ unSHA256 k)) + atomicModifyIORef' grainery (\t -> (insertMap k bs t, ())) + evaluate (VR k) + +getGrain :: SHA256 -> Val +getGrain k = unsafePerformIO $ do + traceM ("Getting Grain: " <> unpack (decodeBase58 $ unSHA256 k)) + + t <- readIORef grainery + + Just (P.Right v) <- pure (unflat <$> lookup k t) + + pure v + +valExp :: Val -> Exp +-- Exp (valFor' -> Just e) = EQuot e +valExp VN = EPure VN +valExp VV = crash +valExp v = go v <> EPure VN + where + go = \case + -- lFor' → Just e) → EQuot e + VV → crash + VN → ESubj + V0 VN → ELeft + V1 VN → EWrit + V0 l → ELeft <> go l + V1 r → EWrit <> go r + VP x y → ECons (go x) (go y) + VT x y _r → ECons (go x) y + VR k → EMark <> go (getGrain k) + +hashVal :: Val -> (ByteString, SHA256) +hashVal x = (bs, SHA256 (SHA256.hash bs)) + where bs = flat x + +data TyExp + = TENil + | TESum TyExp TyExp + | TETup TyExp TyExp + | TEFor TyExp TyExp + | TEAll TyExp + | TEFix TyExp + | TERef Int + deriving (Eq, Ord, Generic, Flat) + +instance Show TyExp where + show = \case + TESum TENil TENil -> "?" + TENil -> "~" + TESum x y -> "<" <> show x <> " " <> show y <> ">" + TETup x y -> "[" <> show x <> " " <> show y <> "]" + TEFor x y -> "(" <> show x <> " " <> show y <> ")" + TEAll x -> "A" <> show x + TEFix x -> "F" <> show x + TERef x -> show x + +data Ty + = TNil + | TSum Ty Ty + | TTup Ty Ty + | TFor Ty Ty + | TVar Int + deriving (Eq, Ord) + +tBit :: TyExp +tBit = TESum TENil TENil + +tBitOp :: TyExp +tBitOp = TEFor tBit tBit + +instance Show Ty where + show = \case + TNil -> "~" + TSum x y -> "<" <> show x <> " " <> show y <> ">" + TTup x y -> "[" <> show x <> " " <> show y <> "]" + TFor x y -> "(" <> show x <> " => " <> show y <> ")" + TVar x -> show x + +tyExpTy :: TyExp -> Infer Ty +tyExpTy = go [] + where + go :: [Int] -> TyExp -> Infer Ty + go t = \case + TENil -> pure TNil + TESum x y -> TSum <$> go t x <*> go t y + TETup x y -> TTup <$> go t x <*> go t y + TEFor x y -> TFor <$> go t x <*> go t y + TEAll x -> do t' <- (:t) <$> mkTVar + go t' x + TEFix x -> do t' <- (:t) <$> mkTVar + go t' x + TERef i -> pure $ TVar (t P.!! i) + +declare :: Ty -> TyExp -> Infer Ty +declare t e = do + te <- tyExpTy e + unify t te + +checkType :: Exp -> Either Text Ty +checkType e = runInfer (infer e >>= finalize) + +type Unique = Int +type Infer a = ExceptT Text (State (Map Int Ty, Unique)) a +type Unify a = Maybe a + +mkTVar :: Infer Int +mkTVar = do + (env, n) <- get + put (env, n+1) + pure n + +forAll :: Infer Ty +forAll = TVar <$> mkTVar + +varIs :: Int -> Ty -> Infer Ty +varIs v (TVar x) | x==v = do + pure (TVar x) +varIs v t = do + (env, n) <- get + put (insertMap v t env, n) + pure t + +finalize :: Ty -> Infer Ty +finalize (TVar v) = resolve v >>= finalize' +finalize t = finalize' t + +finalize' :: Ty -> Infer Ty +finalize' = \case + TNil -> pure TNil + TVar x -> pure (TVar x) + TSum x y -> TSum <$> finalize x <*> finalize y + TTup x y -> TTup <$> finalize x <*> finalize y + TFor x y -> TFor <$> finalize x <*> finalize y + +unify :: Ty -> Ty -> Infer Ty +unify x y = do + -- traceM $ "UNIFY " <> show x <> " " <> show y + x <- case x of { TVar v -> resolve v; x -> pure x } + y <- case y of { TVar v -> resolve v; y -> pure y } + unify' x y + +unify' :: Ty -> Ty -> Infer Ty +unify' = curry \case + ( TNil, TNil ) → pure TNil + ( TSum a1 b1, TSum a2 b2 ) → TSum <$> unify a1 a2 <*> unify b1 b2 + ( TTup a1 b1, TTup a2 b2 ) → TTup <$> unify a1 a2 <*> unify b1 b2 + ( TFor a1 b1, TFor a2 b2 ) → TFor <$> unify a1 a2 <*> unify b1 b2 + ( ty, TVar x ) → varIs x ty + ( TVar x, ty ) → varIs x ty + ( x, y ) → throwE + $ "Bad unify: " <> tshow x <> " " <> tshow y + +resolve :: Int -> Infer Ty +resolve v = do + (env, _) <- get + lookup v env & \case + Nothing -> pure (TVar v) + Just (TVar x) -> resolve x + Just x -> pure x + +expectFor :: Ty -> Infer (Ty, Ty, Ty) +expectFor = \case + ty@(TFor x y) -> pure (ty, x, y) + t -> throwE ("Not a formula: " <> tshow t) + +runInfer :: Infer a -> Either Text a +runInfer = flip evalState ((∅), 0) . runExceptT + +infer :: Exp -> Infer Ty +infer = \case + EPure _v -> do + a <- forAll + pure (TFor a TNil) -- TODO + + ESubj -> do + a <- forAll + pure (TFor a a) + + ELeft -> do + (a, b) <- (,) <$> forAll <*> forAll + pure (TFor a (TSum a b)) + + EWrit -> do + (a, b) <- (,) <$> forAll <*> forAll + pure (TFor b (TSum a b)) + + EHead -> do + (a, b) <- (,) <$> forAll <*> forAll + pure $ TFor (TTup a b) a + + ETail -> do + (a, b) <- (,) <$> forAll <*> forAll + pure $ TFor (TTup a b) b + + EDist -> do + (a, b, c) <- (,,) <$> forAll <*> forAll <*> forAll + pure $ TFor (TTup (TSum a b) c) (TSum (TTup a c) (TTup b c)) + + EEval -> do + (a, b) <- (,) <$> forAll <*> forAll + pure $ TFor (TTup a (TFor a b)) b + + EWith x y -> do + (xt, xi, xo) <- infer x >>= expectFor + (yt, yi, yo) <- infer y >>= expectFor + unify xo yi + pure (TFor xi yo) + + ECons x y -> do + (xt, xi, xo) <- infer x >>= expectFor + (yt, yi, yo) <- infer y >>= expectFor + unify xi yi + pure (TFor xi (TTup xo yo)) + + ECase p q -> do + (pt, pi, po) <- infer p >>= expectFor + (qt, qi, qo) <- infer q >>= expectFor + unify po qo + pure (TFor (TSum pi qi) po) + + EType t -> do + tt <- tyExpTy t + pure (TFor tt tt) + + ELazy -> throwE "infer: EPush" -- TODO + EMark -> throwE "infer: EHash" -- TODO + +-- An Alternate Encoding for Conq ---------------------------------------------- + +data Flag = T | F + deriving (Generic, Flat) + +data Hint = HLazy | HMark + deriving (Generic, Flat) + +deriving instance Flat a => Flat (NonEmpty a) + +data Axe + = AAxis [Flag] + | APure Val + | AEval + | ATong (NonEmpty Flag) + | ACons Axe Axe + | ACase Axe Axe + | AWith Axe Axe + | AHint Hint + deriving (Generic, Flat) + +instance Semigroup Axe where + AAxis xs <> AAxis ys = AAxis (ys <> xs) + ATong xs <> ATong ys = ATong (ys <> xs) + x <> y = y `AWith` x + +instance Monoid Axe where + mempty = AAxis [] + +instance Show Axe where + show = show . axeVal + +-- Convenience ----------------------------------------------------------------- + +lef = ATong (singleton F) +rit = ATong (singleton T) + +sut = AAxis [] +hed = AAxis [F] +tel = AAxis [T] + +showFlatAxe :: Axe -> IO () +showFlatAxe a = putStrLn $ pack + $ filter (\x -> x=='0' || x=='1') + $ show + $ fmap (\x -> if x then 1 else 0) + $ toList (bits a) + + +-- Encode Axes to Vals --------------------------------------------------------- + +axeVal :: Axe -> Val +axeVal = \case + AAxis ds -> V0 $ V0 $ V0 $ flagsVal ds + APure v -> V0 $ V0 $ V1 $ v + AEval -> V0 $ V1 $ V0 $ VN + ATong ts -> V0 $ V1 $ V1 $ flagsValNE ts + ACons x y -> V1 $ V0 $ V0 $ VP (axeVal x) (axeVal y) + ACase x y -> V1 $ V0 $ V1 $ VP (axeVal x) (axeVal y) + AWith x y -> V1 $ V1 $ V0 $ VP (axeVal x) (axeVal y) + AHint h -> V1 $ V1 $ V1 $ hintVal h + +axeExp :: Axe -> Exp +axeExp = \case + AAxis [] -> ESubj + AAxis [F] -> EHead + AAxis [T] -> ETail + AAxis (F:ds) -> axeExp (AAxis ds) <> EHead + AAxis (T:ds) -> axeExp (AAxis ds) <> ETail + APure VN -> EPure VN + APure v -> valExp v + AEval -> EEval + ATong (F :| []) -> ELeft + ATong (T :| []) -> EWrit + ATong (F :| t:ts) -> axeExp (ATong (t :| ts)) <> ELeft + ATong (T :| t:ts) -> axeExp (ATong (t :| ts)) <> EWrit + ACons x y -> ECons (axeExp x) (axeExp y) + ACase x y -> ECase (axeExp x) (axeExp y) + AWith x y -> axeExp y <> axeExp x + AHint HLazy -> ELazy + AHint HMark -> EMark + +expAxe :: Exp -> Axe +expAxe = \case + ESubj -> AAxis [] + EPure v -> APure v + EEval -> AEval + ELeft -> ATong (singleton F) + EWrit -> ATong (singleton T) + EHead -> AAxis (singleton F) + ETail -> AAxis (singleton T) + EDist -> ACase (expAxe ELeft) (expAxe EWrit) + EWith x y -> AWith (expAxe x) (expAxe y) + ECons x y -> ACons (expAxe x) (expAxe y) + ECase x y -> ACase (expAxe x) (expAxe y) + EType ty -> undefined + EMark -> AHint HMark + ELazy -> AHint HMark + ETent ref -> expAxe (valFor (getGrain ref)) + EQuot e -> APure (axeVal (expAxe e)) +--EUnquot e -> undefined + + +hintVal :: Hint -> Val +hintVal HLazy = V0 VN +hintVal HMark = V1 VN + +flagsVal :: [Flag] -> Val +flagsVal [] = V0 VN +flagsVal (F:bs) = V1 (VP (V0 VN) (flagsVal bs)) +flagsVal (T:bs) = V1 (VP (V1 VN) (flagsVal bs)) + +flagsValNE :: NonEmpty Flag -> Val +flagsValNE (F :| []) = V0 (V0 VN) +flagsValNE (T :| []) = V0 (V1 VN) +flagsValNE (F :| b:bs) = V1 (VP (V0 VN) (flagsValNE (b :| bs))) +flagsValNE (T :| b:bs) = V1 (VP (V1 VN) (flagsValNE (b :| bs))) + +-------------------------------------------------------------------------------- + +data Exp + = ESubj + | EPure Val + | EEval + | ELeft + | EWrit + | EHead + | ETail + | EDist + | EWith Exp Exp + | ECons Exp Exp + | ECase Exp Exp + + -- Hints + | EType TyExp + | EMark + | ELazy + + -- Convenience + | ETent SHA256 + | EQuot Exp +-- | EUnquot Exp + deriving (Eq, Ord, Generic, Flat) + +instance Semigroup Exp where + x <> y = EWith y x + +instance Monoid Exp where + mempty = ESubj + +runExp :: Val -> Exp -> Val +runExp s ESubj = s +runExp s e = uncurry runExp (step s e) + +-- Get a formula from a Val ---------------------------------------------------- + +{- + :+ <: > + :+ :+ <<- +> <~ .>> + < <◆ ▪>> + :+ <<, ●> > + <<# @> <^ |>> +-} + + +{- + for = + opk = < < > + dir = + get = <- +> + sim = <~ .> + otr = + plx = <◆ ▪> + quo = <, ●> + hin = < <<# @> <^ |>>> +-} + +flattenExp :: Exp -> Exp +flattenExp = go + where + go (EWith (EWith x y) z) = go (EWith x (EWith y z)) + go (EWith x y) = EWith x (go y) + go x = x + +forVal :: Exp -> Val +forVal = \e -> + case flattenExp e of + EWith x y -> V1 $ VP (opkVal x) (forVal y) + x -> V0 (opkVal x) + where + opkVal :: Exp -> Val + opkVal = \case + EWith _ _ -> error "forVal: broken invariant" + ELeft -> V0 $ V0 $ V0 VN + EWrit -> V0 $ V0 $ V1 VN + EHead -> V0 $ V1 $ V0 VN + ETail -> V0 $ V1 $ V1 VN + EPure v -> V1 $ V0 $ V0 $ V0 v + ESubj -> V1 $ V0 $ V0 $ V1 VN + ELazy -> V1 $ V0 $ V1 $ V0 $ V0 VN +-- ETent ref -> V1 $ V0 $ V1 $ V1 $ V0 VN + EMark -> V1 $ V0 $ V1 $ V1 $ V0 VN +-- ETent ref -> VR ref + EEval -> V1 $ V1 $ V0 $ V0 VN + EDist -> V1 $ V1 $ V0 $ V1 VN + ECase x y -> V1 $ V1 $ V1 $ V0 $ VP (forVal x) (forVal y) + ECons x y -> V1 $ V1 $ V1 $ V1 $ VP (forVal x) (forVal y) + EType _ -> opkVal ESubj + +valFor' :: Val -> Maybe Exp +valFor' (V0 l) = valOpk l +valFor' (VR r) = valFor' (getGrain r) +valFor' (V1 (VP x y)) = (<>) <$> valFor' y <*> valOpk x +valFor' _ = Nothing + +valFor :: Val -> Exp +valFor = maybe (EPure VN) id . valFor' + +valOpk :: Val -> Maybe Exp +valOpk (V0 (V0 x)) = valDir x +valOpk (V0 (V1 x)) = valGet x +valOpk (V1 (V0 (V0 x))) = valSim x +valOpk (V1 (V0 (V1 x))) = valHin x +valOpk (V1 (V1 (V0 x))) = valOtr x +valOpk (V1 (V1 (V1 x))) = valPlx x +valOpk _ = Nothing + +valDir :: Val -> Maybe Exp +valDir (V0 VN) = pure ELeft +valDir (V1 VN) = pure EWrit +valDir _ = Nothing + +valGet :: Val -> Maybe Exp +valGet (V0 VN) = pure EHead +valGet (V1 VN) = pure ETail +valGet _ = Nothing + +valSim :: Val -> Maybe Exp +valSim (V0 v) = pure (EPure v) +valSim (V1 VN) = pure ESubj +valSim _ = Nothing + +valOtr :: Val -> Maybe Exp +valOtr (V0 VN) = pure EEval +valOtr (V1 VN) = pure EDist +valOtr _ = Nothing + +valPlx :: Val -> Maybe Exp +valPlx (V0 (VP x y)) = pure $ ECase (valFor x) (valFor y) +valPlx (V1 (VP x y)) = pure $ ECons (valFor x) (valFor y) +valPlx _ = Nothing + +valHin :: Val -> Maybe Exp +valHin = \case + V0 (V0 VN) -> pure ELazy + V1 (V0 VN) -> pure EMark + _ -> Nothing + +-------------------------------------------------------------------------------- + +-- tag :: Bool -> Val -> Val +-- tag False = V0 +-- tag True = V1 + +-- unTag :: Val -> (Bool, Val) +-- unTag (V0 x) = (False, x) +-- unTag (V1 x) = (True, x) +-- unTag _ = error "unTag" + +-- toBits :: (Bits b, FiniteBits b) => b -> Vector Bool +-- toBits b = +-- generate (finiteBitSize b) (testBit b) + +-- byteVal :: Word8 -> Val +-- byteVal b = +-- foldl' (flip tag) VN (toBits b) + +-- valByte :: Val -> Word8 +-- valByte v = runIdentity $ do +-- (a, v) <- pure $ unTag v +-- (b, v) <- pure $ unTag v +-- (c, v) <- pure $ unTag v +-- (d, v) <- pure $ unTag v +-- (e, v) <- pure $ unTag v +-- (f, v) <- pure $ unTag v +-- (g, v) <- pure $ unTag v +-- (h, v) <- pure $ unTag v +-- let bits = [a, b, c, d, e, f, g, h] +-- unless (VN == v) (error "valByte: bad byte") +-- pure $ foldl' (\acc (i, x) -> if x then setBit acc (7-i) else acc) +-- 0 +-- (zip [0..] bits) + +-- data Pair a = Pair a a +-- deriving (Functor) + +-- data Quad a = Quad (Pair a) (Pair a) +-- deriving (Functor) + +-- data Oct a = Oct (Quad a) (Quad a) +-- deriving (Functor) + +-- pairVal :: Pair Val -> Val +-- pairVal (Pair x y) = VP x y + +-- quadVal :: Quad Val -> Val +-- quadVal (Quad x y) = VP (pairVal x) (pairVal y) + +-- octVal :: Oct Val -> Val +-- octVal (Oct x y) = VP (quadVal x) (quadVal y) + +-- -- Needs to be four times as big -- This throws away data +-- hashOct :: SHA256 -> Oct Word8 +-- hashOct (SHA256 bs) = +-- Oct (Quad (Pair a b) (Pair c d)) +-- (Quad (Pair e f) (Pair g h)) +-- where +-- a = B.unsafeIndex bs 0 +-- b = B.unsafeIndex bs 1 +-- c = B.unsafeIndex bs 2 +-- d = B.unsafeIndex bs 3 +-- e = B.unsafeIndex bs 4 +-- f = B.unsafeIndex bs 5 +-- g = B.unsafeIndex bs 6 +-- h = B.unsafeIndex bs 7 + +-- valHash :: Val -> SHA256 +-- valHash = \case +-- VP (VP (VP a b) (VP c d)) (VP (VP e f) (VP g h)) -> +-- SHA256 (B.pack $ valByte <$> [a, b, c, d, e, f, g, h]) +-- _ -> +-- SHA256 "" + +-- hashToVal :: SHA256 -> Val +-- hashToVal = octVal . fmap byteVal . hashOct + + +-- Small-Step Interpreter ------------------------------------------------------ + +step :: Val -> Exp -> (Val, Exp) +step VV = const (VV, ESubj) +step s = \case + EPure v -> (v, ESubj) + ESubj -> (s, ESubj) + EWith ESubj y -> (s, y) + EWith x y -> case step s x of + (s', ESubj) -> (s', y) + (s', x' ) -> (s', EWith x' y) + + EEval -> + case s of + VP s' f' -> (s', valFor f') + _ -> (VV, ESubj) + + ECons ESubj ESubj -> (VP s s, ESubj) + ECons x y -> (VP (runExp s x) (runExp s y), ESubj) + ELeft -> (V0 s, ESubj) + EWrit -> (V1 s, ESubj) + EHead -> case s of + VP x _ -> (x, ESubj) + _ -> (VV, ESubj) + ETail -> case s of + VP _ y -> (y, ESubj) + _ -> (VV, ESubj) + EDist -> case s of + VP (V0 l) x -> (V0 (VP l x), ESubj) + VP (V1 r) x -> (V1 (VP r x), ESubj) + _ -> (VV, ESubj) + ECase p q -> case s of + V0 l -> (l, p) + V1 r -> (r, q) + _ -> (VV, ESubj) + EType _ -> (s, ESubj) + ELazy -> case s of + VP s' f' -> let e = valFor f' + in traceShowId (VT s' e (runExp s' e), ESubj) + _ -> (VV, ESubj) + EMark -> (putGrain s, ESubj) + EQuot e -> (forVal e, ESubj) + +displayExp :: Exp -> String +displayExp (EWith x y) = displayExp x <> "\n" <> displayExp y +displayExp x = "\t" <> show x + +traceRunExp :: Val -> Exp -> IO Val +traceRunExp s e = do + putStrLn (tshow (valExp s)) + putStrLn (pack $ displayExp e) + void getLine + case e of + ESubj -> do putStrLn "DONE" + pure s + _ -> uncurry traceRunExp (step s e) + +traceRun :: Conq () r -> IO Val +traceRun = traceRunExp VN . toExp + +flattenCons :: Exp -> Exp -> [Exp] +flattenCons = \x -> go [x] + where + go acc (ECons x y) = go (x:acc) y + go acc x = reverse (x:acc) + +instance Show Exp where + show = \case + ESubj -> "." + EPure VN -> "~" + EPure v -> show (valExp v) + EEval -> "!" + ELeft -> "0" + EWrit -> "1" + EHead -> "-" + ETail -> "+" + EDist -> "%" + EWith x y -> show y <> show x + ECons x y -> "[" <> show x <> " " <> show y <> "]" + ECase x y -> "<" <> show x <> " " <> show y <> ">" + EType t -> "{" <> show t <> "}" + ELazy -> "?" + EMark -> "@" + EQuot x -> "(" <> show x <> ")" +-- ETent ref -> "|" <> take 8 (unpack $ decodeBase58 $ unSHA256 ref) <> "|" + +parseSimpl :: String -> Maybe (Exp, String) +parseSimpl = \case + '.' : xs -> pure (ESubj, xs) +--'~' : xs -> pure (ENull, xs) -- TODO EPure + '!' : xs -> pure (EEval, xs) + '0' : xs -> pure (ELeft, xs) + '1' : xs -> pure (EWrit, xs) + '-' : xs -> pure (EHead, xs) + '+' : xs -> pure (ETail, xs) + '%' : xs -> pure (EDist, xs) + '?' : xs -> pure (ELazy, xs) + '@' : xs -> pure (EMark, xs) + _ -> Nothing + +parseHash :: String -> Either String (SHA256, String) +parseHash b = do + let (h,r) = splitAt 44 b + let sha = SHA256 (encodeBase58 $ pack h) + when (length h /= 44) (P.Left "short tent") + pure (sha, r) + +parseExp :: String -> Either String (Exp, String) +parseExp str = do + case parseSimpl str of + Just (e, xs) -> pure (e, xs) + Nothing -> + case str of + '[':xs -> parseTwo ECons ']' xs + '<':xs -> parseTwo ECase '>' xs + '(':xs -> parseSeq ')' xs <&> \case + (e,cs) -> (EQuot e, cs) +-- '|':xs -> parseHash xs >>= \case +-- (s, '|':xs) -> pure (ETent s, xs) +-- (_, _ ) -> P.Left "bad tent" + _ -> P.Left "bad" + +repl :: IO () +repl = r VN + where + r sut = do + ln <- unpack <$> getLine + parseSeq '\n' ln & \case + P.Right (e,"") -> do + epl sut e + P.Right (e,cs) -> do + traceM ("ignoring trailing chars: " <> cs) + epl sut e + P.Left msg -> do + traceM msg + traceM "Try again\n" + r sut + + epl sut exp = do + sut' <- pure (runExp sut exp) + if (sut' == VV) + then do + putStrLn "Crash! Try again\n" + r sut + else do + putStrLn ("-> " <> tshow sut') + putStrLn "" + r sut' + +parseSeq :: Char -> String -> Either String (Exp, String) +parseSeq end = go >=> \case + (Just x, buf) -> pure (x, buf) + (Nothing, buf) -> P.Left "empty sequence" + where + go :: String -> Either String (Maybe Exp, String) + go = \case + [] -> pure (Nothing, []) + c : cd | c == end -> pure (Nothing, cd) + cs -> do + (x, buf) <- parseExp cs + (y, buf) <- go buf + case y of + Nothing -> pure (Just x, buf) + Just y -> pure (Just (x <> y), buf) + +parseTwo :: (Exp -> Exp -> Exp) -> Char -> String + -> Either String (Exp, String) +parseTwo cntr end buf = do + (xs, buf) <- parseSeq ' ' buf + (ys, buf) <- parseSeq end buf + pure (cntr xs ys, buf) + +-------------------------------------------------------------------------------- + +data Conq s r where + Subj :: Conq s s + Pure :: v -> Conq s v + Left :: Conq a (Sum a b) + Writ :: Conq b (Sum a b) + Head :: Conq (Tup a b) a + Tail :: Conq (Tup a b) b + Cons :: Conq s a -> Conq s b -> Conq s (Tup a b) + Case :: Conq a r -> Conq b r -> Conq (Sum a b) r + Dist :: Conq (Tup (Sum a b) s) (Sum (Tup a s) (Tup b s)) + With :: (Conq s a) -> ((Conq a r) -> (Conq s r)) + Eval :: Conq (Tup a (Conq a r)) r + Mark :: Conq a a + Lazy :: Conq (Tup s (Conq s a)) (Tup s (Conq s a)) + +instance Category Conq where + id = Subj + (.) = flip With + +instance Show (Conq s r) where + show c = show (toExp c) + +-------------------------------------------------------------------------------- + +run :: s -> Conq s r -> r +run sut = \case + Pure x -> x + Subj -> sut + With x y -> run (run sut x) y + Eval -> case sut of (s,f) -> run s f + Cons x y -> (run sut x, run sut y) + Left -> L sut + Writ -> R sut + Head -> fst sut + Tail -> snd sut + Dist -> case sut of (L l, x) -> L (l, x); (R r, x) -> R (r, x) + Case p q -> case sut of L l -> run l p; R r -> run r q + Mark -> sut + Lazy -> sut + +times :: Int -> Conq s s -> Conq s s +times 0 _ = id +times 1 f = f +times n f = With f (times (n-1) f) + +runTimes :: Int -> s -> Conq s s -> s +runTimes n sut conq = go n + where + go 0 = sut + go 1 = run sut conq + go n = run (go (n-1)) conq + +-------------------------------------------------------------------------------- + +toExp :: Conq s r -> Exp +toExp = \case + Subj -> ESubj + Pure _ -> EPure VN -- TODO + Eval -> EEval + Left -> ELeft + Writ -> EWrit + Head -> EHead + Tail -> ETail + Dist -> EDist + Cons x y -> ECons (toExp x) (toExp y) + Case l r -> ECase (toExp l) (toExp r) + With x y -> EWith (toExp x) (toExp y) + Lazy -> ELazy + Mark -> EMark + +-------------------------------------------------------------------------------- + +fromExp :: forall s r. (Typeable s, Typeable r) => Exp -> Maybe (Conq s r) +fromExp = \case + ESubj -> + case testEquality (typeRep @s) (typeRep @r) of + Just Refl -> Just (coerce Subj) + Nothing -> Nothing + + _ -> + Nothing + +-- Axis Lookup ----------------------------------------------------------------- + +a1 :: Conq a a +a1 = Subj + +a2 :: Conq (Tup a b) a +a2 = Head + +a3 :: Conq (Tup a b) b +a3 = Tail + +a4 :: Conq (Tup (Tup a b) c) a +a4 = Head . Head + +a5 :: Conq (Tup (Tup a b) c) b +a5 = Tail . Head + +a6 :: Conq (Tup a (Tup b c)) b +a6 = Head . Tail + +a7 :: Conq (Tup a (Tup b c)) c +a7 = Tail . Tail + +a8 :: Conq (((a, b), c), d) a +a8 = Head . Head . Head + + +-- Eat Operations -------------------------------------------------------------- + +nothing :: Conq s (Sum () a) +nothing = Left . Pure() + +just :: Conq a (Sum () a) +just = Writ + +case' :: Conq (a,s) r -> Conq (b,s) r -> Conq (Sum a b,s) r +case' x y = Case x y . Dist + +previewLeft :: Conq (Sum a b) (Sum () a) +previewLeft = Case just nothing + +previewWrit :: Conq (Sum a b) (Sum () b) +previewWrit = Case nothing just + + +-- Pair Operations ------------------------------------------------------------- + +curry' :: Conq (a, b) c -> Conq s a -> Conq s b -> Conq s c +curry' f x y = With (Cons x y) f + +both :: Conq a b -> Conq (a, a) (b, b) +both x = Cons (With Head x) (With Tail x) + +dub_equal :: Conq (a, a) Bit -> Conq ((a, a), (a, a)) Bit +dub_equal cmp = With results bit_and + where + results = Cons (With (both Head) cmp) (With (both Tail) cmp) + +dub_test :: Conq a Bit -> Conq (a, a) Bit +dub_test test = curry' bit_and (With Head test) (With Tail test) + +dub_inc :: Conq a a -> Conq a Bit -> Conq (a, a) (a, a) +dub_inc inc null = With bump_low (if' low_zero bump_hig id) + where + bump_low = Cons (inc . Head) Tail + bump_hig = Cons Head (inc . Tail) + low_zero = null . Head + +type Tag a = Sum a a -- Tag with a bit: <0 1> +type Inc a = Conq a (Tag a) + +bit_incer :: Inc Bit +bit_incer = Case (Left . Writ) (Writ . Left) + +duo_incer' :: Inc Duo +duo_incer' = incer bit_incer + +duo_incer :: Inc Duo +duo_incer = Case (Left . Cons true Tail) carry . Dist + where + carry = Case (Left . Cons Left Writ) (Writ . Cons Left Left) . Tail + +incer :: forall a. Inc a -> Inc (a, a) +incer i = + Case Left hig . low + where + low, hig :: Inc (a, a) + low = Dist . Cons (i . Head) Tail + hig = Case (Left . flip') Writ . Dist . Cons (i . Tail) Head + +nyb_incer :: Inc Nyb +nyb_incer = incer duo_incer + +byt_incer :: Inc Byt +byt_incer = incer nyb_incer + +short_incer :: Inc Short +short_incer = incer byt_incer + +wide_incer :: Inc Wide +wide_incer = incer short_incer + +long_incer :: Inc Long +long_incer = incer wide_incer + +bit :: Int -> Bit +bit n = runTimes n val_bit_zero bit_inc + + +-- Random Combinators ---------------------------------------------------------- + +dup :: Conq a (a, a) +dup = Cons Subj Subj + +eat :: Conq (Sum a a) a +eat = Case Subj Subj + +flip' :: Conq (a, b) (b, a) +flip' = Cons Tail Head + +if' :: Conq s Bit -> Conq s r -> Conq s r -> Conq s r +if' c t f = case' (f . Tail) (t . Tail) . Cons c Subj + +factor :: Conq (Sum (a, c) (b, c)) (Sum a b, c) +factor = Case (Cons (Left . Head) Tail) + (Cons (Writ . Head) Tail) + + +-- Boolean Operations ---------------------------------------------------------- + +type Bit = Sum () () + +true :: Conq s Bit +true = Writ . Pure() + +false :: Conq s Bit +false = Left . Pure() + +bit_not :: Conq Bit Bit +bit_not = Case Writ Left + +bit_id :: Conq Bit Bit +bit_id = Case Left Writ + +bit_and :: Conq (Bit, Bit) Bit +bit_and = Case false Tail . Dist + +bit_or :: Conq (Bit, Bit) Bit +bit_or = Case Tail true . Dist + +bit_xor :: Conq (Bit, Bit) Bit +bit_xor = Case Tail (bit_not . Tail) . Dist + +bit_equal :: Conq (Bit, Bit) Bit +bit_equal = Case (bit_not . Tail) Tail . Dist + +bit_zero :: Conq s Bit +bit_zero = false + +val_bit_zero :: Bit +val_bit_zero = run () bit_zero + +bit_is_zero :: Conq Bit Bit +bit_is_zero = bit_not + +bit_inc :: Conq Bit Bit +bit_inc = bit_not + +-- Duo Operations (2 bit) ------------------------------------------------------ + +type Duo = (Bit, Bit) + +duo_zero :: Conq s Duo +duo_zero = Cons bit_zero bit_zero + +duo_is_zero :: Conq Duo Bit +duo_is_zero = dub_test bit_is_zero + +duo_inc :: Conq Duo Duo +duo_inc = Case (Cons true Tail) (Cons false (bit_not . Tail)) . Dist + +duo :: Int -> Duo +duo n = runTimes n (run () duo_zero) duo_inc + +duo_equal :: Conq (Duo, Duo) Bit +duo_equal = dub_equal bit_equal + + +-- Nibble Operations (4 bit) --------------------------------------------------- + +type Nyb = (Duo, Duo) + +nyb_zero :: Conq a Nyb +nyb_zero = Cons duo_zero duo_zero + +nyb_is_zero :: Conq Nyb Bit +nyb_is_zero = dub_test duo_is_zero + +nyb_inc :: Conq Nyb Nyb +nyb_inc = dub_inc duo_inc duo_is_zero + +nyb :: Int -> Nyb +nyb n = runTimes n (run () nyb_zero) nyb_inc + +nyb_equal :: Conq (Nyb, Nyb) Bit +nyb_equal = dub_equal duo_equal + + +-- Byte Operations (8 bit) ----------------------------------------------------- + +type Byt = (Nyb, Nyb) + +byt_zero :: Conq a Byt +byt_zero = Cons nyb_zero nyb_zero + +byt_is_zero :: Conq Byt Bit +byt_is_zero = dub_test nyb_is_zero + +byt_inc :: Conq Byt Byt +byt_inc = dub_inc nyb_inc nyb_is_zero + +byt :: Int -> Byt +byt n = runTimes n (run () byt_zero) byt_inc + +byt_equal :: Conq (Byt, Byt) Bit +byt_equal = dub_equal nyb_equal + + +-- Short Operations (16 bit) --------------------------------------------------- + +type Short = (Byt, Byt) + +short_zero :: Conq a Short +short_zero = Cons byt_zero byt_zero + +short_is_zero :: Conq Short Bit +short_is_zero = dub_test byt_is_zero + +short_inc :: Conq Short Short +short_inc = dub_inc byt_inc byt_is_zero + +short :: Int -> Short +short n = runTimes n (run () short_zero) short_inc + +short_equal :: Conq (Short, Short) Bit +short_equal = dub_equal byt_equal + + +-- Wide Operations (32 bit) ---------------------------------------------------- + +type Wide = (Short, Short) + +wide_zero :: Conq a Wide +wide_zero = Cons short_zero short_zero + +wide_is_zero :: Conq Wide Bit +wide_is_zero = dub_test short_is_zero + +wide_inc :: Conq Wide Wide +wide_inc = dub_inc short_inc short_is_zero + +wide :: Int -> Wide +wide n = runTimes n (run () wide_zero) wide_inc + +wide_equal :: Conq (Wide, Wide) Bit +wide_equal = dub_equal short_equal + + +-- Long Operations (64 bit) ---------------------------------------------------- + +type Long = (Wide, Wide) + +long_zero :: Conq a Long +long_zero = Cons wide_zero wide_zero + +long_is_zero :: Conq Long Bit +long_is_zero = dub_test wide_is_zero + +long_inc :: Conq Long Long +long_inc = dub_inc wide_inc wide_is_zero + +long :: Int -> Long +long n = runTimes n (run () long_zero) long_inc + +long_equal :: Conq (Long, Long) Bit +long_equal = dub_equal wide_equal + +n0 :: Conq a (Sum () a) +n0 = Left . Pure() + +n1 :: Conq a (Sum () (Sum () a)) +n1 = Writ . n0 + +n2 = Writ . n1 +n3 = Writ . n2 +n4 = Writ . n3 +n5 = Writ . n4 +n6 = Writ . n5 +n7 = Writ . n6 +n8 = Writ . n7 +n9 = Writ . n8 +n10 = Writ . n9 + + +-------------------------------------------------------------------------------- + +-- ((arg (ctx for)) fireTramp) -> %(!((arg ctx) for) (ctx for)) +-- fireTramp = Payload +-- fireTramp = undefined + +-- [Lx y] -> R[x y] +-- [R[x y] z] -> R[x (compose y z)] +compose :: Exp +compose = ECase EWrit (EWrit <> recur) <> EDist + where + recur = ECons (EHead <> EHead) + (ECons (ETail <> EHead) ETail) + +-- ctx for -> (ctx for) +gate :: Val -> Exp -> Val +gate v e = VP v (forVal e) + +-- `$-(a a)`: Identity +identFn :: Val +identFn = gate VN (toExp Head) + +-- `$-(a b)`: Trivial-Loop +spinFn :: Val +spinFn = gate VN fire + +call :: Exp -> Exp -> Exp +call g a = fire <> ECons a g + +spin :: Exp +spin = call (valExp spinFn) (EPure VN) + +-- `$-((list a) @)`: List-Length +lenFn :: Val +lenFn = gate (V0 VN) lenFnBody + +caseHead x y = ECase x y <> EDist + +hep, lus :: Exp +hep = EHead +lus = ETail +zer = ELeft +one = EWrit + +cons :: Exp -> Exp -> Exp +cons = ECons + +lenFnBody :: Exp +lenFnBody = caseHead (hep <> lus) + $ (fire <>) + $ cons (lus <> hep) + $ cons (one<>hep) lus <> lus + +swapFn :: Val +swapFn = gate VN (toExp swapFnBody) + +swapFnBody :: Conq ((a,b),x) (b,a) +swapFnBody = Cons Tail Head . Head + +-- ctx lFor rFor -> (ctx (lfor rfor)) +coreTwo :: Val -> Exp -> Exp -> Val +coreTwo v l r = VP v (VP (forVal l) (forVal r)) + +evenOddCore :: Val +evenOddCore = coreTwo VN evArm odArm + +evArm, odArm :: Exp +evArm = caseHead (toExp true) fireRit +odArm = caseHead (toExp false) fireLef + +-- (arg (ctx for)) -> ((arg (ctx for)) for)! +fire :: Exp +fire = EEval <> cons (∅) (lus <> lus) + +-- (arg (ctx (lfor rfor))) -> ((arg (ctx (lfor rfor))) lfor)! +fireLef :: Exp +fireLef = EEval <> toExp reOrg + where + reOrg :: Conq (a,(c,(l,r))) ((a,(c,(l,r))),l) + reOrg = Cons Subj (Head . Tail . Tail) + +-- (arg (ctx (lfor rfor))) -> ((arg (ctx (lfor rfor))) rfor)! +fireRit :: Exp +fireRit = EEval <> toExp reOrg + where + reOrg :: Conq (a,(c,(l,r))) ((a,(c,(l,r))),r) + reOrg = Cons Subj (Tail . Tail . Tail) + +-- Demos ----------------------------------------------------------------------- + +type Payload = (Val, Exp) + +demo :: Payload -> IO Val +demo (s,f) = traceRunExp s f + +dumbLoop :: Exp +dumbLoop = EEval <> ECons (∅) (∅) + +dumbLoopP :: Payload +dumbLoopP = (forVal dumbLoop, dumbLoop) + +demo_dumb_loop :: IO Val +demo_dumb_loop = demo dumbLoopP + +demo_duo_overflow :: IO Val +demo_duo_overflow = traceRun (duo_incer . times 3 (eat . duo_incer) . duo_zero) + +demo_nat_constr :: IO Val +demo_nat_constr = traceRun n10 + +-- [[-e +] +]! +fix :: Val -> Exp -> Payload +fix x e = (VP x (forVal fe), fe) + where + fe = EEval <> cons (cons (e <> hep) lus) lus + +natOverflow :: Exp +natOverflow = EEval <> cons (cons (one <> hep) lus) lus + +natOverflowPay :: Payload +natOverflowPay = fix (V0 VN) EWrit + +demo_nat_inc_loop :: IO Val +demo_nat_inc_loop = demo natOverflowPay + +duo_zero_val :: Val +duo_zero_val = VP (V0 VN) (V0 (VN)) + +short_zero_val :: Val +short_zero_val = runExp VN (toExp short_zero) + +short_inc_loop :: IO Val +short_inc_loop = demo $ fix (V0 short_zero_val) (toExp (short_incer . eat)) diff --git a/pkg/hs-conq/lib/Language/Conq/Types.hs b/pkg/hs-conq/lib/Language/Conq/Types.hs new file mode 100644 index 000000000..0cf320220 --- /dev/null +++ b/pkg/hs-conq/lib/Language/Conq/Types.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Language.Conq.Types where + +import ClassyPrelude hiding ((<.>), Left, Right, hash, cons) +import Data.Type.Equality +import Type.Reflection +import Data.Coerce +import GHC.Natural +import Control.Category +import Data.Flat +import Data.Flat.Bits +import Data.Bits +import Data.Vector (generate) +import Data.Monoid.Unicode ((∅)) +import Data.List.NonEmpty (NonEmpty(..)) + +import Control.Lens ((&)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.State (State, get, put, evalState, runState) +import Control.Monad.Trans.Except (throwE) +import Data.Bits ((.|.), shiftL, shiftR) +import System.IO.Unsafe (unsafePerformIO) +import Text.Show (showString, showParen) + +import qualified Prelude as P +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base58 as Base58 +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B + + +-- Utilities ------------------------------------------------------------------- + +type Tup a b = (a, b) + +data Sum a b = L a | R b + deriving (Eq, Ord) + +-- SHA256 +newtype SHA256 = SHA256 { unSHA256 :: ByteString } + deriving newtype (Eq, Ord, Flat, Show, Hashable, NFData) + + +-- RTS Values ------------------------------------------------------------------ + +data Val + = VV -- Void + | VN -- Null + | V0 !Val -- Left + | V1 !Val -- Right + | VP !Val !Val -- Pair + | VT !Val !Exp Val -- Thunk + | VR !SHA256 -- Grain + deriving (Eq, Ord, Show, Generic, Flat) + + +-- Types ----------------------------------------------------------------------- + +data TyExp + = TENil + | TESum TyExp TyExp + | TETup TyExp TyExp + | TEFor TyExp TyExp + | TEAll TyExp + | TEFix TyExp + | TERef Int + deriving (Eq, Ord, Show, Generic, Flat) + +data Ty + = TNil + | TSum Ty Ty + | TTup Ty Ty + | TFor Ty Ty + | TVar Int + deriving (Eq, Show, Ord) + + +-- Axe -- Conq Encoding -------------------------------------------------------- + +data Flag = T | F + deriving (Eq, Ord, Show, Generic, Flat) + +data Hint = HLazy | HMark | HType TyExp | HFast + deriving (Eq, Ord, Show, Generic, Flat) + +deriving instance Flat a => Flat (NonEmpty a) + +data Axe + = AAxis [Flag] + | APure Val + | AEval + | ATong (NonEmpty Flag) + | ACons Axe Axe + | ACase Axe Axe + | AWith Axe Axe + | AHint Hint + deriving (Eq, Ord, Show, Generic, Flat) + +instance Semigroup Axe where + AAxis xs <> AAxis ys = AAxis (ys <> xs) + ATong xs <> ATong ys = ATong (ys <> xs) + x <> y = y `AWith` x + +instance Monoid Axe where + mempty = AAxis [] + + +-- Exp -- Conq ASTs ------------------------------------------------------------ + +data Exp + = ESubj + | EPure Val + | EEval + | ELeft + | EWrit + | EHead + | ETail + | EDist + | EWith Exp Exp + | ECons Exp Exp + | ECase Exp Exp + | EType TyExp + | EMark + | ELazy + | EFast + | EQuot Exp + | ETape Exp -- Unquote + deriving (Eq, Ord, Show, Generic, Flat) + +instance Semigroup Exp where + x <> y = EWith y x + +instance Monoid Exp where + mempty = ESubj + + +-- Conq -- Typed-Embedding ----------------------------------------------------- + +data Conq s r where + Subj :: Conq s s + Pure :: v -> Conq s v + Left :: Conq a (Sum a b) + Writ :: Conq b (Sum a b) + Head :: Conq (Tup a b) a + Tail :: Conq (Tup a b) b + Cons :: Conq s a -> Conq s b -> Conq s (Tup a b) + Case :: Conq a r -> Conq b r -> Conq (Sum a b) r + Dist :: Conq (Tup (Sum a b) s) (Sum (Tup a s) (Tup b s)) + With :: (Conq s a) -> ((Conq a r) -> (Conq s r)) + Eval :: Conq (Tup a (Conq a r)) r + Mark :: Conq a a + Lazy :: Conq (Tup s (Conq s a)) (Tup s (Conq s a)) + +instance Category Conq where + id = Subj + (.) = flip With From 6565c06fd4708396ba206fcf8b28b72ba5384ca2 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 24 Jun 2019 18:10:41 -0700 Subject: [PATCH 075/431] Got something working: Can "replay" event log for ship whos snapshot is already up to date.. --- pkg/hs-urbit/lib/Data/Noun/Poet.hs | 10 +- pkg/hs-urbit/lib/Vere/Log.hs | 286 ++++++++----------- pkg/hs-urbit/lib/Vere/Persist.hs | 77 +++++ pkg/hs-urbit/lib/Vere/Pier.hs | 90 +++--- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 2 + pkg/hs-urbit/lib/Vere/{Worker.hs => Serf.hs} | 187 +++++++----- pkg/hs-vere/app/test/Main.hs | 81 ++++-- pkg/urbit/vere/pier.c | 8 +- stack.yaml | 2 + 9 files changed, 427 insertions(+), 316 deletions(-) create mode 100644 pkg/hs-urbit/lib/Vere/Persist.hs rename pkg/hs-urbit/lib/Vere/{Worker.hs => Serf.hs} (64%) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Data/Noun/Poet.hs index 7c99cfc37..45247c539 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet.hs @@ -79,7 +79,7 @@ instance Applicative IResult where (<*>) = ap instance Fail.MonadFail IResult where - fail err = IError [] err + fail err = traceM ("!" <> err <> "!") >> IError [] err instance Monad IResult where return = pure @@ -203,6 +203,12 @@ fromNoun n = runParser (parseNoun n) [] onFail onSuccess onFail p m = Nothing onSuccess x = Just x +fromNounErr :: FromNoun a => Noun -> Either Text a +fromNounErr n = runParser (parseNoun n) [] onFail onSuccess + where + onFail p m = Left (pack m) + onSuccess x = Right x + _Poet :: (ToNoun a, FromNoun a) => Prism' Noun a _Poet = prism' toNoun fromNoun @@ -287,7 +293,7 @@ instance ToNoun a => ToNoun (Nullable a) where instance FromNoun a => FromNoun (Nullable a) where parseNoun (Atom 0) = pure Nil - parseNoun (Atom n) = fail ("Expected ?@(~ ^), but got " <> show n) + parseNoun (Atom n) = fail ("Nullable: expected ?@(~ ^), but got " <> show n) parseNoun n = NotNil <$> parseNoun n diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index 71f0e8719..c7748c460 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -1,17 +1,19 @@ --- TODO: Make sure transaction closed in all error cases --- TODO: Don't allow writing non-contiguous events -module Vere.Log ( - init, - shutdown, - -- we don't export write; you use the queue - readEvents, - latestEventNumber, - readLogIdentity, - writeLogIdentity -) where +{- + TODO: Make sure transaction closed in all error cases + TODO: Don't allow writing non-contiguous events +-} + +module Vere.Log ( open + , close + , readEvents + , latestEventNumber + , readIdent + , writeIdent + , putJam + ) where import ClassyPrelude hiding (init) -import Control.Lens hiding ((<|)) +import Control.Lens hiding ((<|)) import Data.Noun import Data.Noun.Atom @@ -32,131 +34,73 @@ import qualified Data.ByteString as B import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV --------------------------------------------------------------------------------- --- TODO: Handle throws on the async -init :: FilePath -> TQueue (Writ [Eff]) -> (Writ [Eff] -> STM ()) - -> IO LogState -init dir inp cb = do +-- Open/Close an Event Log ----------------------------------------------------- + +open :: FilePath -> IO EventLog +open dir = do env <- mdb_env_create mdb_env_set_maxdbs env 3 mdb_env_set_mapsize env (40 * 1024 * 1024 * 1024) mdb_env_open env dir [] - writer <- persistThread env inp cb - pure (LogState env inp cb writer) + pure (EventLog env) --- TODO: properly handle shutdowns during write -shutdown :: LogState -> IO () -shutdown s = do - void $ waitCancel (writer s) - mdb_env_close (env s) +close :: EventLog -> IO () +close (EventLog env) = mdb_env_close env -waitCancel :: Async a -> IO (Either SomeException a) -waitCancel async = cancel async >> waitCatch async --------------------------------------------------------------------------------- +-- Read/Write Log Identity ----------------------------------------------------- -{- - Read one or more items from a TQueue, only blocking on the first item. --} -readQueue :: TQueue a -> STM (NonNull [a]) -readQueue q = - readTQueue q >>= go . singleton +readIdent :: EventLog -> IO LogIdentity +readIdent (EventLog env) = do + txn <- mdb_txn_begin env Nothing True + db <- mdb_dbi_open txn (Just "META") [] + who <- get txn db "who" + is_fake <- get txn db "is-fake" + life <- get txn db "life" + mdb_txn_abort txn + pure (LogIdentity who is_fake life) + +writeIdent :: EventLog -> LogIdentity -> IO () +writeIdent (EventLog env) LogIdentity{..} = do + txn <- mdb_txn_begin env Nothing False + db <- mdb_dbi_open txn (Just "META") [MDB_CREATE] + let flags = compileWriteFlags [] + putNoun flags txn db "who" who + putNoun flags txn db "is-fake" is_fake + putNoun flags txn db "life" life + mdb_txn_commit txn + pure () + + +-- Latest Event Number --------------------------------------------------------- + +latestEventNumber :: EventLog -> IO Word64 +latestEventNumber (EventLog env) = + do + txn <- mdb_txn_begin env Nothing True + db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] + cur <- mdb_cursor_open txn db + res <- fetch txn db cur + mdb_cursor_close cur + mdb_txn_abort txn + pure res where - go acc = - tryReadTQueue q >>= \case - Nothing -> pure (reverse acc) - Just item -> go (item <| acc) + key = MDB_val 0 nullPtr + val = MDB_val 0 nullPtr + fetch txn db cur = + withKVPtrs key val $ \pKey pVal -> + mdb_cursor_get MDB_LAST cur pKey pVal >>= \case + False -> pure 0 + True -> peek pKey >>= mdbValToWord64 -byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a -byteStringAsMdbVal bs k = - BU.unsafeUseAsCStringLen bs \(ptr,sz) -> - k (MDB_val (fromIntegral sz) (castPtr ptr)) -mdbValToAtom :: MDB_val -> IO Atom -mdbValToAtom (MDB_val sz ptr) = do - bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) - pure (bs ^. from (pill . pillBS)) - -maybeErr :: Maybe a -> String -> IO a -maybeErr (Just x) _ = pure x -maybeErr Nothing msg = error msg - -mdbValToNoun :: MDB_val -> IO Noun -mdbValToNoun (MDB_val sz ptr) = do - bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) - let res = (bs ^? from pillBS . from pill . _Cue) - maybeErr res "mdb bad cue" - -putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO () -putRaw flags txn db key val = - mdb_put flags txn db key val >>= \case - True -> pure () - False -> error "mdb bad put" - -putNoun :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO () -putNoun flags txn db key val = - byteStringAsMdbVal key $ \mKey -> - byteStringAsMdbVal (val ^. re _CueBytes) $ \mVal -> - putRaw flags txn db mKey mVal - -putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO () -putJam flags txn db id (Jam atom) = do - withWord64AsMDBval id $ \idVal -> do - let !bs = atom ^. pill . pillBS - byteStringAsMdbVal bs $ \mVal -> do - putRaw flags txn db idVal mVal - -get :: MDB_txn -> MDB_dbi -> ByteString -> IO Noun -get txn db key = - byteStringAsMdbVal key \mKey -> - mdb_get txn db mKey >>= maybe (error "mdb bad get") mdbValToNoun - -mdbValToWord64 :: MDB_val -> IO Word64 -mdbValToWord64 (MDB_val sz ptr) = do - assertErr (sz == 8) "wrong size in mdbValToWord64" - peek (castPtr ptr) - -withWord64AsMDBval :: Word64 -> (MDB_val -> IO a) -> IO a -withWord64AsMDBval w cb = do - withWordPtr w $ \p -> - cb (MDB_val (fromIntegral (sizeOf w)) (castPtr p)) - --------------------------------------------------------------------------------- - -withWordPtr :: Word64 -> (Ptr Word64 -> IO a) -> IO a -withWordPtr w cb = do - allocaBytes (sizeOf w) (\p -> poke p w >> cb p) - --- TODO: We need to be able to send back an exception to the main thread on an --- exception on the persistence thread. -persistThread :: MDB_env - -> TQueue (Writ [Eff]) - -> (Writ [Eff] -> STM ()) - -> IO (Async ()) -persistThread env inputQueue onPersist = asyncBound $ - forever do - writs <- atomically $ readQueue inputQueue - writeEvents writs - atomically $ traverse_ onPersist writs - where - writeEvents writs = do - txn <- mdb_txn_begin env Nothing False - db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] - - let flags = compileWriteFlags [MDB_NOOVERWRITE] - - for_ writs $ \w -> do - putJam flags txn db (eventId w) (event w) - - mdb_txn_commit txn - -deriving instance Show MDB_val +-- Read Events ----------------------------------------------------------------- -- TODO: This will read len items and will error if there are less than that -- available. This differs from the current pier.c's expectations. -readEvents :: LogState -> Word64 -> Word64 -> IO (V.Vector (Word64,Atom)) -readEvents (LogState env _ _ _) first len = +readEvents :: EventLog -> Word64 -> Word64 -> IO (V.Vector (Word64,Atom)) +readEvents (EventLog env) first len = withWordPtr first $ \pIdx -> withKVPtrs (MDB_val 8 (castPtr pIdx)) (MDB_val 0 nullPtr) $ \pKey pVal -> do @@ -186,6 +130,9 @@ readEvents (LogState env _ _ _) first len = pure vec + +-- Utils ----------------------------------------------------------------------- + int :: Word64 -> Int int = fromIntegral @@ -193,44 +140,63 @@ assertErr :: Bool -> String -> IO () assertErr True _ = pure () assertErr False m = error m -latestEventNumber :: LogState -> IO Word64 -latestEventNumber (LogState env _ _ _) = - do - txn <- mdb_txn_begin env Nothing True - db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] - cur <- mdb_cursor_open txn db - res <- fetch txn db cur - mdb_cursor_close cur - mdb_txn_abort txn - pure res - where - key = MDB_val 0 nullPtr - val = MDB_val 0 nullPtr - fetch txn db cur = - withKVPtrs key val $ \pKey pVal -> - mdb_cursor_get MDB_LAST cur pKey pVal >>= \case - False -> pure 0 - True -> peek pKey >>= mdbValToWord64 +maybeErr :: Maybe a -> String -> IO a +maybeErr (Just x) _ = pure x +maybeErr Nothing msg = error msg --------------------------------------------------------------------------------- +byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a +byteStringAsMdbVal bs k = + BU.unsafeUseAsCStringLen bs \(ptr,sz) -> + k (MDB_val (fromIntegral sz) (castPtr ptr)) -readLogIdentity :: LogState -> IO LogIdentity -readLogIdentity (LogState env _ _ _) = do - txn <- mdb_txn_begin env Nothing True - db <- mdb_dbi_open txn (Just "META") [] - who <- get txn db "who" - is_fake <- get txn db "is-fake" - life <- get txn db "life" - mdb_txn_abort txn - pure (LogIdentity who is_fake life) +mdbValToWord64 :: MDB_val -> IO Word64 +mdbValToWord64 (MDB_val sz ptr) = do + assertErr (sz == 8) "wrong size in mdbValToWord64" + peek (castPtr ptr) -writeLogIdentity :: LogState -> LogIdentity -> IO () -writeLogIdentity (LogState env _ _ _) LogIdentity{..} = do - txn <- mdb_txn_begin env Nothing False - db <- mdb_dbi_open txn (Just "META") [MDB_CREATE] - let flags = compileWriteFlags [] - putNoun flags txn db "who" who - putNoun flags txn db "is-fake" is_fake - putNoun flags txn db "life" life - mdb_txn_commit txn - pure () +withWord64AsMDBval :: Word64 -> (MDB_val -> IO a) -> IO a +withWord64AsMDBval w cb = do + withWordPtr w $ \p -> + cb (MDB_val (fromIntegral (sizeOf w)) (castPtr p)) + +withWordPtr :: Word64 -> (Ptr Word64 -> IO a) -> IO a +withWordPtr w cb = do + allocaBytes (sizeOf w) (\p -> poke p w >> cb p) + + +-- Lower-Level Operations ------------------------------------------------------ + +get :: MDB_txn -> MDB_dbi -> ByteString -> IO Noun +get txn db key = + byteStringAsMdbVal key \mKey -> + mdb_get txn db mKey >>= maybe (error "mdb bad get") mdbValToNoun + +mdbValToAtom :: MDB_val -> IO Atom +mdbValToAtom (MDB_val sz ptr) = do + bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) + pure (bs ^. from (pill . pillBS)) + +mdbValToNoun :: MDB_val -> IO Noun +mdbValToNoun (MDB_val sz ptr) = do + bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) + let res = (bs ^? from pillBS . from pill . _Cue) + maybeErr res "mdb bad cue" + +putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO () +putRaw flags txn db key val = + mdb_put flags txn db key val >>= \case + True -> pure () + False -> error "mdb bad put" + +putNoun :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO () +putNoun flags txn db key val = + byteStringAsMdbVal key $ \mKey -> + byteStringAsMdbVal (val ^. re _CueBytes) $ \mVal -> + putRaw flags txn db mKey mVal + +putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO () +putJam flags txn db id (Jam atom) = do + withWord64AsMDBval id $ \idVal -> do + let !bs = atom ^. pill . pillBS + byteStringAsMdbVal bs $ \mVal -> do + putRaw flags txn db idVal mVal diff --git a/pkg/hs-urbit/lib/Vere/Persist.hs b/pkg/hs-urbit/lib/Vere/Persist.hs new file mode 100644 index 000000000..8a6678f59 --- /dev/null +++ b/pkg/hs-urbit/lib/Vere/Persist.hs @@ -0,0 +1,77 @@ +{- + TODO Close the database on uncaught exception. + TODO `Persist` should just be the thread id. + the thread should close the database when it is killed. +-} + +module Vere.Persist (start, stop) where + +import ClassyPrelude hiding (init) + +import Vere.Log +import Vere.Pier.Types +import Database.LMDB.Raw + + +-- Types ----------------------------------------------------------------------- + +data Persist = Persist EventLog (Async ()) + + +-- Start and Stop -------------------------------------------------------------- + +start :: EventLog + -> TQueue (Writ [Eff]) + -> (Writ [Eff] -> STM ()) + -> IO Persist +start log inp cb = do + tid <- asyncBound (persistThread log inp cb) + pure (Persist log tid) + +-- TODO: properly handle shutdowns during write +stop :: Persist -> IO () +stop (Persist log tid) = do + void (cancel tid) + void (waitCatch tid) + close log + + +-- Persist Thread -------------------------------------------------------------- + +-- TODO: We need to be able to send back an exception to the main thread on an +-- exception on the persistence thread. +persistThread :: EventLog + -> TQueue (Writ [Eff]) + -> (Writ [Eff] -> STM ()) + -> IO () +persistThread (EventLog env) inputQueue onPersist = + forever do + writs <- atomically $ readQueue inputQueue + writeEvents writs + atomically $ traverse_ onPersist writs + where + writeEvents writs = do + txn <- mdb_txn_begin env Nothing False + db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] + + let flags = compileWriteFlags [MDB_NOOVERWRITE] + + for_ writs $ \w -> do + putJam flags txn db (eventId w) (event w) + + mdb_txn_commit txn + + +-- Get eventhing from the input queue. ----------------------------------------- + +{- + Read one or more items from a TQueue, only blocking on the first item. +-} +readQueue :: TQueue a -> STM (NonNull [a]) +readQueue q = + readTQueue q >>= go . singleton + where + go acc = + tryReadTQueue q >>= \case + Nothing -> pure (reverse acc) + Just item -> go (item <| acc) diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 3a9ae2b96..ad08a92e6 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -7,87 +7,75 @@ import Data.Noun.Pill import Vere import Vere.Pier.Types -import qualified Vere.Log as Log -import qualified Vere.Worker as Worker +import qualified Vere.Log as Log +import qualified Vere.Persist as Persist +import qualified Vere.Serf as Serf + +import Vere.Serf (Serf, EventId) + + +-------------------------------------------------------------------------------- ioDrivers = [] :: [IODriver] + +-------------------------------------------------------------------------------- + -- This is called to make a freshly booted pier. It assigns an identity to an -- event log and takes a chill pill. -newPier :: Pill -> FilePath -> LogIdentity -> IO Pier -newPier pill top id = do +boot :: Pill -> FilePath -> LogIdentity -> IO (Serf, EventLog, EventId, Mug) +boot pill top id = do let logPath = top <> "/log" - computeQueue <- newTQueueIO - persistQueue <- newTQueueIO - releaseQueue <- newTQueueIO + log <- Log.open logPath - -- What we really want to do is write the log identity and then do normal - -- startup, but writeLogIdentity requires a full log state including - -- input/output queues. - logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) + Log.writeIdent log id - -- In first boot, we need to write this! - Log.writeLogIdentity logState id + serf <- Serf.startSerfProcess top + (e, m) <- Serf.bootSerf serf id pill - let logLatestEventNumber = 0 - let getEvents = Log.readEvents logState - - workerState <- Worker.startWorkerProcess - - Worker.bootWorker workerState id pill - - performCommonPierStartup workerState computeQueue persistQueue releaseQueue logState + pure (serf, log, e, m) --- This reads in a pier -runPierFromDisk :: FilePath -> IO Pier -runPierFromDisk top = do - let logPath = top <> "/log" +{- + What we really want to do is write the log identity and then do + normal startup, but writeIdent requires a full log state + including input/output queues. +-} +resume :: FilePath -> IO (Serf, EventLog, EventId, Mug) +resume top = do + log <- Log.open (top <> "/.urb/log") + ident <- Log.readIdent log + lastEv <- Log.latestEventNumber log + serf <- Serf.startSerfProcess top + (e, m) <- Serf.replay serf ident lastEv (Log.readEvents log) - computeQueue <- newTQueueIO - persistQueue <- newTQueueIO - releaseQueue <- newTQueueIO + pure (serf, log, e, m) - -- What we really want to do is write the log identity and then do normal - -- startup, but writeLogIdentity requires a full log state including - -- input/output queues. - logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) - - -- In first boot, we need to write this! - id <- Log.readLogIdentity logState - logLatestEventNumber <- Log.latestEventNumber logState - - let getEvents = Log.readEvents logState - - workerState <- Worker.startWorkerProcess - Worker.resumeWorker workerState id logLatestEventNumber getEvents - - performCommonPierStartup workerState computeQueue persistQueue releaseQueue logState - - -performCommonPierStartup :: Worker.Worker +{- +performCommonPierStartup :: Serf.Serf -> TQueue Ovum -> TQueue (Writ [Eff]) -> TQueue (Writ [Eff]) -> LogState -> IO Pier -performCommonPierStartup workerState computeQueue persistQueue releaseQueue logState = do +performCommonPierStartup serf computeQ persistQ releaseQ logState = do for ioDrivers $ \x -> do bootMessage <- bornEvent x - atomically $ writeTQueue computeQueue bootMessage + atomically $ writeTQueue computeQ bootMessage driverThreads <- for ioDrivers $ \x -> do - startDriver x (writeTQueue computeQueue) + startDriver x (writeTQueue computeQ) -- TODO: Don't do a bunch of extra work; we send all events to all drivers portingThread <- async $ do forever $ do - r <- atomically (readTQueue releaseQueue) + r <- atomically (readTQueue releaseQ) for_ driverThreads $ \(_, k) -> for_ (payload r) $ \eff -> k eff - Worker.workerThread workerState (readTQueue computeQueue) undefined + Serf.workerThread serf (readTQueue computeQ) undefined pure (Pier{..}) +-} diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 20128806d..bd6bbbce5 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -75,6 +75,8 @@ data Pier = Pier , portingThread :: Async () } +newtype EventLog = EventLog MDB_env + -- TODO: We are uncertain about q's type. There's some serious entanglement -- with u3_pier in this logic in the C code, and you might not be able to get -- away with anything less than passing the full u3_writ around. diff --git a/pkg/hs-urbit/lib/Vere/Worker.hs b/pkg/hs-urbit/lib/Vere/Serf.hs similarity index 64% rename from pkg/hs-urbit/lib/Vere/Worker.hs rename to pkg/hs-urbit/lib/Vere/Serf.hs index a9354194a..67adbad31 100644 --- a/pkg/hs-urbit/lib/Vere/Worker.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -1,4 +1,4 @@ -module Vere.Worker where +module Vere.Serf where import ClassyPrelude import Control.Lens @@ -23,7 +23,7 @@ import Foreign.Storable (peek) import qualified Vere.Log as Log -data Worker = Worker +data Serf = Serf { sendHandle :: Handle , recvHandle :: Handle , process :: ProcessHandle @@ -31,7 +31,7 @@ data Worker = Worker -- , getInput :: STM (Writ ()) -- , onComputed :: Writ [Effect] -> STM () --- , onExit :: Worker -> IO () +-- , onExit :: Serf -> IO () -- , task :: Async () } @@ -39,20 +39,27 @@ data Worker = Worker -------------------------------------------------------------------------------- --- Think about how to handle process exit --- Tear down subprocess on exit? (terminiteProcess) -startWorkerProcess :: IO Worker -startWorkerProcess = +{- + TODO Think about how to handle process exit + TODO Tear down subprocess on exit? (terminiteProcess) + TODO `config` is a stub, fill it in. +-} +startSerfProcess :: FilePath -> IO Serf +startSerfProcess pier = do (Just i, Just o, _, p) <- createProcess pSpec - pure (Worker i o p) + pure (Serf i o p) where - pSpec = - (proc "urbit-worker" []) { std_in = CreatePipe - , std_out = CreatePipe - } + chkDir = traceShowId pier + diskKey = "" + config = "0" + args = [chkDir, diskKey, config] + pSpec = (proc "urbit-worker" args) + { std_in = CreatePipe + , std_out = CreatePipe + } -kill :: Worker -> IO ExitCode +kill :: Serf -> IO ExitCode kill w = do terminateProcess (process w) waitForProcess (process w) @@ -73,7 +80,7 @@ newtype ShipId = ShipId (Ship, Bool) -------------------------------------------------------------------------------- -type Play = Nullable (EventId, Mug, ShipId) +type Play = Maybe (EventId, Mug, ShipId) data Plea = Play Play @@ -106,27 +113,27 @@ instance FromNoun Plea where type CompletedEventId = Word64 type NextEventId = Word64 -type WorkerState = (EventId, Mug) +type SerfState = (EventId, Mug) type ReplacementEv = (EventId, Mug, Job) -type WorkResult = (EventId, Mug, [Eff]) -type WorkerResp = (Either ReplacementEv WorkResult) +type WorkResult = (EventId, Mug, [Eff]) +type SerfResp = (Either ReplacementEv WorkResult) -- Exceptions ------------------------------------------------------------------ -data WorkerExn +data SerfExn = BadComputeId EventId WorkResult | BadReplacementId EventId ReplacementEv | UnexpectedPlay EventId Play | BadPleaAtom Atom - | BadPleaNoun Noun + | BadPleaNoun Noun Text | ReplacedEventDuringReplay EventId ReplacementEv - | WorkerConnectionClosed + | SerfConnectionClosed | UnexpectedPleaOnNewShip Plea | InvalidInitialPlea Plea deriving (Show) -instance Exception WorkerExn +instance Exception SerfExn -- Utils ----------------------------------------------------------------------- @@ -140,25 +147,32 @@ fromJustExn :: Exception e => Maybe a -> e -> IO a fromJustExn Nothing exn = throwIO exn fromJustExn (Just x) exn = pure x +fromRightExn :: Exception e => Either Text a -> (Text -> e) -> IO a +fromRightExn (Left m) exn = throwIO (exn m) +fromRightExn (Right x) _ = pure x + -------------------------------------------------------------------------------- -sendAndRecv :: Worker -> EventId -> Atom -> IO WorkerResp +sendAndRecv :: Serf -> EventId -> Atom -> IO SerfResp sendAndRecv w eventId event = do + traceM ("sendAndRecv: " <> show eventId) sendAtom w $ work eventId (Jam event) - loop + res <- loop + traceM "sendAndRecv.done" + pure res where - produce :: WorkResult -> IO WorkerResp + produce :: WorkResult -> IO SerfResp produce (i, m, o) = do guardExn (i /= eventId) (BadComputeId eventId (i, m, o)) pure $ Right (i, m, o) - replace :: ReplacementEv -> IO WorkerResp + replace :: ReplacementEv -> IO SerfResp replace (i, m, j) = do guardExn (i /= eventId) (BadReplacementId eventId (i, m, j)) pure (Left (i, m, j)) - loop :: IO WorkerResp + loop :: IO SerfResp loop = recvPlea w >>= \case Play p -> throwIO (UnexpectedPlay eventId p) Done i m o -> produce (i, m, o) @@ -166,32 +180,43 @@ sendAndRecv w eventId event = Stdr _ cord -> print cord >> loop Slog _ pri t -> printTank pri t >> loop -sendBootEvent :: LogIdentity -> Worker -> IO () +sendBootEvent :: LogIdentity -> Serf -> IO () sendBootEvent id w = do sendAtom w $ jam $ toNoun (Cord "boot", id) -- the ship is booted, but it is behind. shove events to the worker until it is -- caught up. -replay :: Worker - -> WorkerState - -> LogIdentity - -> EventId - -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) - -> IO (EventId, Mug) -replay w (wid, wmug) identity lastCommitedId getEvents = do +replayEvents :: Serf + -> SerfState + -> LogIdentity + -> EventId + -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) + -> IO (EventId, Mug) +replayEvents w (wid, wmug) identity lastCommitedId getEvents = do + traceM ("replayEvents: " <> show wid <> " " <> show wmug) + when (wid == 1) (sendBootEvent identity w) vLast <- newIORef (wid, wmug) loop vLast wid - readIORef vLast + + res <- readIORef vLast + traceM ("replayEvents.return " <> show res) + pure res + where -- Replay events in batches of 1000. loop vLast curEvent = do + traceM ("replayEvents.loop: " <> show curEvent) let toRead = min 1000 (1 + lastCommitedId - curEvent) when (toRead > 0) do + traceM ("replayEvents.loop.getEvents " <> show toRead) + events <- getEvents curEvent toRead + traceM ("got events " <> show (length events)) + for_ events $ \(eventId, event) -> do sendAndRecv w eventId event >>= \case Left ev -> throwIO (ReplacedEventDuringReplay eventId ev) @@ -200,45 +225,35 @@ replay w (wid, wmug) identity lastCommitedId getEvents = do loop vLast (curEvent + toRead) -bootWorker :: Worker - -> LogIdentity - -> Pill - -> IO () -bootWorker w identity pill = +bootSerf :: Serf -> LogIdentity -> Pill -> IO (EventId, Mug) +bootSerf w ident pill = do recvPlea w >>= \case - Play Nil -> pure () - x@(Play _) -> throwIO (UnexpectedPleaOnNewShip x) - x -> throwIO (InvalidInitialPlea x) + Play Nothing -> pure () + x@(Play _) -> throwIO (UnexpectedPleaOnNewShip x) + x -> throwIO (InvalidInitialPlea x) -- TODO: actually boot the pill undefined - requestSnapshot w - -- Maybe return the current event id ? But we'll have to figure that out -- later. - pure () + pure undefined -resumeWorker :: Worker - -> LogIdentity - -> EventId - -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) - -> IO (EventId, Mug) -resumeWorker w identity logLatestEventNumber eventFetcher = - do +type GetEvents = EventId -> Word64 -> IO (Vector (EventId, Atom)) + +replay :: Serf -> LogIdentity -> EventId -> GetEvents -> IO (EventId, Mug) +replay w ident lastEv getEvents = do ws@(eventId, mug) <- recvPlea w >>= \case - Play Nil -> pure (1, Mug 0) - Play (NotNil (e, m, _)) -> pure (e, m) - x -> throwIO (InvalidInitialPlea x) + Play Nothing -> pure (1, Mug 0) + Play (Just (e, m, _)) -> pure (e, m) + x -> throwIO (InvalidInitialPlea x) - r <- replay w ws identity logLatestEventNumber eventFetcher + traceM ("got plea! " <> show eventId <> " " <> show mug) - requestSnapshot w + replayEvents w ws ident lastEv getEvents - pure r - -workerThread :: Worker -> STM Ovum -> (EventId, Mug) -> IO (Async ()) +workerThread :: Serf -> STM Ovum -> (EventId, Mug) -> IO (Async ()) workerThread w getEvent (evendId, mug) = async $ forever do ovum <- atomically $ getEvent @@ -247,15 +262,15 @@ workerThread w getEvent (evendId, mug) = async $ forever do let mat = jam (undefined (mug, currentDate, ovum)) undefined - + -- Writ (eventId + 1) Nothing mat -- -- assign a new event id. -- -- assign a date -- -- get current mug state -- -- (jam [mug event]) - -- sendAndRecv + -- sendAndRecv -requestSnapshot :: Worker -> IO () +requestSnapshot :: Serf -> IO () requestSnapshot w = undefined -- The flow here is that we start the worker and then we receive a play event @@ -263,7 +278,7 @@ requestSnapshot w = undefined -- -- <- [%play ...] -- --- Base on this, the main flow is +-- Base on this, the main flow is -- -- [%work ] -> @@ -281,8 +296,12 @@ requestSnapshot w = undefined -- Basic Send and Receive Operations ------------------------------------------- -sendAtom :: Worker -> Atom -> IO () -sendAtom w a = hPut (sendHandle w) (unpackAtom a) +sendAtom :: Serf -> Atom -> IO () +sendAtom w a = do + traceM "sendAtom" + hPut (sendHandle w) (unpackAtom a) + hFlush (sendHandle w) + traceM "sendAtom.return ()" atomBytes :: Iso' Atom ByteString atomBytes = pill . pillBS @@ -292,26 +311,44 @@ packAtom = view (from atomBytes) unpackAtom :: Atom -> ByteString unpackAtom = view atomBytes -recvLen :: Worker -> IO Word64 +recvLen :: Serf -> IO Word64 recvLen w = do + traceM "recvLen.wait" bs <- hGet (recvHandle w) 8 + traceM "recvLen.got" case length bs of -- This is not big endian safe 8 -> unsafeUseAsCString bs (peek . castPtr) - _ -> throwIO WorkerConnectionClosed + _ -> throwIO SerfConnectionClosed -recvBytes :: Worker -> Word64 -> IO ByteString -recvBytes w = hGet (recvHandle w) . fromIntegral +recvBytes :: Serf -> Word64 -> IO ByteString +recvBytes w = do + traceM "recvBytes" + hGet (recvHandle w) . fromIntegral -recvAtom :: Worker -> IO Atom +recvAtom :: Serf -> IO Atom recvAtom w = do + traceM "recvAtom" len <- recvLen w bs <- recvBytes w len pure (packAtom bs) -recvPlea :: Worker -> IO Plea +cordString :: Cord -> String +cordString (Cord bs) = unpack $ decodeUtf8 bs + +recvPlea :: Serf -> IO Plea recvPlea w = do + traceM "recvPlea" + a <- recvAtom w + traceM ("recvPlea.cue " <> show (length $ a ^. atomBytes)) n <- fromJustExn (cue a) (BadPleaAtom a) - p <- fromJustExn (fromNoun n) (BadPleaNoun n) - pure p + traceM "recvPlea.doneCue" + p <- fromRightExn (fromNounErr n) (BadPleaNoun n) + + traceM "recvPlea.done" + + -- TODO Hack! + case p of + Stdr e msg -> traceM (cordString msg) >> recvPlea w + _ -> pure p diff --git a/pkg/hs-vere/app/test/Main.hs b/pkg/hs-vere/app/test/Main.hs index 645674b1f..3c7913002 100644 --- a/pkg/hs-vere/app/test/Main.hs +++ b/pkg/hs-vere/app/test/Main.hs @@ -2,45 +2,78 @@ module Main where import ClassyPrelude import Vere.Pier.Types -import Data.Noun.Jam hiding (main) -import qualified Vere.Log as Log + +import Data.Noun.Jam () + +import qualified Vere.Log as Log +import qualified Vere.Persist as Persist +import qualified Vere.Pier as Pier + + +-------------------------------------------------------------------------------- main :: IO () main = do - let logPath = "/Users/erg/src/urbit/zod/.urb/falselog/" + (s,l,e,m) <- Pier.resume "/home/benjamin/r/urbit/zod/" + + putStrLn "Resumed!" + + pure () + +-------------------------------------------------------------------------------- + +tryCopyLog :: IO () +tryCopyLog = do + let logPath = "/Users/erg/src/urbit/zod/.urb/falselog/" falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog2/" - -- junk - persistQueue <- newTQueueIO - releaseQueue <- newTQueueIO - logState <- Log.init logPath persistQueue (writeTQueue releaseQueue) + ---------------------------------------- - -- - logId <- Log.readLogIdentity logState - print logId + persistQ <- newTQueueIO + releaseQ <- newTQueueIO + log <- Log.open logPath + persist <- Persist.start log persistQ (writeTQueue releaseQ) + ident <- Log.readIdent log - -- - latestEvent <- Log.latestEventNumber logState - print latestEvent + ---------------------------------------- - -- - events <- Log.readEvents logState 1 3142 - --print $ cue . snd <$> events + lastEv <- Log.latestEventNumber log + events <- Log.readEvents log 1 3142 - -- - persistQueue2 <- newTQueueIO - releaseQueue2 <- newTQueueIO - falseLogState <- Log.init falselogPath persistQueue2 (writeTQueue releaseQueue2) + ---------------------------------------- - Log.writeLogIdentity falseLogState logId + print ident + print lastEv + print (length events) + + ---------------------------------------- + + persistQ2 <- newTQueueIO + releaseQ2 <- newTQueueIO + log2 <- Log.open falselogPath + persist2 <- Persist.start log2 persistQ2 (writeTQueue releaseQ2) + + ---------------------------------------- + + Log.writeIdent log2 ident let writs = events <&> \(id, a) -> - Writ id Nothing (Jam a) [] + Writ id Nothing (Jam a) [] + + ---------------------------------------- print "About to write" - for_ writs $ \w -> atomically $ writeTQueue persistQueue2 w + + for_ writs $ \w -> + atomically (writeTQueue persistQ2 w) + + ---------------------------------------- print "About to wait" - replicateM_ 100 $ atomically $ readTQueue releaseQueue2 + replicateM_ 100 $ do + atomically $ readTQueue releaseQ2 + + ---------------------------------------- + print "Done" diff --git a/pkg/urbit/vere/pier.c b/pkg/urbit/vere/pier.c index f69c9f7a7..2873daf17 100644 --- a/pkg/urbit/vere/pier.c +++ b/pkg/urbit/vere/pier.c @@ -1047,10 +1047,10 @@ _pier_work_create(u3_pier* pir_u) sprintf(wag_c, "%u", pir_u->wag_w); - arg_c[0] = bin_c; // executable - arg_c[1] = pax_c; // path to checkpoint directory - arg_c[2] = key_c; // disk key - arg_c[3] = wag_c; // runtime config + arg_c[0] = bin_c; // executable + arg_c[1] = pax_c; // path to checkpoint directory (might be the pier, might be $pier/chk) + arg_c[2] = key_c; // disk key (ignored) + arg_c[3] = wag_c; // runtime config arg_c[4] = 0; uv_pipe_init(u3L, &god_u->inn_u.pyp_u, 0); diff --git a/stack.yaml b/stack.yaml index 152439f36..00bb63e7f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,6 +18,8 @@ nix: - SDL2_image - zlib +ghc-options: + urbit: '-fobject-code' # build: # library-profiling: true From febaeada1a8a4284b4ec7e3bab1470a50200b34a Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 25 Jun 2019 13:58:07 -0700 Subject: [PATCH 076/431] Actually replay events! Also, parse some effects. --- pkg/hs-urbit/lib/Data/Noun/Poet.hs | 8 +-- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 70 +++++++++++++++++++++++++- pkg/hs-urbit/lib/Vere/Serf.hs | 76 +++++++++++++++++++---------- pkg/hs-urbit/package.yaml | 1 + pkg/urbit/worker/main.c | 11 +++++ 5 files changed, 135 insertions(+), 31 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Data/Noun/Poet.hs index 45247c539..e37b1d1d6 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet.hs @@ -33,10 +33,10 @@ newtype Tour = Tour [Char] deriving (Eq, Ord, Show) newtype Tape = Tape ByteString - deriving (Eq, Ord, Show) + deriving newtype (Eq, Ord, Show, IsString) newtype Cord = Cord ByteString - deriving newtype (Eq, Ord, Show) + deriving newtype (Eq, Ord, Show, IsString) type Tang = [Tank] @@ -357,10 +357,10 @@ instance FromNoun Plum where parseNoun = undefined instance ToNoun Tank where - toNoun = undefined + toNoun = pure (Atom 0) instance FromNoun Tank where - parseNoun = undefined + parseNoun _ = pure (TLeaf (Tape "TODO: Tank Parsing")) -- Pair Conversion ------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index bd6bbbce5..ec2d33ee6 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -8,6 +8,8 @@ import Data.Noun.Poet import Database.LMDB.Raw import Urbit.Time +import RIO (decodeUtf8Lenient) + import qualified Vere.Http.Server as Server import qualified Vere.Http.Client as Client @@ -20,6 +22,16 @@ data Event | CttpBorn deriving (Eq, Ord, Show) +data PutDel = Put | Del + deriving (Eq, Ord, Show) + +instance FromNoun PutDel where + parseNoun n = do + parseNoun n >>= \case + Cord "put" -> pure Put + Cord "del" -> pure Del + Cord cord -> fail ("Invalid turf operation: " <> show cord) + data Eff = HttpServer Server.Eff | HttpClient Client.Eff @@ -31,19 +43,73 @@ data Eff | Ames Void | Init Void | Term Void + | Hill [Term] + | Turf (Maybe (PutDel, [Text])) -- TODO Unsure deriving (Eq, Ord, Show) instance ToNoun Eff where + toNoun = const (Atom 0) instance FromNoun Eff where + parseNoun = \case + Atom _ -> + fail "Eff: Expecting cell, but got an atom" + Cell h t -> + parseNoun h >>= \case + Cord "hill" -> do + paths <- parseNoun t + pure (Hill paths) + Cord "turf" -> do + arg <- parseNoun t + pure (Turf arg) + Cord nm -> do + fail ("Eff: unknown effect " <> unpack (decodeUtf8Lenient nm)) +-------------------------------------------------------------------------------- + +instance ToNoun Text where -- XX op args)TODO + toNoun t = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Text where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (decodeUtf8Lenient c) + + +-------------------------------------------------------------------------------- + +newtype Term = MkTerm Text + deriving newtype (Eq, Ord, Show) + +instance ToNoun Term where -- XX TODO + toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Term where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (MkTerm (decodeUtf8Lenient c)) + +-------------------------------------------------------------------------------- + +newtype Knot = MkKnot Text + deriving newtype (Eq, Ord, Show) + +instance ToNoun Knot where -- XX TODO + toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Knot where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (MkKnot (decodeUtf8Lenient c)) + +-------------------------------------------------------------------------------- data Varience = Gold | Iron | Lead type Perform = Eff -> IO () -newtype Path = Path [Text] - deriving (Eq, Ord, Show) +newtype Path = Path [Knot] + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) data Ovum = Ovum Path Event deriving (Eq, Ord, Show, ToNoun, FromNoun) diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 67adbad31..dd77a23b6 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -4,8 +4,6 @@ import ClassyPrelude import Control.Lens import Data.Void -import System.Exit (ExitCode) - import Data.Noun import Data.Noun.Atom import Data.Noun.Jam @@ -14,29 +12,35 @@ import Data.Noun.Pill import Vere.Pier.Types import System.Process -import qualified Urbit.Time as Time - +import Foreign.Marshal.Alloc (alloca) +import System.Exit (ExitCode) import Data.ByteString (hGet) import Data.ByteString.Unsafe (unsafeUseAsCString) import Foreign.Ptr (castPtr) -import Foreign.Storable (peek) +import Foreign.Storable (poke, peek) -import qualified Vere.Log as Log +import qualified Data.ByteString.Unsafe as BS +import qualified Urbit.Time as Time +import qualified Vere.Log as Log + +-------------------------------------------------------------------------------- + + +{- + TODO: + - getInput :: STM (Writ ()) + - onComputed :: Writ [Effect] -> STM () + - onExit :: Serf -> IO () + - task :: Async () +-} data Serf = Serf { sendHandle :: Handle , recvHandle :: Handle , process :: ProcessHandle - - -- , getInput :: STM (Writ ()) - -- , onComputed :: Writ [Effect] -> STM () - --- , onExit :: Serf -> IO () --- , task :: Async () } - -------------------------------------------------------------------------------- {- @@ -85,19 +89,24 @@ type Play = Maybe (EventId, Mug, ShipId) data Plea = Play Play | Work EventId Mug Job - | Done EventId Mug [Eff] + | Done EventId Mug [Either Text (Path, Eff)] | Stdr EventId Cord | Slog EventId Word32 Tank deriving (Eq, Show) +fromRight (Right x) = x + instance ToNoun Plea where toNoun = \case Play p -> toNoun (Cord "play", p) Work i m j -> toNoun (Cord "work", i, m, j) - Done i m o -> toNoun (Cord "done", i, m, o) + Done i m o -> toNoun (Cord "done", i, m, fromRight <$> o) Stdr i msg -> toNoun (Cord "stdr", i, msg) Slog i p t -> toNoun (Cord "slog", i, p, t) +instance FromNoun (Either Text (Path, Eff)) where + parseNoun = pure . fromNounErr + instance FromNoun Plea where parseNoun n = parseNoun n >>= \case @@ -116,7 +125,7 @@ type NextEventId = Word64 type SerfState = (EventId, Mug) type ReplacementEv = (EventId, Mug, Job) -type WorkResult = (EventId, Mug, [Eff]) +type WorkResult = (EventId, Mug, [Either Text (Path, Eff)]) type SerfResp = (Either ReplacementEv WorkResult) -- Exceptions ------------------------------------------------------------------ @@ -138,7 +147,7 @@ instance Exception SerfExn -- Utils ----------------------------------------------------------------------- printTank :: Word32 -> Tank -> IO () -printTank pri t = print "tank" +printTank pri t = print "[SERF] tank" guardExn :: Exception e => Bool -> e -> IO () guardExn ok = unless ok . throwIO @@ -157,19 +166,20 @@ sendAndRecv :: Serf -> EventId -> Atom -> IO SerfResp sendAndRecv w eventId event = do traceM ("sendAndRecv: " <> show eventId) + traceM (show (cue event)) sendAtom w $ work eventId (Jam event) res <- loop - traceM "sendAndRecv.done" + traceM ("sendAndRecv.done " <> show res) pure res where produce :: WorkResult -> IO SerfResp produce (i, m, o) = do - guardExn (i /= eventId) (BadComputeId eventId (i, m, o)) + guardExn (i == eventId) (BadComputeId eventId (i, m, o)) pure $ Right (i, m, o) replace :: ReplacementEv -> IO SerfResp replace (i, m, j) = do - guardExn (i /= eventId) (BadReplacementId eventId (i, m, j)) + guardExn (i == eventId) (BadReplacementId eventId (i, m, j)) pure (Left (i, m, j)) loop :: IO SerfResp @@ -177,7 +187,7 @@ sendAndRecv w eventId event = Play p -> throwIO (UnexpectedPlay eventId p) Done i m o -> produce (i, m, o) Work i m j -> replace (i, m, j) - Stdr _ cord -> print cord >> loop + Stdr _ cord -> putStrLn (pack ("[SERF] " <> cordString cord)) >> loop Slog _ pri t -> printTank pri t >> loop sendBootEvent :: LogIdentity -> Serf -> IO () @@ -296,11 +306,27 @@ requestSnapshot w = undefined -- Basic Send and Receive Operations ------------------------------------------- +withWord64AsByteString :: Word64 -> (ByteString -> IO a) -> IO a +withWord64AsByteString w k = do + alloca $ \wp -> do + poke wp w + bs <- BS.unsafePackCStringLen (castPtr wp, 8) + k bs + +sendLen :: Serf -> Int -> IO () +sendLen s i = do + traceM "sendLen.put" + w <- evaluate (fromIntegral i :: Word64) + withWord64AsByteString (fromIntegral i) (hPut (sendHandle s)) + traceM "sendLen.done" + sendAtom :: Serf -> Atom -> IO () -sendAtom w a = do +sendAtom s a = do traceM "sendAtom" - hPut (sendHandle w) (unpackAtom a) - hFlush (sendHandle w) + let bs = unpackAtom a + sendLen s (length bs) + hPut (sendHandle s) bs + hFlush (sendHandle s) traceM "sendAtom.return ()" atomBytes :: Iso' Atom ByteString @@ -350,5 +376,5 @@ recvPlea w = do -- TODO Hack! case p of - Stdr e msg -> traceM (cordString msg) >> recvPlea w + Stdr e msg -> traceM ("[SERF] " <> cordString msg) >> recvPlea w _ -> pure p diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index fb9c7efa8..9328701cf 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -35,6 +35,7 @@ dependencies: - primitive - process - QuickCheck + - rio - sdl2 - sdl2-image - semigroups diff --git a/pkg/urbit/worker/main.c b/pkg/urbit/worker/main.c index 1a37ca775..c0ac96fd0 100644 --- a/pkg/urbit/worker/main.c +++ b/pkg/urbit/worker/main.c @@ -342,6 +342,7 @@ _worker_fail(void* vod_p, const c3_c* wut_c) static void _worker_send(u3_noun job) { + fprintf(stderr, "[SERF] _worker_send\n"); u3_newt_write(&u3V.out_u, u3ke_jam(job), 0); } @@ -728,12 +729,17 @@ _worker_poke_boot(u3_noun who, u3_noun fak, c3_w len_w) void _worker_poke(void* vod_p, u3_noun mat) { + fprintf(stderr, "[SERF] _worker_poke\n"); + u3_noun jar = u3ke_cue(mat); + fprintf(stderr, "[SERF] _worker_poke.cued\n"); + if ( c3y != u3du(jar) ) { goto error; } else { + fprintf(stderr, "%lu", (unsigned long) u3h(jar)); switch ( u3h(jar) ) { default: { goto error; @@ -862,6 +868,7 @@ u3_worker_boot(void) u3l_log("work: play %" PRIu64 "\r\n", nex_d); + fprintf(stderr, "[SERF] Sending play event\n"); _worker_send(u3nc(c3__play, dat)); } @@ -870,6 +877,8 @@ u3_worker_boot(void) c3_i main(c3_i argc, c3_c* argv[]) { + fprintf(stderr, "SERF STARTED\n"); + uv_loop_t* lup_u = uv_default_loop(); c3_c* dir_c = argv[1]; c3_c* key_c = argv[2]; @@ -934,7 +943,9 @@ main(c3_i argc, c3_c* argv[]) u3V.inn_u.pok_f = _worker_poke; u3V.inn_u.bal_f = _worker_fail; + fprintf(stderr, "[SERF] main.u3_newt_read\n"); u3_newt_read(&u3V.inn_u); + fprintf(stderr, "[SERF] main.u3_newt_read.done\n"); /* send start request */ From fb7e0b383809c529669ff8245538422dc67ba6b7 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 25 Jun 2019 17:15:49 -0700 Subject: [PATCH 077/431] Got generic deriving of ToNoun mostly working. --- pkg/hs-urbit/lib/Data/Noun.hs | 4 +- pkg/hs-urbit/lib/Data/Noun/Poet.hs | 163 ++++++++++++++++++++++++++- pkg/hs-urbit/lib/Vere/Http.hs | 40 ++++--- pkg/hs-urbit/lib/Vere/Http/Client.hs | 10 +- pkg/hs-urbit/lib/Vere/Http/Server.hs | 25 ++-- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 83 ++++---------- pkg/hs-urbit/lib/Vere/Serf.hs | 2 +- pkg/urbit/vere/reck.c | 17 --- 8 files changed, 227 insertions(+), 117 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun.hs b/pkg/hs-urbit/lib/Data/Noun.hs index f0926d6f0..ad1172252 100644 --- a/pkg/hs-urbit/lib/Data/Noun.hs +++ b/pkg/hs-urbit/lib/Data/Noun.hs @@ -1,7 +1,8 @@ module Data.Noun where -import Prelude +import Prelude hiding (all) +import ClassyPrelude (Text, all, unpack) import Control.Applicative import Control.Monad import Data.Noun.Atom (Atom) @@ -15,6 +16,7 @@ import Data.List (intercalate) import Data.Typeable (Typeable) import qualified Control.Monad.Fail as Fail +import qualified Data.Char as C -- Types ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Data/Noun/Poet.hs index e37b1d1d6..8da625ee8 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} + module Data.Noun.Poet where import ClassyPrelude hiding (fromList) @@ -11,10 +14,14 @@ import Data.Noun.Pill import Data.Void import Data.Word import GHC.Natural +import GHC.Generics hiding (from) -import Data.List (intercalate) -import Data.Typeable (Typeable) +import qualified GHC.Generics as GHC +import Data.Typeable (Typeable) +import RIO (decodeUtf8Lenient) + +import qualified Data.Char as C import qualified Control.Monad.Fail as Fail @@ -35,9 +42,12 @@ newtype Tour = Tour [Char] newtype Tape = Tape ByteString deriving newtype (Eq, Ord, Show, IsString) -newtype Cord = Cord ByteString +newtype Cord = Cord { unCord :: ByteString } deriving newtype (Eq, Ord, Show, IsString) + +-- Pretty Printing ------------------------------------------------------------- + type Tang = [Tank] data Tank @@ -197,6 +207,123 @@ class FromNoun a where class ToNoun a where toNoun :: a -> Noun + default toNoun :: (Generic a, GToNoun (Rep a)) => a -> Noun + toNoun = genericToNoun + + +-- Generic Deriving ToNoun ----------------------------------------------------- + +-- TODO Handle enums + +class GToNoun f where + gToNoun :: f a -> Noun + +genericToNoun :: (Generic a, GToNoun (Rep a)) => a -> Noun +genericToNoun = gToNoun . GHC.from + +-------------------------------------------------------------------------------- + +instance GToNoun V1 where gToNoun _ = undefined +instance GToNoun U1 where gToNoun U1 = Atom 0 + +instance ToNoun a => GToNoun (K1 i a) where + gToNoun = toNoun . unK1 + +instance (GToNoun a, GToNoun b) => GToNoun (a :*: b) where + gToNoun (x :*: y) = Cell (gToNoun x) (gToNoun y) + +instance (GToNoun a, GToNoun b) => GToNoun (a :+: b) where + gToNoun (L1 x) = gToNoun x + gToNoun (R1 x) = gToNoun x + +instance GToNoun a => GToNoun (S1 c a) where + gToNoun x = gToNoun (unM1 x) + +instance GToNoun a => GToNoun (D1 c a) where + gToNoun x = gToNoun (unM1 x) + +instance (GToNoun f, Constructor c) => GToNoun (C1 c f) where + gToNoun x = Cell tag val + where tag = toNoun (hsToHoon $ conName x) + val = gToNoun (unM1 x) + +-------------------------------------------------------------------------------- + +hsToHoon :: String -> Text +hsToHoon = go [] + where + go acc [] = pack $ intercalate "-" $ reverse acc + go acc (c:cs) = go (elem:acc) remain + where + head = C.toLower c + (tail, remain) = break C.isUpper cs + elem = head:tail + +-- Copy-Pasta ------------------------------------------------------------------ + +class HasConstructor (f :: * -> *) where + gConsName :: f x -> String + +instance HasConstructor f => HasConstructor (D1 c f) where + gConsName (M1 x) = gConsName x + +instance (HasConstructor x, HasConstructor y) => HasConstructor (x :+: y) where + gConsName (L1 l) = gConsName l + gConsName (R1 r) = gConsName r + +instance Constructor c => HasConstructor (C1 c f) where + gConsName x = conName x + +consName :: (HasConstructor (Rep a), Generic a) => a -> String +consName = gConsName . GHC.from + +-------------------------------------------------------------------------------- + +int2Word :: Int -> Word +int2Word = fromIntegral + +instance ToNoun ByteString where + toNoun bs = toNoun (int2Word (length bs), bs ^. from (pill . pillBS)) + +instance ToNoun Text where -- XX TODO + toNoun t = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Text where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (decodeUtf8Lenient c) + + +-------------------------------------------------------------------------------- + +newtype Term = MkTerm Text + deriving newtype (Eq, Ord, Show) + +instance ToNoun Term where -- XX TODO + toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Term where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (MkTerm (decodeUtf8Lenient c)) + +-------------------------------------------------------------------------------- + +newtype Knot = MkKnot Text + deriving newtype (Eq, Ord, Show) + +instance ToNoun Knot where -- XX TODO + toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Knot where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (MkKnot (decodeUtf8Lenient c)) + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + fromNoun :: FromNoun a => Noun -> Maybe a fromNoun n = runParser (parseNoun n) [] onFail onSuccess where @@ -427,3 +554,33 @@ instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e,FromNoun f) (p, tail) <- parseNoun n (q, r, s, t, u) <- parseNoun tail pure (p, q, r, s, t, u) + + +-- This Shouldn't Be Here ------------------------------------------------------ + +showAtom :: Atom -> String +showAtom 0 = "0" +showAtom a = + let mTerm = do + t <- fromNoun (Atom a) + let ok = \x -> (x=='-' || C.isAlphaNum x) + guard (all ok (t :: Text)) + pure ("%" <> unpack t) + + in case mTerm of + Nothing -> show a + Just st -> st + +showNoun :: Noun -> String +showNoun = \case + Atom a -> showAtom a + Cell x y -> fmtCell (showNoun <$> (x : toTuple y)) + where + fmtCell :: [String] -> String + fmtCell xs = "[" <> intercalate " " xs <> "]" + +pPrintAtom :: Atom -> IO () +pPrintAtom = putStrLn . pack . showAtom + +pPrintNoun :: Noun -> IO () +pPrintNoun = putStrLn . pack . showNoun diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index 0b1197f6a..f0e661345 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -4,37 +4,43 @@ module Vere.Http where import ClassyPrelude import Data.Noun +import Data.Noun.Atom +import Data.Noun.Poet import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Method as H data Header = Header Text Text - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic, ToNoun) type Method = H.StdMethod +instance ToNoun H.StdMethod where + toNoun = toNoun . Cord . encodeUtf8 . tshow + data Request = Request - { method :: Method - , url :: Text - , headerList :: [Header] - , body :: Maybe ByteString - } - deriving (Eq, Ord, Show) + { method :: Method + , url :: Text + , headerList :: [Header] + , body :: Maybe ByteString + } + deriving (Eq, Ord, Show, Generic, ToNoun) data ResponseHeader = ResponseHeader - { statusCode :: Int - , headers :: [Header] - } - deriving (Eq, Ord, Show) + { statusCode :: Word + , headers :: [Header] + } + deriving (Eq, Ord, Show, Generic, ToNoun) -data Event = Started ResponseHeader -- [%start hdr (unit octs) ?] - | Received ByteString -- [%continue [~ octs] %.n] - | Done -- [%continue ~ %.y] - | Canceled -- %cancel - | Failed Text -- %cancel - deriving (Eq, Ord, Show) +data Event + = Started ResponseHeader -- [%start hdr (unit octs) ?] + | Received ByteString -- [%continue [~ octs] %.n] + | Done -- [%continue ~ %.y] + | Canceled -- %cancel + | Failed Text -- %cancel + deriving (Eq, Ord, Show, Generic, ToNoun) convertHeaders :: [HT.Header] -> [Header] diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index 247b41670..34b610be1 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Client.hs @@ -7,11 +7,13 @@ module Vere.Http.Client where import ClassyPrelude import Vere.Http +import Data.Noun.Poet import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Client as H + -------------------------------------------------------------------------------- type ReqId = Word @@ -19,9 +21,9 @@ type ReqId = Word data Ev = Receive ReqId Event -- [%receive @ todo] data Eff - = NewReq ReqId Request -- [%request @ todo] - | CancelReq ReqId -- [%cancel-request @] - deriving (Eq, Ord, Show) + = NewReq ReqId Request -- [%request @ todo] + | CancelReq ReqId -- [%cancel-request @] + deriving (Eq, Ord, Show, Generic, ToNoun) data State = State { sManager :: H.Manager @@ -46,7 +48,7 @@ cvtReq r = cvtRespHeaders :: H.Response a -> ResponseHeader cvtRespHeaders resp = - ResponseHeader (HT.statusCode (H.responseStatus resp)) heads + ResponseHeader (fromIntegral $ HT.statusCode (H.responseStatus resp)) heads where heads = convertHeaders (H.responseHeaders resp) diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index bc1ccb82b..7e65bc7f8 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -5,6 +5,7 @@ module Vere.Http.Server where import ClassyPrelude import Vere.Http import Data.Noun.Atom +import Data.Noun.Poet import Control.Lens import Control.Concurrent (ThreadId, killThread, forkIO) @@ -20,22 +21,24 @@ type ServerId = Word type ConnectionId = Word type RequestId = Word +data Foo = A | B | C + data Eff = Eff ServerId ConnectionId RequestId ServerRequest - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic, ToNoun) -- | An http server effect is configuration, or it sends an outbound response data ServerRequest = SetConfig Config | Response Event - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic, ToNoun) data Config = Config - { secure :: Maybe (Key, Cert) - , proxy :: Bool - , log :: Bool - , redirect :: Bool - } - deriving (Eq, Ord, Show) + { secure :: Maybe (Key, Cert) + , proxy :: Bool + , log :: Bool + , redirect :: Bool + } + deriving (Eq, Ord, Show, Generic, ToNoun) -- Note: We need to parse PEM-encoded RSA private keys and cert or cert chain @@ -44,8 +47,8 @@ type Key = PEM type Cert = PEM data Wain = Wain [Text] -newtype PEM = PEM ByteString - deriving newtype (Eq, Ord, Show) +newtype PEM = PEM Cord + deriving newtype (Eq, Ord, Show, ToNoun) data ClientResponse = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString) @@ -86,7 +89,7 @@ startServer s c = do tls <- case (secure c) of Nothing -> error "no wai" Just (PEM key, PEM cert) -> - pure (W.tlsSettingsMemory cert key) + pure (W.tlsSettingsMemory (unCord cert) (unCord key)) -- we need to do the dance where we do the socket checking dance. or shove a -- socket into it. diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index ec2d33ee6..99bd277d5 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -13,17 +13,16 @@ import RIO (decodeUtf8Lenient) import qualified Vere.Http.Server as Server import qualified Vere.Http.Client as Client -data WTFIsThis - = WTFIsThis (Maybe Varience) Eff +-------------------------------------------------------------------------------- data Event - = BehnBorn - | HttpBorn - | CttpBorn - deriving (Eq, Ord, Show) + = BehnBorn + | HttpBorn + | CttpBorn + deriving (Eq, Ord, Show, Generic, ToNoun) data PutDel = Put | Del - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic, ToNoun) instance FromNoun PutDel where parseNoun n = do @@ -33,22 +32,19 @@ instance FromNoun PutDel where Cord cord -> fail ("Invalid turf operation: " <> show cord) data Eff - = HttpServer Server.Eff - | HttpClient Client.Eff - | Behn Void - | Clay Void - | Boat Void - | Sync Void - | Newt Void - | Ames Void - | Init Void - | Term Void - | Hill [Term] - | Turf (Maybe (PutDel, [Text])) -- TODO Unsure - deriving (Eq, Ord, Show) - -instance ToNoun Eff where - toNoun = const (Atom 0) + = HttpServer Server.Eff + | HttpClient Client.Eff + | Behn Void + | Clay Void + | Boat Void + | Sync Void + | Newt Void + | Ames Void + | Init Void + | Term Void + | Hill [Term] + | Turf (Maybe (PutDel, [Text])) -- TODO Unsure + deriving (Eq, Ord, Show, Generic, ToNoun) instance FromNoun Eff where parseNoun = \case @@ -65,45 +61,6 @@ instance FromNoun Eff where Cord nm -> do fail ("Eff: unknown effect " <> unpack (decodeUtf8Lenient nm)) --------------------------------------------------------------------------------- - -instance ToNoun Text where -- XX op args)TODO - toNoun t = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Text where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (decodeUtf8Lenient c) - - --------------------------------------------------------------------------------- - -newtype Term = MkTerm Text - deriving newtype (Eq, Ord, Show) - -instance ToNoun Term where -- XX TODO - toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Term where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (MkTerm (decodeUtf8Lenient c)) - --------------------------------------------------------------------------------- - -newtype Knot = MkKnot Text - deriving newtype (Eq, Ord, Show) - -instance ToNoun Knot where -- XX TODO - toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Knot where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (MkKnot (decodeUtf8Lenient c)) - --------------------------------------------------------------------------------- - data Varience = Gold | Iron | Lead type Perform = Eff -> IO () @@ -112,7 +69,7 @@ newtype Path = Path [Knot] deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) data Ovum = Ovum Path Event - deriving (Eq, Ord, Show, ToNoun, FromNoun) + deriving (Eq, Ord, Show, Generic, ToNoun) newtype Mug = Mug Word32 deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index dd77a23b6..b1b382778 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -166,7 +166,7 @@ sendAndRecv :: Serf -> EventId -> Atom -> IO SerfResp sendAndRecv w eventId event = do traceM ("sendAndRecv: " <> show eventId) - traceM (show (cue event)) + traceM (maybe "bad cue" showNoun $ cue event) sendAtom w $ work eventId (Jam event) res <- loop traceM ("sendAndRecv.done " <> show res) diff --git a/pkg/urbit/vere/reck.c b/pkg/urbit/vere/reck.c index 74556acd6..661dc53fc 100644 --- a/pkg/urbit/vere/reck.c +++ b/pkg/urbit/vere/reck.c @@ -420,18 +420,7 @@ u3_reck_kick(u3_pier* pir_u, u3_noun ovo) if ( (c3n == _reck_kick_spec(pir_u, u3k(u3h(ovo)), u3k(u3t(ovo)))) && (c3n == _reck_kick_norm(pir_u, u3k(u3h(ovo)), u3k(u3t(ovo)))) ) { -#if 0 - if ( (c3__warn != u3h(u3t(ovo))) && - (c3__text != u3h(u3t(ovo))) && - (c3__note != u3h(u3t(ovo))) ) -#endif -#if 1 if ( (c3__crud == u3h(u3t(ovo))) ) -#if 0 - (c3__talk == u3h(u3t(ovo))) || - (c3__helo == u3h(u3t(ovo))) || - (c3__init == u3h(u3t(ovo))) ) -#endif { u3_pier_work(pir_u, u3nt(u3_blip, c3__term, u3_nul), @@ -443,13 +432,7 @@ u3_reck_kick(u3_pier* pir_u, u3_noun ovo) u3r_string(u3h(u3t(ovo))), u3r_string(tox)); u3z(tox); -#if 0 - if ( c3__hear == u3h(u3t(ovo)) ) { - c3_assert(0); - } -#endif } -#endif } u3z(ovo); } From c95d45198b64d78de02a8c069a7bcbab311f4250 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 26 Jun 2019 14:13:25 -0700 Subject: [PATCH 078/431] Generate ToNoun instances for enum-shaped types. --- pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs | 202 ++++++++++++++++++++++++++ pkg/hs-urbit/lib/Vere/Pier/Types.hs | 23 ++- pkg/hs-urbit/package.yaml | 1 + 3 files changed, 218 insertions(+), 8 deletions(-) create mode 100644 pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs new file mode 100644 index 000000000..bca35f7f3 --- /dev/null +++ b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs @@ -0,0 +1,202 @@ +{- + Generate FromNoun and ToNoun instances +-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} + +module Data.Noun.Poet.TH where + +import ClassyPrelude hiding (fromList) +import Control.Lens +import Data.Noun.Poet hiding (hsToHoon) + +import Data.Noun +import Data.Noun.Atom +import Data.Noun.Pill +import Data.Void +import Data.Word +import GHC.Natural +import GHC.Generics hiding (from) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import qualified Prelude as P +import qualified GHC.Generics as GHC + +import Data.Typeable (Typeable) +import RIO (decodeUtf8Lenient) + +import qualified Data.Char as C +import qualified Control.Monad.Fail as Fail + + +data Foo = Foo Int | Bar Int + + +-- Types For Hoon Constructs --------------------------------------------------- + +-- data Deriving = Deriving { tyCon :: Name, tyVar :: Name } + +data Shape + = Tup Name Con + | Enu Name [Name] + | Sum Name [Con] + deriving (Eq, Ord, Show) + +nameStr :: Name -> String +nameStr (Name (OccName n) _) = n + +typeShape :: Name -> Q Shape +typeShape tyName = do + (tyConName, tyVars, cs) <- reify tyName >>= \case + TyConI (DataD _ nm tyVars _ cs _) -> pure (nm, tyVars, cs) + TyConI (NewtypeD _ nm tyVars _ c _) -> pure (nm, tyVars, [c]) + TyConI _ -> fail badSynonym + _ -> fail "not type" + + allEmpty <- all id <$> (traverse emptyCon cs) + + if allEmpty + then do + conNames :: [Name] <- traverse conName' cs + pure (Enu tyConName conNames) + else + case cs of + [] -> pure $ Enu tyConName [] + [c] -> pure $ Tup tyConName c + cs -> pure $ Sum tyConName cs + + where + badSynonym = "deriveFunctor: tyCon may not be a type synonym." + +conName' :: Con -> Q Name +conName' = \case + NormalC nm bangType -> pure nm + RecC nm varBangTypes -> pure nm + InfixC bangType1 nm bangType2 -> fail "Infix constructors are not supported" + ForallC tyVarBndrs ctx con -> fail "Polymorphic types are not supported" + GadtC nm bangTypes ty -> fail "GADTs are not supported" + RecGadtC nm varBangTypes ty -> fail "GADTs are not supported" + +emptyCon :: Con -> Q Bool +emptyCon = \case + NormalC nm bangType -> pure (null bangType) + RecC nm varBangTypes -> pure (null varBangTypes) + InfixC bangType1 nm bangType2 -> fail "Infix constructors are not supported" + ForallC tyVarBndrs ctx con -> fail "Polymorphic types are not supported" + GadtC nm bangTypes ty -> fail "GADTs are not supported" + RecGadtC nm varBangTypes ty -> fail "GADTs are not supported" + + +deriveNoun :: Name -> Q [Dec] +deriveNoun tyName = do + (<>) <$> deriveToNoun tyName <*> deriveFromNoun tyName + +deriveToNoun :: Name -> Q [Dec] +deriveToNoun tyName = do + let t = conT tyName + + shape <- typeShape tyName + + traceM (show shape) + + body <- case shape of + Tup nm con -> pure [| \_ -> Atom 0 |] + Enu nm cons -> enumToAtom cons + Sum nm cons -> pure [| \_ -> Atom 0 |] + + [d| + instance ToNoun $t where + toNoun = $body + |] + +enumToAtom :: [Name] -> Q ExpQ +enumToAtom cons = do + matches <- traverse mkMatch cons + pure (pure (LamCaseE matches)) + where + mkMatch :: Name -> Q Match + mkMatch nm = pure $ Match (ConP nm []) (NormalB body) [] + where + body = AppE (VarE 'toNoun) $ AppE (ConE 'Cord) strLit + strLit = LitE $ StringL $ unpack $ hsToHoon $ nameStr nm + +deriveFromNoun :: Name -> Q [Dec] +deriveFromNoun tyName = + [d| + instance FromNoun $t where + parseNoun = $body + |] + where + t = conT tyName + + body = [| \_ -> fail "unimplemented" |] + + +{- + (tyConName, tyVars, cs) <- reify tyName >>= \case + TyConI (DataD _ nm tyVars _ cs _) -> pure (nm, tyVars, cs) + TyConI (NewtypeD _ nm tyVars _ c _) -> pure (nm, tyVars, [c]) + TyConI _ -> fail badSynonym + _ -> fail "not type" + + let KindedTV tyVar StarT = P.last tyVars + + let instanceType = (conT ''ToNoun) + `appT` + varT (foldl' apply (conT tyConName) (P.init tyVars)) + + putQ $ Deriving tyConName tyVar + sequence [instanceD (pure []) instanceType [genToNoun cs]] +-} + +{- + apply t (PlainTV name) = appT t (varT name) + apply t (KindedTV name _) = appT t (varT name) + + badSynonym = "deriveFunctor: tyCon may not be a type synonym." + + genToNoun :: [Con] -> DecQ + genToNoun cons = funD 'toNoun (genToNounClause <$> cons) + + genToNounClause :: Con -> Q Clause + genToNounClause c@(NormalC name fieldTypes) = do + f <- newName "f" + fieldNames <- replicateM (length fieldTypes) (newName "x") + + let pats = varP f:[conP name (map varP fieldNames)] + body = normalB $ appsE $ + conE name : map (newField f) (zip fieldNames fieldTypes) + + clause pats body [] + genToNounClause _ = fail "wut" +-} + +{- +newField :: Name -> (Name, StrictType) -> Q Exp +newField f (x, (_, fieldType)) = do + Just (Deriving typeCon typeVar) <- getQ + case fieldType of + VarT typeVar' | typeVar' == typeVar -> + [| $(varE f) $(varE x) |] + ty `AppT` VarT typeVar' | + leftmost ty == (ConT typeCon) && typeVar' == typeVar -> + [| fmap $(varE f) $(varE x) |] + _ -> [| $(varE x) |] + +leftmost :: Type -> Type +leftmost (AppT ty1 _) = leftmost ty1 +leftmost ty = ty +-} + +hsToHoon :: String -> Text +hsToHoon = go [] + where + go acc [] = pack $ intercalate "-" $ reverse acc + go acc (c:cs) = go (elem:acc) remain + where + head = C.toLower c + (tail, remain) = break C.isUpper cs + elem = head:tail diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 99bd277d5..76a1c7bbe 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -5,6 +5,7 @@ import Data.Void import Data.Noun import Data.Noun.Atom import Data.Noun.Poet +import Data.Noun.Poet.TH import Database.LMDB.Raw import Urbit.Time @@ -19,17 +20,23 @@ data Event = BehnBorn | HttpBorn | CttpBorn - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) + +deriveNoun ''Event data PutDel = Put | Del - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) -instance FromNoun PutDel where - parseNoun n = do - parseNoun n >>= \case - Cord "put" -> pure Put - Cord "del" -> pure Del - Cord cord -> fail ("Invalid turf operation: " <> show cord) +deriveNoun ''PutDel + +{- + instance FromNoun PutDel where + parseNoun n = do + parseNoun n >>= \case + Cord "put" -> pure Put + Cord "del" -> pure Del + Cord cord -> fail ("Invalid turf operation: " <> show cord) +-} data Eff = HttpServer Server.Eff diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 9328701cf..00b78c23d 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -45,6 +45,7 @@ dependencies: - tasty - tasty-quickcheck - tasty-th + - template-haskell - text - these - time From 798178d10c54db9e2fdbcd977dff9ef9d4aa304f Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 26 Jun 2019 15:51:30 -0700 Subject: [PATCH 079/431] Finished generating ToNoun instances. --- pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs | 210 ++++++++++---------------- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 12 ++ pkg/hs-urbit/package.yaml | 6 +- 3 files changed, 92 insertions(+), 136 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs index bca35f7f3..47121f724 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs @@ -1,127 +1,80 @@ {- - Generate FromNoun and ToNoun instances + Generate FromNoun and ToNoun instances. -} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DefaultSignatures #-} - module Data.Noun.Poet.TH where import ClassyPrelude hiding (fromList) import Control.Lens import Data.Noun.Poet hiding (hsToHoon) -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Pill -import Data.Void -import Data.Word -import GHC.Natural -import GHC.Generics hiding (from) - import Language.Haskell.TH import Language.Haskell.TH.Syntax -import qualified Prelude as P -import qualified GHC.Generics as GHC - -import Data.Typeable (Typeable) -import RIO (decodeUtf8Lenient) - -import qualified Data.Char as C -import qualified Control.Monad.Fail as Fail +import qualified Data.Char as C -data Foo = Foo Int | Bar Int +-------------------------------------------------------------------------------- - --- Types For Hoon Constructs --------------------------------------------------- - --- data Deriving = Deriving { tyCon :: Name, tyVar :: Name } +type ConInfo = (Name, [Type]) data Shape - = Tup Name Con - | Enu Name [Name] - | Sum Name [Con] + = Tup ConInfo + | Enu [Name] + | Sum [ConInfo] deriving (Eq, Ord, Show) -nameStr :: Name -> String -nameStr (Name (OccName n) _) = n - typeShape :: Name -> Q Shape typeShape tyName = do - (tyConName, tyVars, cs) <- reify tyName >>= \case - TyConI (DataD _ nm tyVars _ cs _) -> pure (nm, tyVars, cs) - TyConI (NewtypeD _ nm tyVars _ c _) -> pure (nm, tyVars, [c]) - TyConI _ -> fail badSynonym - _ -> fail "not type" + cs <- reify tyName >>= \case + TyConI (DataD _ nm [] _ cs _) -> pure $ unpackCon <$> cs + TyConI (NewtypeD _ nm [] _ c _) -> pure $ [unpackCon c] + TyConI (DataD _ nm _ _ cs _) -> fail "Type variables are unsupported" + TyConI (NewtypeD _ nm _ _ c _) -> fail "Type variables are unsupported" + TyConI _ -> fail badSynonym + _ -> fail "not type" - allEmpty <- all id <$> (traverse emptyCon cs) + let allEmpty = all (null . snd) cs if allEmpty - then do - conNames :: [Name] <- traverse conName' cs - pure (Enu tyConName conNames) + then pure $ Enu $ fst <$> cs else case cs of - [] -> pure $ Enu tyConName [] - [c] -> pure $ Tup tyConName c - cs -> pure $ Sum tyConName cs + [] -> pure $ Enu [] + [c] -> pure $ Tup c + cs -> pure $ Sum cs where badSynonym = "deriveFunctor: tyCon may not be a type synonym." -conName' :: Con -> Q Name -conName' = \case - NormalC nm bangType -> pure nm - RecC nm varBangTypes -> pure nm - InfixC bangType1 nm bangType2 -> fail "Infix constructors are not supported" - ForallC tyVarBndrs ctx con -> fail "Polymorphic types are not supported" - GadtC nm bangTypes ty -> fail "GADTs are not supported" - RecGadtC nm varBangTypes ty -> fail "GADTs are not supported" - -emptyCon :: Con -> Q Bool -emptyCon = \case - NormalC nm bangType -> pure (null bangType) - RecC nm varBangTypes -> pure (null varBangTypes) - InfixC bangType1 nm bangType2 -> fail "Infix constructors are not supported" - ForallC tyVarBndrs ctx con -> fail "Polymorphic types are not supported" - GadtC nm bangTypes ty -> fail "GADTs are not supported" - RecGadtC nm varBangTypes ty -> fail "GADTs are not supported" + unpackCon :: Con -> ConInfo + unpackCon = \case + NormalC nm bangTypes -> (nm, snd <$> bangTypes) + RecC nm varBangTypes -> (nm, varBangTypes <&> (\(_, _, t) -> t)) + InfixC bangType1 nm bangType2 -> error "Infix Cnstrs are not supported" + ForallC tyVarBndrs ctx con -> error "Polymorphic tys are not supported" + GadtC nm bangTypes ty -> error "GADTs are not supported" + RecGadtC nm varBangTypes ty -> error "GADTs are not supported" +-------------------------------------------------------------------------------- deriveNoun :: Name -> Q [Dec] -deriveNoun tyName = do - (<>) <$> deriveToNoun tyName <*> deriveFromNoun tyName +deriveNoun n = (<>) <$> deriveToNoun n <*> deriveFromNoun n + +-------------------------------------------------------------------------------- deriveToNoun :: Name -> Q [Dec] deriveToNoun tyName = do - let t = conT tyName - - shape <- typeShape tyName - - traceM (show shape) - - body <- case shape of - Tup nm con -> pure [| \_ -> Atom 0 |] - Enu nm cons -> enumToAtom cons - Sum nm cons -> pure [| \_ -> Atom 0 |] + body <- typeShape tyName <&> \case Tup con -> tupToNoun con + Enu cons -> enumToAtom cons + Sum cons -> sumToNoun cons [d| - instance ToNoun $t where - toNoun = $body + instance ToNoun $(conT tyName) where + toNoun = $(pure body) |] -enumToAtom :: [Name] -> Q ExpQ -enumToAtom cons = do - matches <- traverse mkMatch cons - pure (pure (LamCaseE matches)) - where - mkMatch :: Name -> Q Match - mkMatch nm = pure $ Match (ConP nm []) (NormalB body) [] - where - body = AppE (VarE 'toNoun) $ AppE (ConE 'Cord) strLit - strLit = LitE $ StringL $ unpack $ hsToHoon $ nameStr nm +-------------------------------------------------------------------------------- deriveFromNoun :: Name -> Q [Dec] deriveFromNoun tyName = @@ -134,67 +87,56 @@ deriveFromNoun tyName = body = [| \_ -> fail "unimplemented" |] +-------------------------------------------------------------------------------- -{- - (tyConName, tyVars, cs) <- reify tyName >>= \case - TyConI (DataD _ nm tyVars _ cs _) -> pure (nm, tyVars, cs) - TyConI (NewtypeD _ nm tyVars _ c _) -> pure (nm, tyVars, [c]) - TyConI _ -> fail badSynonym - _ -> fail "not type" +tagNoun :: Name -> Exp +tagNoun = AppE (VarE 'toNoun) + . AppE (ConE 'Cord) + . LitE + . StringL + . hsToHoon + . nameStr + where + nameStr :: Name -> String + nameStr (Name (OccName n) _) = n - let KindedTV tyVar StarT = P.last tyVars +tagTup :: Name -> [Name] -> Exp +tagTup c args = AppE (VarE 'toNoun) $ TupE (tagNoun c : fmap VarE args) - let instanceType = (conT ''ToNoun) - `appT` - varT (foldl' apply (conT tyConName) (P.init tyVars)) +tup :: [Name] -> Exp +tup = AppE (VarE 'toNoun) . TupE . fmap VarE - putQ $ Deriving tyConName tyVar - sequence [instanceD (pure []) instanceType [genToNoun cs]] --} +-------------------------------------------------------------------------------- -{- - apply t (PlainTV name) = appT t (varT name) - apply t (KindedTV name _) = appT t (varT name) +enumToAtom :: [Name] -> Exp +enumToAtom cons = + LamCaseE $ cons <&> \nm -> + Match (ConP nm []) (NormalB $ tagNoun nm) [] - badSynonym = "deriveFunctor: tyCon may not be a type synonym." +tupToNoun :: ConInfo -> Exp +tupToNoun cons = LamCaseE [mkMatch cons] + where + mkMatch :: ConInfo -> Match + mkMatch (nm, tys) = Match (ConP nm params) (NormalB body) [] + where vars = (zip tys ['a'..]) <&> (mkName . singleton . snd) + params = VarP <$> vars + body = tup vars - genToNoun :: [Con] -> DecQ - genToNoun cons = funD 'toNoun (genToNounClause <$> cons) +sumToNoun :: [ConInfo] -> Exp +sumToNoun cons = LamCaseE (cons <&> mkMatch) + where + mkMatch :: ConInfo -> Match + mkMatch (nm, tys) = Match (ConP nm params) (NormalB body) [] + where vars = (zip tys ['a'..]) <&> (mkName . singleton . snd) + params = VarP <$> vars + body = tagTup nm vars - genToNounClause :: Con -> Q Clause - genToNounClause c@(NormalC name fieldTypes) = do - f <- newName "f" - fieldNames <- replicateM (length fieldTypes) (newName "x") +-------------------------------------------------------------------------------- - let pats = varP f:[conP name (map varP fieldNames)] - body = normalB $ appsE $ - conE name : map (newField f) (zip fieldNames fieldTypes) - - clause pats body [] - genToNounClause _ = fail "wut" --} - -{- -newField :: Name -> (Name, StrictType) -> Q Exp -newField f (x, (_, fieldType)) = do - Just (Deriving typeCon typeVar) <- getQ - case fieldType of - VarT typeVar' | typeVar' == typeVar -> - [| $(varE f) $(varE x) |] - ty `AppT` VarT typeVar' | - leftmost ty == (ConT typeCon) && typeVar' == typeVar -> - [| fmap $(varE f) $(varE x) |] - _ -> [| $(varE x) |] - -leftmost :: Type -> Type -leftmost (AppT ty1 _) = leftmost ty1 -leftmost ty = ty --} - -hsToHoon :: String -> Text +hsToHoon :: String -> String hsToHoon = go [] where - go acc [] = pack $ intercalate "-" $ reverse acc + go acc [] = intercalate "-" $ reverse acc go acc (c:cs) = go (elem:acc) remain where head = C.toLower c diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 76a1c7bbe..4c5ef2931 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -29,6 +29,18 @@ data PutDel = Put | Del deriveNoun ''PutDel +data EffBs + = EBAsdf Word + | EBLolr Word Word + +data RecEx = RE Word Word + +data NewtEx = NE Word + +deriveNoun ''EffBs +deriveNoun ''RecEx +deriveNoun ''NewtEx + {- instance FromNoun PutDel where parseNoun n = do diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 00b78c23d..61783ad6b 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -58,9 +58,10 @@ dependencies: default-extensions: - ApplicativeDo - - DataKinds - BangPatterns - BlockArguments + - DataKinds + - DefaultSignatures - DeriveAnyClass - DeriveDataTypeable - DeriveFoldable @@ -84,11 +85,12 @@ default-extensions: - Rank2Types - RankNTypes - RecordWildCards - - StandaloneDeriving - ScopedTypeVariables + - StandaloneDeriving - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies + - TypeOperators - UnicodeSyntax - ViewPatterns From f680e44ad580ec597aff85f204b7d39f48c229b4 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 26 Jun 2019 16:27:37 -0700 Subject: [PATCH 080/431] Generate FromNoun code for enum types. --- pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs | 48 ++++++++++++++++++++++----- 1 file changed, 40 insertions(+), 8 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs index 47121f724..82f2b9dfb 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs @@ -77,18 +77,50 @@ deriveToNoun tyName = do -------------------------------------------------------------------------------- deriveFromNoun :: Name -> Q [Dec] -deriveFromNoun tyName = - [d| - instance FromNoun $t where - parseNoun = $body - |] - where - t = conT tyName +deriveFromNoun tyName = do + body <- typeShape tyName <&> \case Tup con -> tupFromNoun con + Enu cons -> enumFromAtom cons + Sum cons -> sumFromNoun cons - body = [| \_ -> fail "unimplemented" |] + + [d| + instance FromNoun $(conT tyName) where + parseNoun = $(pure body) + |] + +enumFromAtom :: [Name] -> Exp +enumFromAtom nms = LamE [VarP n] body + where + n = mkName "n" + c = mkName "c" + getCord = BindS (VarP c) $ AppE (VarE 'parseNoun) (VarE n) + examine = NoBindS $ CaseE (VarE c) (matches ++ [fallback]) + matches = mkMatch <$> nms + fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) [] + body = DoE [getCord, examine] + matchFail = LitE $ StringL ("Expected one of: " <> possible) + possible = intercalate " " (('%':) . tagString <$> nms) + mkMatch n = Match (ConP 'Cord [LitP (tagLit n)]) + (NormalB $ AppE (VarE 'pure) (ConE n)) + [] + +tupFromNoun :: ConInfo -> Exp +tupFromNoun _ = VarE 'undefined + +sumFromNoun :: [ConInfo] -> Exp +sumFromNoun _ = VarE 'undefined -------------------------------------------------------------------------------- +tagString :: Name -> String +tagString = hsToHoon . nameStr + where + nameStr :: Name -> String + nameStr (Name (OccName n) _) = n + +tagLit :: Name -> Lit +tagLit = StringL . tagString + tagNoun :: Name -> Exp tagNoun = AppE (VarE 'toNoun) . AppE (ConE 'Cord) From 4a666d1aa6bb213892034a044562819098ab3110 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 26 Jun 2019 16:40:31 -0700 Subject: [PATCH 081/431] Generate FromNoun code for record types. --- pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs | 15 ++++++++++++--- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 11 ++--------- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs index 82f2b9dfb..20a7d710a 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs @@ -91,8 +91,7 @@ deriveFromNoun tyName = do enumFromAtom :: [Name] -> Exp enumFromAtom nms = LamE [VarP n] body where - n = mkName "n" - c = mkName "c" + (n, c) = (mkName "n", mkName "c") getCord = BindS (VarP c) $ AppE (VarE 'parseNoun) (VarE n) examine = NoBindS $ CaseE (VarE c) (matches ++ [fallback]) matches = mkMatch <$> nms @@ -104,8 +103,18 @@ enumFromAtom nms = LamE [VarP n] body (NormalB $ AppE (VarE 'pure) (ConE n)) [] +applyE :: Exp -> [Exp] -> Exp +applyE e [] = e +applyE e (a:as) = applyE (AppE e a) as + tupFromNoun :: ConInfo -> Exp -tupFromNoun _ = VarE 'undefined +tupFromNoun (n, tys) = LamE [VarP x] body + where + x = mkName "x" + vars = mkName . singleton . fst <$> zip ['a'..] tys + body = DoE [getTup, convert] + convert = NoBindS $ AppE (VarE 'pure) $ applyE (ConE n) (VarE <$> vars) + getTup = BindS (TupP $ VarP <$> vars) $ AppE (VarE 'parseNoun) (VarE x) sumFromNoun :: [ConInfo] -> Exp sumFromNoun _ = VarE 'undefined diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 4c5ef2931..6974f7d4f 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -34,22 +34,15 @@ data EffBs | EBLolr Word Word data RecEx = RE Word Word + deriving (Eq, Ord, Show) data NewtEx = NE Word + deriving (Eq, Ord, Show) deriveNoun ''EffBs deriveNoun ''RecEx deriveNoun ''NewtEx -{- - instance FromNoun PutDel where - parseNoun n = do - parseNoun n >>= \case - Cord "put" -> pure Put - Cord "del" -> pure Del - Cord cord -> fail ("Invalid turf operation: " <> show cord) --} - data Eff = HttpServer Server.Eff | HttpClient Client.Eff From 9999e5264a8166afb45bc3c56333a885c201b032 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 26 Jun 2019 17:58:55 -0700 Subject: [PATCH 082/431] Generate FromNoun code for sum types. --- pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs | 35 ++++++++++++++++++++++++--- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 8 +++--- 2 files changed, 35 insertions(+), 8 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs index 20a7d710a..a8a9fecbe 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs @@ -89,10 +89,10 @@ deriveFromNoun tyName = do |] enumFromAtom :: [Name] -> Exp -enumFromAtom nms = LamE [VarP n] body +enumFromAtom nms = LamE [VarP x] body where - (n, c) = (mkName "n", mkName "c") - getCord = BindS (VarP c) $ AppE (VarE 'parseNoun) (VarE n) + (x, c) = (mkName "x", mkName "c") + getCord = BindS (VarP c) $ AppE (VarE 'parseNoun) (VarE x) examine = NoBindS $ CaseE (VarE c) (matches ++ [fallback]) matches = mkMatch <$> nms fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) [] @@ -116,8 +116,35 @@ tupFromNoun (n, tys) = LamE [VarP x] body convert = NoBindS $ AppE (VarE 'pure) $ applyE (ConE n) (VarE <$> vars) getTup = BindS (TupP $ VarP <$> vars) $ AppE (VarE 'parseNoun) (VarE x) +{- +unexpectedTag :: [Name] -> String -> String +unexpectedTag expected got = + mconcat ["Expected one of: ", possible, " but got " <> showAtom + where + possible = intercalate " " (('%':) . tagString <$> expected) +-} + sumFromNoun :: [ConInfo] -> Exp -sumFromNoun _ = VarE 'undefined +sumFromNoun cons = LamE [VarP x] (DoE [getHead, getTag, examine]) + where + (x, h, t, c) = (mkName "x", mkName "h", mkName "t", mkName "c") + + getHead = BindS (TupP [VarP h, VarP t]) + $ AppE (VarE 'parseNoun) (VarE x) + + getTag = BindS (ConP 'Cord [VarP c]) + $ AppE (VarE 'parseNoun) (VarE h) + + examine = NoBindS + $ CaseE (VarE c) (matches ++ [fallback]) + + matches = mkMatch <$> cons + mkMatch = \(n, tys) -> let body = AppE (tupFromNoun (n, tys)) (VarE t) + in Match (LitP $ tagLit n) (NormalB body) [] + + fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) [] + matchFail = LitE $ StringL ("Expected one of: " <> possible) + possible = intercalate " " (('%':) . tagString . fst <$> cons) -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 6974f7d4f..3fb0e9ce4 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -22,16 +22,13 @@ data Event | CttpBorn deriving (Eq, Ord, Show) -deriveNoun ''Event - data PutDel = Put | Del deriving (Eq, Ord, Show) -deriveNoun ''PutDel - data EffBs = EBAsdf Word | EBLolr Word Word + deriving (Eq, Ord, Show) data RecEx = RE Word Word deriving (Eq, Ord, Show) @@ -39,6 +36,9 @@ data RecEx = RE Word Word data NewtEx = NE Word deriving (Eq, Ord, Show) + +deriveNoun ''Event +deriveNoun ''PutDel deriveNoun ''EffBs deriveNoun ''RecEx deriveNoun ''NewtEx From fc65176ca41c7204d105d7fea2de8bb275deae77 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 27 Jun 2019 14:28:58 -0700 Subject: [PATCH 083/431] Fix segfault and handle more effects. --- pkg/hs-urbit/lib/Data/Noun/Pill.hs | 9 +++-- pkg/hs-urbit/lib/Data/Noun/Poet.hs | 34 ++++++++++++++++-- pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs | 16 +++++---- pkg/hs-urbit/lib/Vere/Http.hs | 32 +++++++++++++---- pkg/hs-urbit/lib/Vere/Http/Client.hs | 11 ++++-- pkg/hs-urbit/lib/Vere/Http/Server.hs | 17 +++++---- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 50 +++++++++++++-------------- pkg/hs-urbit/lib/Vere/Serf.hs | 11 ++---- 8 files changed, 119 insertions(+), 61 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Pill.hs b/pkg/hs-urbit/lib/Data/Noun/Pill.hs index 20e4dd77b..b85a9906f 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Pill.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Pill.hs @@ -158,9 +158,12 @@ bytesBS = iso to from where to :: VP.Vector Word8 -> ByteString to (VP.Vector off sz buf) = - BS.copy $ BS.drop off $ unsafePerformIO $ BU.unsafePackAddressLen sz ptr - where - Prim.Addr ptr = Prim.byteArrayContents buf + -- TODO This still has a (small) risk of segfaulting. is still Manually copy the data onto the C heap, setup the + -- finalizers, and make a bytestring from that. + unsafePerformIO $ do + Prim.Addr ptr <- evaluate $ Prim.byteArrayContents buf + bs <- BU.unsafePackAddressLen sz ptr + evaluate $ force $ BS.copy $ BS.drop off bs from :: ByteString -> VP.Vector Word8 from bs = VP.generate (length bs) (BS.index bs) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Data/Noun/Poet.hs index 8da625ee8..27e140c1a 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet.hs @@ -43,8 +43,17 @@ newtype Tape = Tape ByteString deriving newtype (Eq, Ord, Show, IsString) newtype Cord = Cord { unCord :: ByteString } - deriving newtype (Eq, Ord, Show, IsString) + deriving newtype (Eq, Ord, Show, IsString, NFData) +-- Chars ----------------------------------------------------------------------- + +instance ToNoun Char where + toNoun = toNoun . (fromIntegral :: Int -> Word32) . C.ord + +instance FromNoun Char where + parseNoun n = do + w :: Word32 <- parseNoun n + pure $ C.chr $ fromIntegral w -- Pretty Printing ------------------------------------------------------------- @@ -282,6 +291,9 @@ consName = gConsName . GHC.from int2Word :: Int -> Word int2Word = fromIntegral +word2Int :: Word -> Int +word2Int = fromIntegral + instance ToNoun ByteString where toNoun bs = toNoun (int2Word (length bs), bs ^. from (pill . pillBS)) @@ -293,6 +305,14 @@ instance FromNoun Text where -- XX TODO Cord c <- parseNoun n pure (decodeUtf8Lenient c) +instance FromNoun ByteString where + parseNoun x = do + (word2Int -> len, atom) <- parseNoun x + let bs = atom ^. pill . pillBS + pure $ case compare (length bs) len of + EQ -> bs + LT -> bs <> replicate (len - length bs) 0 + GT -> take len bs -------------------------------------------------------------------------------- @@ -460,7 +480,10 @@ instance ToNoun Cord where instance FromNoun Cord where parseNoun n = do atom <- parseNoun n - pure $ Cord (atom ^. pill . pillBS) + traceM "Parsing cord" + let res@(Cord _) = force $ Cord (atom ^. pill . pillBS) + traceM "Done parsing cord" + pure res -- Tank and Plum Conversion ---------------------------------------------------- @@ -492,6 +515,13 @@ instance FromNoun Tank where -- Pair Conversion ------------------------------------------------------------- +instance ToNoun () where + toNoun () = Atom 0 + +instance FromNoun () where + parseNoun (Atom 0) = pure () + parseNoun x = fail ("expecting `~`, but got " <> showNoun x) + instance (ToNoun a, ToNoun b) => ToNoun (a, b) where toNoun (x, y) = Cell (toNoun x) (toNoun y) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs index a8a9fecbe..38576d43d 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs @@ -7,10 +7,11 @@ module Data.Noun.Poet.TH where import ClassyPrelude hiding (fromList) import Control.Lens import Data.Noun.Poet hiding (hsToHoon) - import Language.Haskell.TH import Language.Haskell.TH.Syntax +import RIO (decodeUtf8Lenient) + import qualified Data.Char as C @@ -116,13 +117,12 @@ tupFromNoun (n, tys) = LamE [VarP x] body convert = NoBindS $ AppE (VarE 'pure) $ applyE (ConE n) (VarE <$> vars) getTup = BindS (TupP $ VarP <$> vars) $ AppE (VarE 'parseNoun) (VarE x) -{- -unexpectedTag :: [Name] -> String -> String +unexpectedTag :: [Name] -> Exp -> Exp unexpectedTag expected got = - mconcat ["Expected one of: ", possible, " but got " <> showAtom + applyE (VarE 'mappend) [LitE (StringL prefix), got] where possible = intercalate " " (('%':) . tagString <$> expected) --} + prefix = "Expected one of: " <> possible <> " but got %" sumFromNoun :: [ConInfo] -> Exp sumFromNoun cons = LamE [VarP x] (DoE [getHead, getTag, examine]) @@ -143,8 +143,10 @@ sumFromNoun cons = LamE [VarP x] (DoE [getHead, getTag, examine]) in Match (LitP $ tagLit n) (NormalB body) [] fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) [] - matchFail = LitE $ StringL ("Expected one of: " <> possible) - possible = intercalate " " (('%':) . tagString . fst <$> cons) + matchFail = unexpectedTag (fst <$> cons) + $ AppE (VarE 'unpack) + $ AppE (VarE 'decodeUtf8Lenient) + $ VarE c -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index f0e661345..4fe12d334 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -6,32 +6,32 @@ import ClassyPrelude import Data.Noun import Data.Noun.Atom import Data.Noun.Poet +import Data.Noun.Poet.TH import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Method as H +-------------------------------------------------------------------------------- + data Header = Header Text Text - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) type Method = H.StdMethod -instance ToNoun H.StdMethod where - toNoun = toNoun . Cord . encodeUtf8 . tshow - data Request = Request { method :: Method , url :: Text , headerList :: [Header] , body :: Maybe ByteString } - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) data ResponseHeader = ResponseHeader { statusCode :: Word , headers :: [Header] } - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) data Event @@ -40,8 +40,26 @@ data Event | Done -- [%continue ~ %.y] | Canceled -- %cancel | Failed Text -- %cancel - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) +-------------------------------------------------------------------------------- + +instance ToNoun H.StdMethod where + toNoun = toNoun . Cord . H.renderStdMethod + +instance FromNoun H.StdMethod where + parseNoun n = do + Cord m <- parseNoun n + case H.parseMethod m of + Left bs -> fail ("Unexpected method: " <> unpack (decodeUtf8 bs)) + Right m -> pure m + +deriveNoun ''Header +deriveNoun ''ResponseHeader +deriveNoun ''Event +deriveNoun ''Request + +-------------------------------------------------------------------------------- convertHeaders :: [HT.Header] -> [Header] convertHeaders = fmap f diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index 34b610be1..44b553a91 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Client.hs @@ -8,13 +8,14 @@ module Vere.Http.Client where import ClassyPrelude import Vere.Http import Data.Noun.Poet +import Data.Noun.Poet.TH import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Client as H --------------------------------------------------------------------------------- +-- Types ----------------------------------------------------------------------- type ReqId = Word @@ -23,7 +24,7 @@ data Ev = Receive ReqId Event -- [%receive @ todo] data Eff = NewReq ReqId Request -- [%request @ todo] | CancelReq ReqId -- [%cancel-request @] - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) data State = State { sManager :: H.Manager @@ -31,6 +32,12 @@ data State = State , sChan :: MVar Ev } + +-- Instances ------------------------------------------------------------------- + +deriveNoun ''Eff + + -------------------------------------------------------------------------------- cvtReq :: Request -> Maybe H.Request diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index 7e65bc7f8..c47bfe63b 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -6,6 +6,7 @@ import ClassyPrelude import Vere.Http import Data.Noun.Atom import Data.Noun.Poet +import Data.Noun.Poet.TH import Control.Lens import Control.Concurrent (ThreadId, killThread, forkIO) @@ -24,13 +25,13 @@ type RequestId = Word data Foo = A | B | C data Eff = Eff ServerId ConnectionId RequestId ServerRequest - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) -- | An http server effect is configuration, or it sends an outbound response data ServerRequest = SetConfig Config | Response Event - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) data Config = Config { secure :: Maybe (Key, Cert) @@ -38,17 +39,21 @@ data Config = Config , log :: Bool , redirect :: Bool } - deriving (Eq, Ord, Show, Generic, ToNoun) - + deriving (Eq, Ord, Show) -- Note: We need to parse PEM-encoded RSA private keys and cert or cert chain -- from Wain type Key = PEM type Cert = PEM -data Wain = Wain [Text] +newtype Wain = Wain [Text] + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) newtype PEM = PEM Cord - deriving newtype (Eq, Ord, Show, ToNoun) + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) + +deriveNoun ''ServerRequest +deriveNoun ''Config +deriveNoun ''Eff data ClientResponse = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString) diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 3fb0e9ce4..469fd2671 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -11,8 +11,8 @@ import Urbit.Time import RIO (decodeUtf8Lenient) -import qualified Vere.Http.Server as Server import qualified Vere.Http.Client as Client +import qualified Vere.Http.Server as Server -------------------------------------------------------------------------------- @@ -36,13 +36,6 @@ data RecEx = RE Word Word data NewtEx = NE Word deriving (Eq, Ord, Show) - -deriveNoun ''Event -deriveNoun ''PutDel -deriveNoun ''EffBs -deriveNoun ''RecEx -deriveNoun ''NewtEx - data Eff = HttpServer Server.Eff | HttpClient Client.Eff @@ -54,32 +47,37 @@ data Eff | Ames Void | Init Void | Term Void + | Blit [Blit] | Hill [Term] | Turf (Maybe (PutDel, [Text])) -- TODO Unsure - deriving (Eq, Ord, Show, Generic, ToNoun) + deriving (Eq, Ord, Show) -instance FromNoun Eff where - parseNoun = \case - Atom _ -> - fail "Eff: Expecting cell, but got an atom" - Cell h t -> - parseNoun h >>= \case - Cord "hill" -> do - paths <- parseNoun t - pure (Hill paths) - Cord "turf" -> do - arg <- parseNoun t - pure (Turf arg) - Cord nm -> do - fail ("Eff: unknown effect " <> unpack (decodeUtf8Lenient nm)) +newtype Path = Path [Knot] + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) + +data Blit + = Bel + | Clr + | Hop Word64 + | Lin [Char] + | Mor + | Sag Path Noun + | Sav Path Atom + | Url Text + deriving (Eq, Ord, Show) + +deriveNoun ''Blit +deriveNoun ''Eff +deriveNoun ''Event +deriveNoun ''PutDel +deriveNoun ''EffBs +deriveNoun ''RecEx +deriveNoun ''NewtEx data Varience = Gold | Iron | Lead type Perform = Eff -> IO () -newtype Path = Path [Knot] - deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) - data Ovum = Ovum Path Event deriving (Eq, Ord, Show, Generic, ToNoun) diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index b1b382778..e87164480 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -89,24 +89,19 @@ type Play = Maybe (EventId, Mug, ShipId) data Plea = Play Play | Work EventId Mug Job - | Done EventId Mug [Either Text (Path, Eff)] + | Done EventId Mug [(Path, Eff)] | Stdr EventId Cord | Slog EventId Word32 Tank deriving (Eq, Show) -fromRight (Right x) = x - instance ToNoun Plea where toNoun = \case Play p -> toNoun (Cord "play", p) Work i m j -> toNoun (Cord "work", i, m, j) - Done i m o -> toNoun (Cord "done", i, m, fromRight <$> o) + Done i m o -> toNoun (Cord "done", i, m, o) Stdr i msg -> toNoun (Cord "stdr", i, msg) Slog i p t -> toNoun (Cord "slog", i, p, t) -instance FromNoun (Either Text (Path, Eff)) where - parseNoun = pure . fromNounErr - instance FromNoun Plea where parseNoun n = parseNoun n >>= \case @@ -125,7 +120,7 @@ type NextEventId = Word64 type SerfState = (EventId, Mug) type ReplacementEv = (EventId, Mug, Job) -type WorkResult = (EventId, Mug, [Either Text (Path, Eff)]) +type WorkResult = (EventId, Mug, [(Path, Eff)]) type SerfResp = (Either ReplacementEv WorkResult) -- Exceptions ------------------------------------------------------------------ From d62ef3cdfe625f4f5c9110f451a889923d002c7d Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 28 Jun 2019 18:46:33 -0700 Subject: [PATCH 084/431] Write high-performance serialization utils for Jam. --- pkg/hs-urbit/lib/Data/Noun/Jam.hs | 2 - pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs | 236 ++--------------------- pkg/hs-urbit/lib/Data/Noun/Jam/Get.hs | 220 ++++++++++++++++++++++ pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 248 +++++++++++++++++++++++++ pkg/hs-urbit/lib/Data/Noun/Pill.hs | 10 +- pkg/hs-urbit/lib/Data/Noun/Poet.hs | 49 ++++- pkg/hs-urbit/lib/Vere/Log.hs | 24 ++- pkg/hs-urbit/lib/Vere/Pier.hs | 35 ++++ pkg/hs-urbit/lib/Vere/Pier/Types.hs | 27 +-- 9 files changed, 602 insertions(+), 249 deletions(-) create mode 100644 pkg/hs-urbit/lib/Data/Noun/Jam/Get.hs create mode 100644 pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam.hs b/pkg/hs-urbit/lib/Data/Noun/Jam.hs index 803f37a3f..adf6ffda7 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam.hs @@ -150,8 +150,6 @@ jam = toAtom . fst . go 0 mempty where (Buf lSz lRes, lTbl) = go (off+2) tbl lef (Buf rSz rRes, rTbl) = go (off+lSz) lTbl rit - - leadingZeros :: Cursor -> Maybe Int leadingZeros (Cursor idx buf) = go 0 where wid = bitWidth buf diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs index 9ac77c498..fa71373a3 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs @@ -14,6 +14,7 @@ import GHC.Word import GHC.Natural import Foreign.Ptr import Foreign.Storable (peek) +import Data.Noun.Jam.Get import Data.Map (Map) import Control.Monad (guard) @@ -25,21 +26,8 @@ import Test.QuickCheck hiding ((.&.)) import qualified Data.HashTable.IO as H --- Pre-Calculate the bit-width of `jam` ---------------------------------------- -matSz# :: Atom -> Word# -matSz# 0 = 1## -matSz# a = preW `plusWord#` preW `plusWord#` atmW - where - atmW = atomBitWidth# a - preW = wordBitWidth# atmW - -refSz# :: Word# -> Word# -refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) - -nounSz# :: Noun -> Word# -nounSz# (Atom a) = 1## `plusWord#` (matSz# a) -nounSz# (Cell l r) = 2## `plusWord#` (nounSz# l) `plusWord#` (nounSz# r) +-- Pre-compute the bit-width of a jammed noun. --------------------------------- jamSz :: Noun -> Word jamSz = fst . go 0 mempty @@ -71,218 +59,30 @@ jamSz = fst . go 0 mempty Cell _ _ -> (refSz, oldTbl) --- How to write a faster `cue`? ------------------------------------------------ + matSz# :: Atom -> Word# + matSz# 0 = 1## + matSz# a = preW `plusWord#` preW `plusWord#` atmW + where + atmW = atomBitWidth# a + preW = wordBitWidth# atmW -{-| - The decoder state. + refSz# :: Word# -> Word# + refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) - - An array of words (internal structure of our atoms). - - A pointer to the word *after* the last word in the array. - - A pointer into the current word of that array. - - A bit-offset into that word. --} -data S = S - { currPtr :: {-# UNPACK #-} !(Ptr Word) - , usedBits :: {-# UNPACK #-} !Word - , pos :: {-# UNPACK #-} !Word - } deriving (Show,Eq,Ord) + nounSz# :: Noun -> Word# + nounSz# (Atom a) = 1## `plusWord#` (matSz# a) + nounSz# (Cell l r) = 2## `plusWord#` (nounSz# l) `plusWord#` (nounSz# r) -------------------------------------------------------------------------------- -type Env = (Ptr Word, S) - -data DecodeException = NotEnoughSpace Env - | TooMuchSpace Env - | BadEncoding Env String - deriving (Show, Eq, Ord) - -instance Exception DecodeException - -badEncoding :: Ptr Word -> S -> String -> IO a -badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg - --- The Get Monad --------------------------------------------------------------- - -data GetResult a = GetResult {-# UNPACK #-} !S !a - deriving Functor - -newtype Get a = Get - { runGet :: Ptr Word - -> H.LinearHashTable Word Noun - -> S - -> IO (GetResult a) - } - -instance Functor Get where - fmap f g = Get $ \end tbl s -> do - GetResult s' a <- runGet g end tbl s - return $ GetResult s' (f a) - {-# INLINE fmap #-} - -instance Applicative Get where - pure x = Get (\_ _ s -> return $ GetResult s x) - {-# INLINE pure #-} - - Get f <*> Get g = Get $ \end tbl s1 -> do - GetResult s2 f' <- f end tbl s1 - GetResult s3 g' <- g end tbl s2 - return $ GetResult s3 (f' g') - {-# INLINE (<*>) #-} - - Get f *> Get g = Get $ \end tbl s1 -> do - GetResult s2 _ <- f end tbl s1 - g end tbl s2 - {-# INLINE (*>) #-} - -instance Monad Get where - return = pure - {-# INLINE return #-} - - (>>) = (*>) - {-# INLINE (>>) #-} - - Get x >>= f = Get $ \end tbl s -> do - GetResult s' x' <- x end tbl s - runGet (f x') end tbl s' - {-# INLINE (>>=) #-} - - fail msg = Get $ \end tbl s -> - badEncoding end s msg - {-# INLINE fail #-} - --------------------------------------------------------------------------------- - -type Bits = Vector Bool - -getPos :: Get Word -getPos = Get $ \_ _ s -> - pure (GetResult s (pos s)) - -insRef :: Word -> Noun -> Get () -insRef pos now = Get \_ tbl s -> do - H.insert tbl pos now - pure $ GetResult s () - -getRef :: Word -> Get Noun -getRef ref = Get \_ tbl s -> do - H.lookup tbl ref >>= \case - Nothing -> fail "Invalid Reference" - Just no -> pure (GetResult s no) - -advance :: Word -> Get () -advance n = Get \_ _ s -> do - let newUsed = n + usedBits s - newS = s { pos = pos s + n - , usedBits = newUsed `mod` 64 - , currPtr = plusPtr (currPtr s) - (fromIntegral $ newUsed `div` 64) - } - - pure (GetResult newS ()) - --------------------------------------------------------------------------------- - --- TODO Should this be (>= end) or (> end)? -peekCurWord :: Get Word -peekCurWord = Get \end _ s -> - if ptrToWordPtr (currPtr s) >= ptrToWordPtr end - then pure (GetResult s 0) - else GetResult s <$> peek (currPtr s) - --- TODO Same question as above. -peekNextWord :: Get Word -peekNextWord = Get \end _ s -> - if ptrToWordPtr (currPtr s) > ptrToWordPtr end - then pure (GetResult s 0) - else GetResult s <$> peek (currPtr s `plusPtr` 1) - -peekUsedBits :: Get Word -peekUsedBits = Get \_ _ s -> pure (GetResult s (usedBits s)) - -{-| - Get a bit. - - - Peek the current word. - - Right-shift by the bit-offset. - - Mask the high bits. --} -dBit :: Get Bool -dBit = do - wor <- peekCurWord - use <- fromIntegral <$> peekUsedBits - advance 1 - pure (0 /= shiftR wor use .&. 1) - -{-| - Get n bits, where n > 64: - - - Get (n/64) words. - - Advance by n bits. - - Calculate an offset (equal to the current bit-offset) - - Calculate the length (equal to n) - - Construct a bit-vector using the buffer*length*offset. --} -dBits :: Word -> Get Bits -dBits = undefined - -{-| - In order to peek at the next Word64: - - - If we are past the end of the buffer: - - Return zero. - - If the bit-offset is zero: - - Just peek. - - If we are pointing to the last word: - - Peek and right-shift by the bit offset. - - Otherwise, - - Peek the current word *and* the next word. - - Right-shift the current word by the bit-offset. - - Left-shift the next word by the bit-offset. - - Binary or the resulting two words. --} -peekWord :: Get Word -peekWord = do - off <- peekUsedBits - cur <- peekCurWord - if off == 0 then pure cur else - do - nex <- peekNextWord - advance 64 - pure (dropLowBits off cur .|. dropHighBits off nex) - -dropLowBits :: Word -> Word -> Word -dropLowBits bits wor = shiftR wor (fromIntegral bits :: Int) - -takeLowBits :: Word -> Word -> Word -takeLowBits 64 wor = wor -takeLowBits wid wor = (2^wid - 1) .&. wor - -takeHighBits :: Word -> Word -> Word -takeHighBits off wor = dropLowBits (64-off) wor - -dropHighBits :: Word -> Word -> Word -dropHighBits off wor = takeLowBits (64-off) wor - -{-| - Make a word from the next n bits (where n <= 64). - - - Peek at the next word. - - Mask the n lowest bits from the word. - - Advance by that number of bits. - - Return the word. --} -dWordBits :: Word -> Get Word -dWordBits n = do - w <- peekWord - advance n - pure (takeLowBits n w) - --------------------------------------------------------------------------------- +jamFast :: Noun -> Vector Word64 +jamFast n = undefined bitsToAtom :: Bits -> Atom bitsToAtom = undefined --------------------------------------------------------------------------------- + +-- Fast Cue -------------------------------------------------------------------- {- Get the exponent-prefix of an atom: @@ -340,7 +140,7 @@ dNoun = do True -> dRef >>= getRef {- - Count leading zero bits. + TODO Count leading zero bits. Read a 64 bit word from the buffer and get the number of leading zeros in that word. This works as long as no atom is larger than diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Get.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Get.hs new file mode 100644 index 000000000..c53874ba1 --- /dev/null +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Get.hs @@ -0,0 +1,220 @@ +module Data.Noun.Jam.Get where + +import ClassyPrelude + +import Data.Noun (Noun) +import Data.Bits (shiftR, (.|.), (.&.)) +import Foreign.Ptr (Ptr, plusPtr, ptrToWordPtr) +import Foreign.Storable (peek) +import Data.Map (Map) +import Control.Monad (guard) + +import qualified Data.HashTable.IO as H + + +-- Types ----------------------------------------------------------------------- + +{-| + The decoder state. + + - An array of words (internal structure of our atoms). + - A pointer to the word *after* the last word in the array. + - A pointer into the current word of that array. + - A bit-offset into that word. +-} +data S = S + { currPtr :: {-# UNPACK #-} !(Ptr Word) + , usedBits :: {-# UNPACK #-} !Word + , pos :: {-# UNPACK #-} !Word + } deriving (Show,Eq,Ord) + +type Env = (Ptr Word, S) + +data DecodeExn + = NotEnoughSpace Env + | TooMuchSpace Env + | BadEncoding Env String + deriving (Show, Eq, Ord) + +data GetResult a = GetResult {-# UNPACK #-} !S !a + deriving Functor + +newtype Get a = Get + { runGet :: Ptr Word + -> H.LinearHashTable Word Noun + -> S + -> IO (GetResult a) + } + +type Bits = Vector Bool + +-------------------------------------------------------------------------------- + +instance Exception DecodeExn + +instance Functor Get where + fmap f g = Get $ \end tbl s -> do + GetResult s' a <- runGet g end tbl s + return $ GetResult s' (f a) + {-# INLINE fmap #-} + +instance Applicative Get where + pure x = Get (\_ _ s -> return $ GetResult s x) + {-# INLINE pure #-} + + Get f <*> Get g = Get $ \end tbl s1 -> do + GetResult s2 f' <- f end tbl s1 + GetResult s3 g' <- g end tbl s2 + return $ GetResult s3 (f' g') + {-# INLINE (<*>) #-} + + Get f *> Get g = Get $ \end tbl s1 -> do + GetResult s2 _ <- f end tbl s1 + g end tbl s2 + {-# INLINE (*>) #-} + +instance Monad Get where + return = pure + {-# INLINE return #-} + + (>>) = (*>) + {-# INLINE (>>) #-} + + Get x >>= f = Get $ \end tbl s -> do + GetResult s' x' <- x end tbl s + runGet (f x') end tbl s' + {-# INLINE (>>=) #-} + + fail msg = Get $ \end tbl s -> + badEncoding end s msg + {-# INLINE fail #-} + +-------------------------------------------------------------------------------- + +badEncoding :: Ptr Word -> S -> String -> IO a +badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg + +-------------------------------------------------------------------------------- + +getPos :: Get Word +getPos = Get $ \_ _ s -> + pure (GetResult s (pos s)) + +insRef :: Word -> Noun -> Get () +insRef pos now = Get \_ tbl s -> do + H.insert tbl pos now + pure $ GetResult s () + +getRef :: Word -> Get Noun +getRef ref = Get \_ tbl s -> do + H.lookup tbl ref >>= \case + Nothing -> fail "Invalid Reference" + Just no -> pure (GetResult s no) + +advance :: Word -> Get () +advance n = Get \_ _ s -> do + let newUsed = n + usedBits s + newS = s { pos = pos s + n + , usedBits = newUsed `mod` 64 + , currPtr = plusPtr (currPtr s) + (fromIntegral $ newUsed `div` 64) + } + + pure (GetResult newS ()) + +-------------------------------------------------------------------------------- + +-- TODO Should this be (>= end) or (> end)? +peekCurWord :: Get Word +peekCurWord = Get \end _ s -> + if ptrToWordPtr (currPtr s) >= ptrToWordPtr end + then pure (GetResult s 0) + else GetResult s <$> peek (currPtr s) + +-- TODO Same question as above. +peekNextWord :: Get Word +peekNextWord = Get \end _ s -> + if ptrToWordPtr (currPtr s) > ptrToWordPtr end + then pure (GetResult s 0) + else GetResult s <$> peek (currPtr s `plusPtr` 1) + +peekUsedBits :: Get Word +peekUsedBits = Get \_ _ s -> pure (GetResult s (usedBits s)) + +{-| + Get a bit. + + - Peek the current word. + - Right-shift by the bit-offset. + - Mask the high bits. +-} +dBit :: Get Bool +dBit = do + wor <- peekCurWord + use <- fromIntegral <$> peekUsedBits + advance 1 + pure (0 /= shiftR wor use .&. 1) + +{-| + Get n bits, where n > 64: + + - Get (n/64) words. + - Advance by n bits. + - Calculate an offset (equal to the current bit-offset) + - Calculate the length (equal to n) + - Construct a bit-vector using the buffer*length*offset. +-} +dBits :: Word -> Get Bits +dBits = undefined + +{-| + In order to peek at the next Word64: + + - If we are past the end of the buffer: + - Return zero. + - If the bit-offset is zero: + - Just peek. + - If we are pointing to the last word: + - Peek and right-shift by the bit offset. + - Otherwise, + - Peek the current word *and* the next word. + - Right-shift the current word by the bit-offset. + - Left-shift the next word by the bit-offset. + - Binary or the resulting two words. +-} +peekWord :: Get Word +peekWord = do + off <- peekUsedBits + cur <- peekCurWord + if off == 0 then pure cur else + do + nex <- peekNextWord + advance 64 + pure (dropLowBits off cur .|. dropHighBits off nex) + +dropLowBits :: Word -> Word -> Word +dropLowBits bits wor = shiftR wor (fromIntegral bits :: Int) + +takeLowBits :: Word -> Word -> Word +takeLowBits 64 wor = wor +takeLowBits wid wor = (2^wid - 1) .&. wor + +takeHighBits :: Word -> Word -> Word +takeHighBits off wor = dropLowBits (64-off) wor + +dropHighBits :: Word -> Word -> Word +dropHighBits off wor = takeLowBits (64-off) wor + +{-| + Make a word from the next n bits (where n <= 64). + + - Peek at the next word. + - Mask the n lowest bits from the word. + - Advance by that number of bits. + - Return the word. +-} +dWordBits :: Word -> Get Word +dWordBits n = do + w <- peekWord + advance n + pure (takeLowBits n w) diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs new file mode 100644 index 000000000..9ff495ec3 --- /dev/null +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE MagicHash #-} + +module Data.Noun.Jam.Put where + +import ClassyPrelude +import GHC.Word (Word(W#)) +import GHC.Int (Int(I#)) +import GHC.Prim +import GHC.Natural +import GHC.Integer.GMP.Internals +import Data.Vector.Primitive ((!)) + +import Control.Lens (view) +import Control.Monad (guard) +import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.), (.&.)) +import Data.Map (Map) +import Data.Noun.Atom (Atom(MkAtom), wordBitWidth#) +import Data.Noun (Noun) +import Data.Noun.Pill (bigNatWords) +import Foreign.Ptr (Ptr, plusPtr, ptrToWordPtr) +import Foreign.Storable (peek, poke) + +import qualified Data.Vector.Primitive as VP +import qualified Data.HashTable.IO as H + + +-- Types ----------------------------------------------------------------------- + +{-| + The encoder state. + + - ptr: Pointer into the output buffer. + - reg: Next 64 bits of output, partially written. + - off: Number of bits already written into `reg` + - pos: Total number of bits written. +-} +data S = S + { ptr :: {-# UNPACK #-} !(Ptr Word) + , reg :: {-# UNPACK #-} !Word + , off :: {-# UNPACK #-} !Int + , pos :: {-# UNPACK #-} !Word + } deriving (Show,Eq,Ord) + +data PutResult a = PutResult {-# UNPACK #-} !S !a + deriving Functor + +newtype Put a = Put + { runPut :: H.LinearHashTable Word Noun + -> S + -> IO (PutResult a) + } + +-------------------------------------------------------------------------------- + +{- + 1. Write the register to the output, and increment the output pointer. +-} +flush :: Put () +flush = Put $ \tbl s@S{..} -> do + poke ptr reg + pure $ PutResult (s { ptr = ptr `plusPtr` 8 }) () +{-# INLINE flush #-} + +update :: (S -> S) -> Put () +update f = Put \tbl s@S{..} -> pure (PutResult (f s) ()) +{-# INLINE update #-} + +setRegOff :: Word -> Int -> Put () +setRegOff r o = update \s@S{..} -> (s {reg=r, off=o}) +{-# INLINE setRegOff #-} + +setReg :: Word -> Put () +setReg r = update \s@S{..} -> (s { reg=r }) +{-# INLINE setReg #-} + +getS :: Put S +getS = Put $ \tbl s -> pure (PutResult s s) +{-# INLINE getS #-} + +putS :: S -> Put () +putS s = Put $ \tbl _ -> pure (PutResult s ()) +{-# INLINE putS #-} + +{- + To write a bit: + + | reg |= 1 << regI + | regI <- (regI + 1) % 64 + | if (!regI): + | buf[w++] <- reg + | reg <- 0 +-} +writeBit :: Bool -> Put () +writeBit b = Put $ \tbl s@S{..} -> do + let s' = s { reg = (if b then setBit else clearBit) reg off + , off = (off + 1) `mod` 64 + , pos = pos + 1 + } + + if off == 63 + then runPut (flush >> setRegOff 0 0) tbl s' + else pure $ PutResult s' () +{-# INLINE writeBit #-} + +{- + To write a 64bit word: + + | reg |= w << regI + | buf[bufI++] = reg + | reg = w >> (64 - regI) +-} +writeWord :: Word -> Put () +writeWord wor = do + S{..} <- getS + setReg (reg .|. shiftL wor off) + flush + setReg (shiftR wor (64 - off)) +{-# INLINE writeWord #-} + +{- + To write some bits (< 64) from a word: + + | reg |= wor << regI + | regI += wid + | + | if (regI >= 64) + | regI -= 64 + | buf[w] = x + | reg = wor >> (wid - regI) +-} +writeBitsFromWord :: Int -> Word -> Put () +writeBitsFromWord wid wor = do + s <- getS + + let s' = s { reg = reg s .|. shiftL wor (off s) + , off = off s + wid + } + + if (off s' < 64) + then do putS s' + else do update (\s -> s { off = off s - 64 }) + flush + setReg (shiftR wor (wid - off s')) +{- + Write all of the the signficant bits of a direct atom. +-} +writeAtomWord# :: Word# -> Put () +writeAtomWord# w = writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) + +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. +-} +writeAtomBigNat :: BigNat -> Put () +writeAtomBigNat (view bigNatWords -> words) = do + let lastIdx = VP.length words - 1 + for_ [0..(lastIdx-1)] \i -> + writeWord (words ! i) + writeAtomWord (words ! lastIdx) + +writeAtom :: Atom -> Put () +writeAtom = \case MkAtom (NatS# wd) -> writeAtomWord# wd + MkAtom (NatJ# bn) -> writeAtomBigNat bn + +-------------------------------------------------------------------------------- + +instance Functor Put where + fmap f g = Put $ \tbl s -> do + PutResult s' a <- runPut g tbl s + pure $ PutResult s' (f a) + {-# INLINE fmap #-} + +instance Applicative Put where + pure x = Put (\_ s -> return $ PutResult s x) + {-# INLINE pure #-} + + Put f <*> Put g = Put $ \tbl s1 -> do + PutResult s2 f' <- f tbl s1 + PutResult s3 g' <- g tbl s2 + return $ PutResult s3 (f' g') + {-# INLINE (<*>) #-} + + Put f *> Put g = Put $ \tbl s1 -> do + PutResult s2 _ <- f tbl s1 + g tbl s2 + {-# INLINE (*>) #-} + +instance Monad Put where + return = pure + {-# INLINE return #-} + + (>>) = (*>) + {-# INLINE (>>) #-} + + Put x >>= f = Put $ \tbl s -> do + PutResult s' x' <- x tbl s + runPut (f x') tbl s' + {-# INLINE (>>=) #-} + +-------------------------------------------------------------------------------- + +doPut :: (a -> Word64) -> (a -> Put ()) -> VP.Vector Word +doPut = undefined + + + +{- + How does this work? + + Allocate a buffer of (jamSz/8) rounded up. + + Traverse the structure. + Keep a table of backreferences (state monad) + If atom + if backreference exists + if backreference smaller + write backreference + else + write atom + else + write atom + if cell + write cell + + To write backreference: + write `1` + write `1` + write mat + + To write atom: + write `0` + write mat + + To write a cell + write `1` + write `0` + write head + write tail + + To write mat: + write prefix + write extra + write data +-} diff --git a/pkg/hs-urbit/lib/Data/Noun/Pill.hs b/pkg/hs-urbit/lib/Data/Noun/Pill.hs index b85a9906f..902da5f12 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Pill.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Pill.hs @@ -152,14 +152,18 @@ bsToWords bs = VP.generate (1 + length bs `div` 8) $ \i -> view packedWord (BS.drop (i*8) bs) --- TODO Support Big-Endian +{- + TODO Support Big-Endian + TODO This still has a (small) risk of segfaulting. The right thing to + do is to manually copy the data to the C heap, setup the + finalizers, and then manually construct a bytestring from + that pointer. -- finalizers, and make a bytestring from that. +-} bytesBS :: Iso' (VP.Vector Word8) ByteString bytesBS = iso to from where to :: VP.Vector Word8 -> ByteString to (VP.Vector off sz buf) = - -- TODO This still has a (small) risk of segfaulting. is still Manually copy the data onto the C heap, setup the - -- finalizers, and make a bytestring from that. unsafePerformIO $ do Prim.Addr ptr <- evaluate $ Prim.byteArrayContents buf bs <- BU.unsafePackAddressLen sz ptr diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Data/Noun/Poet.hs index 27e140c1a..11509cd4f 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet.hs @@ -480,10 +480,7 @@ instance ToNoun Cord where instance FromNoun Cord where parseNoun n = do atom <- parseNoun n - traceM "Parsing cord" - let res@(Cord _) = force $ Cord (atom ^. pill . pillBS) - traceM "Done parsing cord" - pure res + pure $ Cord (atom ^. pill . pillBS) -- Tank and Plum Conversion ---------------------------------------------------- @@ -577,7 +574,9 @@ instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f) => ToNoun (a, b, c, d, e, f) where toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u)) -instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e,FromNoun f) +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f + ) => FromNoun (a, b, c, d, e, f) where parseNoun n = do @@ -585,6 +584,46 @@ instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e,FromNoun f) (q, r, s, t, u) <- parseNoun tail pure (p, q, r, s, t, u) +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g + ) + => FromNoun (a, b, c, d, e, f, g) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v) <- parseNoun tail + pure (p, q, r, s, t, u, v) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h + ) + => FromNoun (a, b, c, d, e, f, g, h) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w) <- parseNoun tail + pure (p, q, r, s, t, u, v, w) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h, FromNoun i + ) + => FromNoun (a, b, c, d, e, f, g, h, i) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w, x) <- parseNoun tail + pure (p, q, r, s, t, u, v, w, x) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j + ) + => FromNoun (a, b, c, d, e, f, g, h, i, j) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w, x, y) <- parseNoun tail + pure (p, q, r, s, t, u, v, w, x, y) + -- This Shouldn't Be Here ------------------------------------------------------ diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index c7748c460..88b05bc98 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -10,6 +10,7 @@ module Vere.Log ( open , readIdent , writeIdent , putJam + , deleteEventAndEverythingAfterIt ) where import ClassyPrelude hiding (init) @@ -26,8 +27,9 @@ import Foreign.Marshal.Alloc import Vere import Vere.Pier.Types -import Control.Lens ((^.)) -import Foreign.Storable (peek, poke, sizeOf) +import Control.Concurrent (runInBoundThread) +import Control.Lens ((^.)) +import Foreign.Storable (peek, poke, sizeOf) import qualified Data.ByteString.Unsafe as BU import qualified Data.ByteString as B @@ -200,3 +202,21 @@ putJam flags txn db id (Jam atom) = do let !bs = atom ^. pill . pillBS byteStringAsMdbVal bs $ \mVal -> do putRaw flags txn db idVal mVal + + +-- Event Pruning --------------------------------------------------------------- + +deleteEventAndEverythingAfterIt :: FilePath -> Word64 -> IO () +deleteEventAndEverythingAfterIt dir first = + runInBoundThread $ do + log@(EventLog env) <- open dir + + last <- latestEventNumber log + txn <- mdb_txn_begin env Nothing False + db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] + + for_ (reverse [first..last]) $ \i -> + withWord64AsMDBval i $ \val -> do + mdb_del txn db val Nothing + + mdb_txn_commit txn diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index ad08a92e6..4eab9960c 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -52,6 +52,41 @@ resume top = do pure (serf, log, e, m) + +-- Run Pier -------------------------------------------------------------------- + +{- +/* _pier_work_save(): tell worker to save checkpoint. +*/ +static void +_pier_work_save(u3_pier* pir_u) +{ + u3_controller* god_u = pir_u->god_u; + u3_disk* log_u = pir_u->log_u; + u3_save* sav_u = pir_u->sav_u; + + c3_assert( god_u->dun_d == sav_u->req_d ); + c3_assert( log_u->com_d >= god_u->dun_d ); + + { + u3_noun mat = u3ke_jam(u3nc(c3__save, u3i_chubs(1, &god_u->dun_d))); + u3_newt_write(&god_u->inn_u, mat, 0); + + // XX wait on some report of success before updating? + // + sav_u->dun_d = sav_u->req_d; + } + + // if we're gracefully shutting down, do so now + // + if ( u3_psat_done == pir_u->sat_e ) { + _pier_exit_done(pir_u); + } +} +-} + + + {- performCommonPierStartup :: Serf.Serf -> TQueue Ovum diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 469fd2671..5dae02855 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -91,35 +91,24 @@ data IODriver = IODriver , startDriver :: (Ovum -> STM ()) -> IO (Async (), Perform) } - data Writ a = Writ - { eventId :: Word64 - , timeout :: Maybe Word - , event :: Jam -- mat - , payload :: a + { eventId :: Word64 + , timeout :: Maybe Word + , event :: Jam -- mat + , payload :: a } data Pier = Pier - { computeQueue :: TQueue Ovum - , persistQueue :: TQueue (Writ [Eff]) - , releaseQueue :: TQueue (Writ [Eff]) - , logState :: LogState + { computeQueue :: TQueue Ovum + , persistQueue :: TQueue (Writ [Eff]) + , releaseQueue :: TQueue (Writ [Eff]) + , log :: EventLog , driverThreads :: [(Async (), Perform)] , portingThread :: Async () } newtype EventLog = EventLog MDB_env --- TODO: We are uncertain about q's type. There's some serious entanglement --- with u3_pier in this logic in the C code, and you might not be able to get --- away with anything less than passing the full u3_writ around. -data LogState = LogState - { env :: MDB_env - , inputQueue :: TQueue (Writ [Eff]) - , onPersist :: Writ [Eff] -> STM () - , writer :: Async () - } - data LogIdentity = LogIdentity { who :: Noun , is_fake :: Noun From c8055f224f2a86aada03c96db5f11be3afe046a7 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sat, 29 Jun 2019 19:36:07 -0700 Subject: [PATCH 085/431] Finished code for fast Jam (no backreferences yet, and untested). --- pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 114 ++++++++++++++------------ 1 file changed, 61 insertions(+), 53 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs index 9ff495ec3..56061a98f 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs @@ -10,18 +10,22 @@ import GHC.Natural import GHC.Integer.GMP.Internals import Data.Vector.Primitive ((!)) -import Control.Lens (view) -import Control.Monad (guard) -import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.), (.&.)) -import Data.Map (Map) -import Data.Noun.Atom (Atom(MkAtom), wordBitWidth#) -import Data.Noun (Noun) -import Data.Noun.Pill (bigNatWords) -import Foreign.Ptr (Ptr, plusPtr, ptrToWordPtr) -import Foreign.Storable (peek, poke) +import Control.Lens (view) +import Control.Monad (guard) +import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.), (.&.)) +import Data.Map (Map) +import Data.Noun.Atom (Atom(MkAtom), wordBitWidth#) +import Data.Noun (Noun(Atom, Cell)) +import Data.Noun.Pill (bigNatWords) +import Data.Noun.Atom (toAtom, takeBits, bitWidth) +import Foreign.Marshal.Alloc (mallocBytes, free) +import Foreign.Ptr (Ptr, castPtr, plusPtr, ptrToWordPtr) +import Foreign.Storable (peek, poke) +import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Vector.Primitive as VP -import qualified Data.HashTable.IO as H +import qualified Data.ByteString.Unsafe as BS +import qualified Data.HashTable.IO as H +import qualified Data.Vector.Primitive as VP -- Types ----------------------------------------------------------------------- @@ -162,9 +166,9 @@ writeAtomBigNat (view bigNatWords -> words) = do writeWord (words ! i) writeAtomWord (words ! lastIdx) -writeAtom :: Atom -> Put () -writeAtom = \case MkAtom (NatS# wd) -> writeAtomWord# wd - MkAtom (NatJ# bn) -> writeAtomBigNat bn +writeAtomBits :: Atom -> Put () +writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd + MkAtom (NatJ# bn) -> writeAtomBigNat bn -------------------------------------------------------------------------------- @@ -203,46 +207,50 @@ instance Monad Put where -------------------------------------------------------------------------------- -doPut :: (a -> Word64) -> (a -> Put ()) -> VP.Vector Word -doPut = undefined - +doPut :: Word64 -> Put () -> ByteString +doPut sz m = + unsafePerformIO $ do + tbl <- H.new + buf <- mallocBytes (fromIntegral $ wordSz*8) + _ <- runPut m tbl (S buf 0 0 0) + BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf) + where + wordSz = fromIntegral (sz `divUp` 64) + byteSz = fromIntegral (sz `divUp` 8) + divUp x y = (x `div` y) + (if x `mod` y == 0 then 0 else 1) +-------------------------------------------------------------------------------- {- - How does this work? - - Allocate a buffer of (jamSz/8) rounded up. - - Traverse the structure. - Keep a table of backreferences (state monad) - If atom - if backreference exists - if backreference smaller - write backreference - else - write atom - else - write atom - if cell - write cell - - To write backreference: - write `1` - write `1` - write mat - - To write atom: - write `0` - write mat - - To write a cell - write `1` - write `0` - write head - write tail - - To write mat: - write prefix - write extra - write data + TODO Handle back references -} +writeNoun :: Noun -> Put () +writeNoun = \case Atom a -> writeAtom a + Cell h t -> writeCell (h, t) + +writeMat :: Atom -> Put () +writeMat atm = do + writeBitsFromWord (preWid+1) (shiftL (1 :: Word) preWid) + writeAtomBits extras + writeAtomBits atm + where + atmWid = bitWidth atm :: Atom + preWid = bitWidth atmWid :: Int + prefix = shiftL (1 :: Word) (fromIntegral preWid) + extras = takeBits (preWid-1) (toAtom atmWid) + +writeCell :: (Noun, Noun) -> Put () +writeCell (h, t) = do + writeBit True + writeBit False + writeNoun h + writeNoun t + +writeAtom :: Atom -> Put () +writeAtom a = writeBit False >> writeMat a + +writeBackRef :: Atom -> Put () +writeBackRef a = do + writeBit True + writeBit True + writeMat a From 3c25a1bb6ee3e66bda2d3911ba2babe5cbecc8e6 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sat, 29 Jun 2019 20:05:45 -0700 Subject: [PATCH 086/431] Jam: backreferences. --- pkg/hs-urbit/lib/Data/Noun.hs | 11 ++-- pkg/hs-urbit/lib/Data/Noun/Atom.hs | 4 +- pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 75 +++++++++++++++++++-------- pkg/hs-urbit/package.yaml | 1 + 4 files changed, 63 insertions(+), 28 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun.hs b/pkg/hs-urbit/lib/Data/Noun.hs index ad1172252..fe79d8a6f 100644 --- a/pkg/hs-urbit/lib/Data/Noun.hs +++ b/pkg/hs-urbit/lib/Data/Noun.hs @@ -2,18 +2,19 @@ module Data.Noun where import Prelude hiding (all) -import ClassyPrelude (Text, all, unpack) import Control.Applicative import Control.Monad -import Data.Noun.Atom (Atom) import Data.Bits import GHC.Generics import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen import Data.Flat hiding (getSize) -import Data.List (intercalate) -import Data.Typeable (Typeable) +import ClassyPrelude (Text, all, unpack) +import Data.Hashable (Hashable) +import Data.List (intercalate) +import Data.Noun.Atom (Atom) +import Data.Typeable (Typeable) import qualified Control.Monad.Fail as Fail import qualified Data.Char as C @@ -28,7 +29,7 @@ data Noun = Atom !Atom | Cell !Noun !Noun deriving stock (Eq, Ord, Generic) - deriving anyclass Flat + deriving anyclass (Flat, Hashable) data CellIdx = L | R deriving (Eq, Ord, Show) diff --git a/pkg/hs-urbit/lib/Data/Noun/Atom.hs b/pkg/hs-urbit/lib/Data/Noun/Atom.hs index 1ac03a1c4..f80937d8d 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Atom.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Atom.hs @@ -16,10 +16,12 @@ import Test.QuickCheck.Gen import Text.Printf import Data.Flat +import Data.Hashable (Hashable) + -------------------------------------------------------------------------------- newtype Atom = MkAtom { unAtom :: Natural } - deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral, Flat) + deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral, Flat, Hashable) instance Show Atom where show (MkAtom a) = show a diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs index 56061a98f..83ee00863 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs @@ -3,24 +3,24 @@ module Data.Noun.Jam.Put where import ClassyPrelude -import GHC.Word (Word(W#)) -import GHC.Int (Int(I#)) import GHC.Prim import GHC.Natural import GHC.Integer.GMP.Internals -import Data.Vector.Primitive ((!)) import Control.Lens (view) import Control.Monad (guard) import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.), (.&.)) import Data.Map (Map) import Data.Noun.Atom (Atom(MkAtom), wordBitWidth#) +import Data.Noun.Atom (toAtom, takeBits, bitWidth) import Data.Noun (Noun(Atom, Cell)) import Data.Noun.Pill (bigNatWords) -import Data.Noun.Atom (toAtom, takeBits, bitWidth) +import Data.Vector.Primitive ((!)) import Foreign.Marshal.Alloc (mallocBytes, free) import Foreign.Ptr (Ptr, castPtr, plusPtr, ptrToWordPtr) import Foreign.Storable (peek, poke) +import GHC.Int (Int(I#)) +import GHC.Word (Word(W#)) import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Unsafe as BS @@ -49,41 +49,49 @@ data PutResult a = PutResult {-# UNPACK #-} !S !a deriving Functor newtype Put a = Put - { runPut :: H.LinearHashTable Word Noun + { runPut :: H.LinearHashTable Noun Word -> S -> IO (PutResult a) } -------------------------------------------------------------------------------- +{-# INLINE insRef #-} +insRef :: Noun -> Word -> Put () +insRef n w = Put \tbl s -> PutResult s <$> H.insert tbl n w + +{-# INLINE getRef #-} +getRef :: Noun -> Put (Maybe Word) +getRef n = Put \tbl s -> PutResult s <$> H.lookup tbl n + {- 1. Write the register to the output, and increment the output pointer. -} +{-# INLINE flush #-} flush :: Put () flush = Put $ \tbl s@S{..} -> do poke ptr reg pure $ PutResult (s { ptr = ptr `plusPtr` 8 }) () -{-# INLINE flush #-} +{-# INLINE update #-} update :: (S -> S) -> Put () update f = Put \tbl s@S{..} -> pure (PutResult (f s) ()) -{-# INLINE update #-} +{-# INLINE setRegOff #-} setRegOff :: Word -> Int -> Put () setRegOff r o = update \s@S{..} -> (s {reg=r, off=o}) -{-# INLINE setRegOff #-} +{-# INLINE setReg #-} setReg :: Word -> Put () setReg r = update \s@S{..} -> (s { reg=r }) -{-# INLINE setReg #-} +{-# INLINE getS #-} getS :: Put S getS = Put $ \tbl s -> pure (PutResult s s) -{-# INLINE getS #-} +{-# INLINE putS #-} putS :: S -> Put () putS s = Put $ \tbl _ -> pure (PutResult s ()) -{-# INLINE putS #-} {- To write a bit: @@ -94,6 +102,7 @@ putS s = Put $ \tbl _ -> pure (PutResult s ()) | buf[w++] <- reg | reg <- 0 -} +{-# INLINE writeBit #-} writeBit :: Bool -> Put () writeBit b = Put $ \tbl s@S{..} -> do let s' = s { reg = (if b then setBit else clearBit) reg off @@ -104,7 +113,6 @@ writeBit b = Put $ \tbl s@S{..} -> do if off == 63 then runPut (flush >> setRegOff 0 0) tbl s' else pure $ PutResult s' () -{-# INLINE writeBit #-} {- To write a 64bit word: @@ -113,13 +121,13 @@ writeBit b = Put $ \tbl s@S{..} -> do | buf[bufI++] = reg | reg = w >> (64 - regI) -} +{-# INLINE writeWord #-} writeWord :: Word -> Put () writeWord wor = do S{..} <- getS setReg (reg .|. shiftL wor off) flush setReg (shiftR wor (64 - off)) -{-# INLINE writeWord #-} {- To write some bits (< 64) from a word: @@ -132,6 +140,7 @@ writeWord wor = do | buf[w] = x | reg = wor >> (wid - regI) -} +{-# INLINE writeBitsFromWord #-} writeBitsFromWord :: Int -> Word -> Put () writeBitsFromWord wid wor = do s <- getS @@ -148,9 +157,11 @@ writeBitsFromWord wid wor = do {- Write all of the the signficant bits of a direct atom. -} +{-# INLINE writeAtomWord# #-} writeAtomWord# :: Word# -> Put () writeAtomWord# w = writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) +{-# INLINE writeAtomWord #-} writeAtomWord :: Word -> Put () writeAtomWord (W# w) = writeAtomWord# w @@ -159,6 +170,7 @@ writeAtomWord (W# w) = writeAtomWord# w TODO Use memcpy when the bit-offset of the output is divisible by 8. -} +{-# INLINE writeAtomBigNat #-} writeAtomBigNat :: BigNat -> Put () writeAtomBigNat (view bigNatWords -> words) = do let lastIdx = VP.length words - 1 @@ -166,17 +178,19 @@ writeAtomBigNat (view bigNatWords -> words) = do writeWord (words ! i) writeAtomWord (words ! lastIdx) +{-# INLINE writeAtomBits #-} writeAtomBits :: Atom -> Put () writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd MkAtom (NatJ# bn) -> writeAtomBigNat bn --------------------------------------------------------------------------------- + +-- Put Instances --------------------------------------------------------------- instance Functor Put where fmap f g = Put $ \tbl s -> do PutResult s' a <- runPut g tbl s pure $ PutResult s' (f a) - {-# INLINE fmap #-} + {-# INLINE fmap #-} instance Applicative Put where pure x = Put (\_ s -> return $ PutResult s x) @@ -205,6 +219,7 @@ instance Monad Put where runPut (f x') tbl s' {-# INLINE (>>=) #-} + -------------------------------------------------------------------------------- doPut :: Word64 -> Put () -> ByteString @@ -219,15 +234,26 @@ doPut sz m = byteSz = fromIntegral (sz `divUp` 8) divUp x y = (x `div` y) + (if x `mod` y == 0 then 0 else 1) + -------------------------------------------------------------------------------- {- TODO Handle back references -} writeNoun :: Noun -> Put () -writeNoun = \case Atom a -> writeAtom a - Cell h t -> writeCell (h, t) +writeNoun n = do + p <- pos <$> getS + mRef <- getRef n + case (mRef, n) of + (Nothing, Atom a) -> writeAtom a + (Nothing, Cell h t) -> writeCell h t + (Just bk, Atom a) | a < toAtom bk -> writeAtom a + (Just bk, _) -> writeBackRef bk + + insRef n p + +{-# INLINE writeMat #-} writeMat :: Atom -> Put () writeMat atm = do writeBitsFromWord (preWid+1) (shiftL (1 :: Word) preWid) @@ -239,18 +265,23 @@ writeMat atm = do prefix = shiftL (1 :: Word) (fromIntegral preWid) extras = takeBits (preWid-1) (toAtom atmWid) -writeCell :: (Noun, Noun) -> Put () -writeCell (h, t) = do +{-# INLINE writeCell #-} +writeCell :: Noun -> Noun -> Put () +writeCell h t = do writeBit True writeBit False writeNoun h writeNoun t +{-# INLINE writeAtom #-} writeAtom :: Atom -> Put () -writeAtom a = writeBit False >> writeMat a +writeAtom a = do + writeBit False + writeMat a -writeBackRef :: Atom -> Put () +{-# INLINE writeBackRef #-} +writeBackRef :: Word -> Put () writeBackRef a = do writeBit True writeBit True - writeMat a + writeMat (toAtom a) diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 61783ad6b..6bd1768a5 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -20,6 +20,7 @@ dependencies: - fixed-vector - flat - ghc-prim + - hashable - hashtables - http-client - http-types From d445c1cbb14ce180a951fe5569d0e3ea677aab4e Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 30 Jun 2019 16:17:59 -0700 Subject: [PATCH 087/431] Fixed a back-ref bug in my old jam, and got my fast jam to pass tests. --- pkg/hs-urbit/lib/Data/Noun/Atom.hs | 21 +++- pkg/hs-urbit/lib/Data/Noun/Jam.hs | 47 ++++++-- pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 167 +++++++++++++++++++------- pkg/hs-urbit/lib/Data/Noun/Pill.hs | 31 ++--- 4 files changed, 192 insertions(+), 74 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Atom.hs b/pkg/hs-urbit/lib/Data/Noun/Atom.hs index f80937d8d..a78e76f89 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Atom.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Atom.hs @@ -21,7 +21,7 @@ import Data.Hashable (Hashable) -------------------------------------------------------------------------------- newtype Atom = MkAtom { unAtom :: Natural } - deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral, Flat, Hashable) + deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral, Flat, Hashable, NFData) instance Show Atom where show (MkAtom a) = show a @@ -109,6 +109,9 @@ instance IsAtom Integer where wordBitWidth# :: Word# -> Word# wordBitWidth# w = minusWord# 64## (clz# w) +wordBitWidth :: Word -> Word +wordBitWidth (W# w) = W# (wordBitWidth# w) + bigNatBitWidth# :: BigNat -> Word# bigNatBitWidth# nat = lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##) @@ -141,24 +144,30 @@ instance IsAtom Cursor where -------------------------------------------------------------------------------- +{-# INLINE slice #-} slice :: (Atom, Atom) -> Atom -> Atom slice (offset, size) buf = fromSlice (Slice (fromAtom offset) (fromAtom size) buf) +{-# INLINE fromSlice #-} fromSlice :: Slice -> Atom -fromSlice (Slice off wid buf) = mask .&. (shiftR buf off) - where mask = shiftL (MkAtom 1) wid - 1 - +fromSlice (Slice off wid buf) = takeBits wid (shiftR buf off) -------------------------------------------------------------------------------- +{-# INLINE takeBits #-} takeBits :: Int -> Atom -> Atom -takeBits wid buf = mask .&. buf - where mask = shiftL (MkAtom 1) wid - 1 +takeBits wid buf = buf .&. (shiftL (MkAtom 1) wid - 1) +{-# INLINE takeBitsWord #-} +takeBitsWord :: Int -> Word -> Word +takeBitsWord wid wor = wor .&. (shiftL 1 wid - 1) + +{-# INLINE bitIdx #-} bitIdx :: Int -> Atom -> Bool bitIdx idx buf = testBit buf idx +{-# INLINE bitConcat #-} bitConcat :: Atom -> Atom -> Atom bitConcat x y = x .|. shiftL y (bitWidth x) diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam.hs b/pkg/hs-urbit/lib/Data/Noun/Jam.hs index adf6ffda7..692099504 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam.hs @@ -15,6 +15,9 @@ import Test.Tasty.TH import Test.Tasty.QuickCheck as QC import Test.QuickCheck +import qualified Data.Noun.Jam.Put as Fast +import qualified Data.Noun.Pill as Pill + -- Length-Encoded Atoms -------------------------------------------------------- @@ -51,7 +54,7 @@ jam' = toAtom . fst . go 0 mempty where insertNoun :: Noun -> Int -> Map Noun Int -> Map Noun Int insertNoun n i tbl = lookup n tbl - & maybe tbl (const $ insertMap n i tbl) + & maybe (insertMap n i tbl) (const tbl) go :: Int -> Map Noun Int -> Noun -> (Buf, Map Noun Int) go off oldTbl noun = @@ -68,8 +71,8 @@ jam' = toAtom . fst . go 0 mempty where Buf sz res = mat' atm (Nothing, Cell lef rit) -> (Buf (2+lSz+rSz) (xor 1 (shiftL (lRes .|. shiftL rRes lSz) 2)), rTbl) - where (Buf lSz lRes, lTbl) = go (off+2) tbl lef - (Buf rSz rRes, rTbl) = go (off+lSz) lTbl rit + where (Buf lSz lRes, lTbl) = go (off+2) tbl lef + (Buf rSz rRes, rTbl) = go (off+2+lSz) lTbl rit cue' :: Atom -> Maybe Noun cue' buf = view _2 <$> go mempty 0 @@ -98,7 +101,7 @@ mat atm = Buf bufWid buffer where atmWid = bitWidth atm preWid = bitWidth (toAtom atmWid) - bufWid = preWid + preWid + atmWid + bufWid = 2*preWid + atmWid prefix = shiftL 1 preWid extras = takeBits (preWid-1) (toAtom atmWid) suffix = xor extras (shiftL atm (preWid-1)) @@ -114,9 +117,9 @@ rub slc@(Cursor idx buf) = prefix -> pure (Buf sz val) where widIdx = idx + 1 + prefix - width = fromSlice (Slice widIdx (prefix - 1) buf) + extra = fromSlice (Slice widIdx (prefix - 1) buf) datIdx = widIdx + (prefix-1) - datWid = fromIntegral $ 2^(prefix-1) + width + datWid = fromIntegral $ extra + 2^(prefix-1) sz = datWid + (2*prefix) val = fromSlice (Slice datIdx datWid buf) @@ -130,7 +133,7 @@ jam = toAtom . fst . go 0 mempty where insertNoun :: Noun -> Int -> Map Noun Int -> Map Noun Int insertNoun n i tbl = lookup n tbl - & maybe tbl (const $ insertMap n i tbl) + & maybe (insertMap n i tbl) (const tbl) go :: Int -> Map Noun Int -> Noun -> (Buf, Map Noun Int) go off oldTbl noun = @@ -148,7 +151,7 @@ jam = toAtom . fst . go 0 mempty (Nothing, Cell lef rit) -> (Buf (2+lSz+rSz) (xor 1 (shiftL (bitConcat lRes rRes) 2)), rTbl) where (Buf lSz lRes, lTbl) = go (off+2) tbl lef - (Buf rSz rRes, rTbl) = go (off+lSz) lTbl rit + (Buf rSz rRes, rTbl) = go (off+2+lSz) lTbl rit leadingZeros :: Cursor -> Maybe Int leadingZeros (Cursor idx buf) = go 0 @@ -163,17 +166,15 @@ cue buf = view _2 <$> go mempty 0 where go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun) go tbl i = - -- trace ("go-" <> show i) case (bitIdx i buf, bitIdx (i+1) buf) of (False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf) let r = Atom at - pure (wid+1, r, insertMap i r tbl) + pure (1+wid, r, insertMap i r tbl) (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) let r = Cell lef rit pure (2+lSz+rSz, r, insertMap i r tbl) (True, True ) -> do Buf wid at <- rub (Cursor (i+2) buf) - -- traceM ("ref-" <> show at) r <- lookup (fromIntegral at) tbl & \case Nothing -> error ("bad-ref-" <> show at) Just ix -> Just ix @@ -182,6 +183,21 @@ cue buf = view _2 <$> go mempty 0 -- Tests ----------------------------------------------------------------------- +a12 = Atom 12 +a36 = Atom 36 +a9 = Atom 9 + +d12 = Cell a12 a12 +q12 = Cell d12 d12 + +midleEx = Cell a36 $ Cell a9 $ Cell q12 q12 + +smallEx = Cell (Cell (Atom 14) (Atom 8)) + $ Cell (Atom 15) (Atom 15) + +smallEx2 = Cell (Cell (Atom 0) (Atom 0)) + $ Cell (Atom 10) (Atom 10) + pills :: [Atom] pills = [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 , 0x3170_c7c1, 0x93_c7c1, 0xa_72e0, 0x1bd5_b7dd_e080 @@ -193,6 +209,15 @@ cueTest = traverse cue pills jamTest :: Maybe [Atom] jamTest = fmap jam <$> cueTest +prop_fastMatSlow :: Atom -> Bool +prop_fastMatSlow a = jam (Atom a) == Fast.jam (Atom a) + +prop_fastJamSlow :: Noun -> Bool +prop_fastJamSlow n = jam n == Fast.jam n + +prop_fastJam :: Noun -> Bool +prop_fastJam n = Just n == cue (Fast.jam n) + prop_jamCue :: Noun -> Bool prop_jamCue n = Just n == cue (jam n) diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs index 83ee00863..4ed24265c 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs @@ -7,16 +7,17 @@ import GHC.Prim import GHC.Natural import GHC.Integer.GMP.Internals -import Control.Lens (view) +import Control.Lens (view, to, from, (&)) import Control.Monad (guard) import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.), (.&.)) import Data.Map (Map) -import Data.Noun.Atom (Atom(MkAtom), wordBitWidth#) +import Data.Noun.Atom ( Atom(MkAtom), wordBitWidth, wordBitWidth# + , atomBitWidth#, takeBitsWord ) import Data.Noun.Atom (toAtom, takeBits, bitWidth) import Data.Noun (Noun(Atom, Cell)) -import Data.Noun.Pill (bigNatWords) +import Data.Noun.Pill (bigNatWords, atomBS) import Data.Vector.Primitive ((!)) -import Foreign.Marshal.Alloc (mallocBytes, free) +import Foreign.Marshal.Alloc (callocBytes, free) import Foreign.Ptr (Ptr, castPtr, plusPtr, ptrToWordPtr) import Foreign.Storable (peek, poke) import GHC.Int (Int(I#)) @@ -96,15 +97,16 @@ putS s = Put $ \tbl _ -> pure (PutResult s ()) {- To write a bit: - | reg |= 1 << regI - | regI <- (regI + 1) % 64 - | if (!regI): + | reg |= 1 << off + | off <- (off + 1) % 64 + | if (!off): | buf[w++] <- reg | reg <- 0 -} {-# INLINE writeBit #-} writeBit :: Bool -> Put () writeBit b = Put $ \tbl s@S{..} -> do + -- traceM ("writeBit: " <> show b) let s' = s { reg = (if b then setBit else clearBit) reg off , off = (off + 1) `mod` 64 , pos = pos + 1 @@ -117,49 +119,60 @@ writeBit b = Put $ \tbl s@S{..} -> do {- To write a 64bit word: - | reg |= w << regI + | reg |= w << off | buf[bufI++] = reg - | reg = w >> (64 - regI) + | reg = w >> (64 - off) -} {-# INLINE writeWord #-} writeWord :: Word -> Put () writeWord wor = do + -- traceM ("writeWord: " <> show wor) S{..} <- getS setReg (reg .|. shiftL wor off) flush - setReg (shiftR wor (64 - off)) + update \s -> s { pos = 64 + pos + , reg = shiftR wor (64 - off) + } {- To write some bits (< 64) from a word: - | reg |= wor << regI - | regI += wid + | wor = takeBits(wid, wor) + | reg = reg .|. (wor << off) + | off = (off + wid) % 64 | - | if (regI >= 64) - | regI -= 64 + | if (off + wid >= 64) | buf[w] = x - | reg = wor >> (wid - regI) + | reg = wor >> (wid - off) -} + {-# INLINE writeBitsFromWord #-} writeBitsFromWord :: Int -> Word -> Put () writeBitsFromWord wid wor = do - s <- getS + wor <- pure (takeBitsWord wid wor) - let s' = s { reg = reg s .|. shiftL wor (off s) - , off = off s + wid - } + -- traceM ("writeBitsFromWord: " <> show wid <> ", " <> show wor) - if (off s' < 64) - then do putS s' - else do update (\s -> s { off = off s - 64 }) - flush - setReg (shiftR wor (wid - off s')) + oldSt <- getS + + let newSt = oldSt { reg = reg oldSt .|. shiftL wor (off oldSt) + , off = (off oldSt + wid) `mod` 64 + , pos = fromIntegral wid + pos oldSt + } + + putS newSt + + when (wid + off oldSt >= 64) $ do + flush + setReg (shiftR wor (wid - off newSt)) {- Write all of the the signficant bits of a direct atom. -} {-# INLINE writeAtomWord# #-} writeAtomWord# :: Word# -> Put () -writeAtomWord# w = writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) +writeAtomWord# w = do + -- traceM "writeAtomWord" + writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) {-# INLINE writeAtomWord #-} writeAtomWord :: Word -> Put () @@ -173,6 +186,7 @@ writeAtomWord (W# w) = writeAtomWord# w {-# INLINE writeAtomBigNat #-} writeAtomBigNat :: BigNat -> Put () writeAtomBigNat (view bigNatWords -> words) = do + -- traceM "writeAtomBigNat" let lastIdx = VP.length words - 1 for_ [0..(lastIdx-1)] \i -> writeWord (words ! i) @@ -222,18 +236,23 @@ instance Monad Put where -------------------------------------------------------------------------------- -doPut :: Word64 -> Put () -> ByteString +doPut :: Word -> Put () -> ByteString doPut sz m = unsafePerformIO $ do tbl <- H.new - buf <- mallocBytes (fromIntegral $ wordSz*8) - _ <- runPut m tbl (S buf 0 0 0) - BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf) + buf <- callocBytes (fromIntegral $ 4 * wordSz*8) + _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) + BS.unsafePackCStringFinalizer (castPtr buf) (2*byteSz) (free buf) where wordSz = fromIntegral (sz `divUp` 64) byteSz = fromIntegral (sz `divUp` 8) divUp x y = (x `div` y) + (if x `mod` y == 0 then 0 else 1) + mbFlush :: Put () + mbFlush = do + shouldFlush <- (/= 0) . off <$> getS + when shouldFlush flush + -------------------------------------------------------------------------------- @@ -242,32 +261,38 @@ doPut sz m = -} writeNoun :: Noun -> Put () writeNoun n = do - p <- pos <$> getS - mRef <- getRef n + -- traceM "writeNoun" - case (mRef, n) of - (Nothing, Atom a) -> writeAtom a - (Nothing, Cell h t) -> writeCell h t - (Just bk, Atom a) | a < toAtom bk -> writeAtom a - (Just bk, _) -> writeBackRef bk + p <- pos <$> getS + mRef <- getRef n - insRef n p + case (mRef, n) of + (Nothing, Atom a) -> writeAtom a + (Nothing, Cell h t) -> writeCell h t + (Just bk, Atom a) | bitWidth a <= wordBitWidth bk -> writeAtom a + (Just bk, _) -> writeBackRef bk + + when (mRef == Nothing) $ + insRef n p {-# INLINE writeMat #-} writeMat :: Atom -> Put () +writeMat 0 = do + -- traceM "writeMat: 0" + writeBit True writeMat atm = do - writeBitsFromWord (preWid+1) (shiftL (1 :: Word) preWid) - writeAtomBits extras + -- traceM ("writeMat: " <> show atm) + writeBitsFromWord (preWid+1) (shiftL 1 preWid) + writeBitsFromWord (preWid-1) atmWid writeAtomBits atm where - atmWid = bitWidth atm :: Atom - preWid = bitWidth atmWid :: Int - prefix = shiftL (1 :: Word) (fromIntegral preWid) - extras = takeBits (preWid-1) (toAtom atmWid) + atmWid = bitWidth atm + preWid = fromIntegral (wordBitWidth atmWid) {-# INLINE writeCell #-} writeCell :: Noun -> Noun -> Put () writeCell h t = do + -- traceM "writeCell" writeBit True writeBit False writeNoun h @@ -276,12 +301,68 @@ writeCell h t = do {-# INLINE writeAtom #-} writeAtom :: Atom -> Put () writeAtom a = do + -- traceM "writeAtom" writeBit False writeMat a {-# INLINE writeBackRef #-} writeBackRef :: Word -> Put () writeBackRef a = do + -- traceM ("writeBackRef: " <> show a) writeBit True writeBit True writeMat (toAtom a) + +-------------------------------------------------------------------------------- + +jamBS :: Noun -> ByteString +jamBS n = doPut (fst $ preJam n) (writeNoun n) + +jam :: Noun -> Atom +jam = view (to jamBS . from atomBS) + +-------------------------------------------------------------------------------- + +preJam :: Noun -> (Word, Map Noun Word) +preJam = go 0 mempty + where + insertNoun :: Noun -> Word -> Map Noun Word -> Map Noun Word + insertNoun n i tbl = lookup n tbl + & maybe (insertMap n i tbl) (const tbl) + + go :: Word -> Map Noun Word -> Noun -> (Word, Map Noun Word) + go off oldTbl noun = + let tbl = insertNoun noun off oldTbl in + case lookup noun oldTbl of + Nothing -> + case noun of + Atom atm -> + (1 + W# (matSz# atm), tbl) + Cell l r -> + let (lSz, tbl') = go (2+off) tbl l in + let (rSz, tbl'') = go (2+off+lSz) tbl' r in + (2 + lSz + rSz, tbl'') + Just (W# ref) -> + let refSz = W# (wordBitWidth# ref) in + case noun of + Atom atm -> + let worSz = W# (matSz# atm) in + if worSz > refSz + then (2 + refSz, oldTbl) + else (1 + worSz, tbl) + Cell _ _ -> + (2 + refSz, oldTbl) + + matSz# :: Atom -> Word# + matSz# 0 = 1## + matSz# a = preW `plusWord#` preW `plusWord#` atmW + where + atmW = atomBitWidth# a + preW = wordBitWidth# atmW + + refSz# :: Word# -> Word# + refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) + + nounSz# :: Noun -> Word# + nounSz# (Atom a) = 1## `plusWord#` (matSz# a) + nounSz# (Cell l r) = 2## `plusWord#` (nounSz# l) `plusWord#` (nounSz# r) diff --git a/pkg/hs-urbit/lib/Data/Noun/Pill.hs b/pkg/hs-urbit/lib/Data/Noun/Pill.hs index 902da5f12..6532899f3 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Pill.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Pill.hs @@ -25,7 +25,7 @@ module Data.Noun.Pill where import ClassyPrelude import Data.Noun hiding (toList, fromList) import Data.Noun.Atom -import Data.Noun.Jam hiding (main) +-- import Data.Noun.Jam hiding (main) import Data.Flat hiding (from, to) import Control.Monad.Except import Control.Lens hiding (index, Index) @@ -178,8 +178,8 @@ pillWords = iso toVec fromVec toVec = view (pillBS . to bsToWords) fromVec = view (to wordsToBytes . bytesBS . from pillBS) -_CueBytes :: Prism' ByteString Noun -_CueBytes = from pillBS . from pill . _Cue +-- _CueBytes :: Prism' ByteString Noun +-- _CueBytes = from pillBS . from pill . _Cue -------------------------------------------------------------------------------- @@ -201,10 +201,13 @@ pill = iso toAtom fromPill toAtom = view (atomNat . natWords . from pillWords) fromPill = view (pillBS . to bsToWords . from natWords . from atomNat) +atomBS :: Iso' Atom ByteString +atomBS = pill . pillBS + -------------------------------------------------------------------------------- -_Cue :: Prism' Atom Noun -_Cue = prism' jam cue +-- _Cue :: Prism' Atom Noun +-- _Cue = prism' jam cue _Tall :: Flat a => Prism' ByteString a _Tall = prism' flat (eitherToMaybe . unflat) @@ -221,8 +224,8 @@ loadPill = fmap Pill . readFile loadAtom :: FilePath -> IO Atom loadAtom = fmap (view $ from pillBS . from pill) . readFile -loadNoun :: FilePath -> IO (Maybe Noun) -loadNoun = fmap (preview $ from pillBS . from pill . _Cue) . readFile +-- loadNoun :: FilePath -> IO (Maybe Noun) +-- loadNoun = fmap (preview $ from pillBS . from pill . _Cue) . readFile loadFlat :: Flat a => FilePath -> IO (Either Text a) loadFlat = fmap (mapLeft tshow . unflat) . readFile @@ -235,8 +238,8 @@ dumpPill fp = writeFile fp . view pillBS dumpAtom :: FilePath -> Atom -> IO () dumpAtom fp = writeFile fp . view (pill . pillBS) -dumpJam :: FilePath -> Noun -> IO () -dumpJam fp = writeFile fp . view (re _Cue . pill . pillBS) +-- dumpJam :: FilePath -> Noun -> IO () +-- dumpJam fp = writeFile fp . view (re _Cue . pill . pillBS) dumpFlat :: Flat a => FilePath -> a -> IO () dumpFlat fp = writeFile fp . flat @@ -265,11 +268,11 @@ tryPackPill pf = do atm <- tryLoadPill pf print $ length (atm ^. pill . pillBS) -tryCuePill :: PillFile -> IO () -tryCuePill pill = - loadNoun (show pill) >>= \case Nothing -> print "nil" - Just (Atom _) -> print "atom" - _ -> print "cell" +-- tryCuePill :: PillFile -> IO () +-- tryCuePill pill = + -- loadNoun (show pill) >>= \case Nothing -> print "nil" + -- Just (Atom _) -> print "atom" + -- _ -> print "cell" -- Tests ----------------------------------------------------------------------- From 89b2cccae7adc94d38913779f191aab5c01cdf19 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 30 Jun 2019 19:30:23 -0700 Subject: [PATCH 088/431] Jam: much smarter preJam pass. --- pkg/hs-urbit/lib/Data/Noun/Jam.hs | 58 ++++--- pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 215 ++++++++++++++++++++++---- pkg/hs-urbit/package.yaml | 1 + 3 files changed, 218 insertions(+), 56 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam.hs b/pkg/hs-urbit/lib/Data/Noun/Jam.hs index 692099504..144454b23 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam.hs @@ -7,8 +7,9 @@ import Data.Bits import Control.Lens import Text.Printf -import Data.Map (Map) import Control.Monad (guard) +import Data.Map (Map) +import Text.Printf (printf) import Test.Tasty import Test.Tasty.TH @@ -169,11 +170,11 @@ cue buf = view _2 <$> go mempty 0 case (bitIdx i buf, bitIdx (i+1) buf) of (False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf) let r = Atom at - pure (1+wid, r, insertMap i r tbl) + pure (1+wid, r, trace (show ('c', i, r)) $ insertMap i r tbl) (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) let r = Cell lef rit - pure (2+lSz+rSz, r, insertMap i r tbl) + pure (2+lSz+rSz, r, trace (show ('c', i, r)) $ insertMap i r tbl) (True, True ) -> do Buf wid at <- rub (Cursor (i+2) buf) r <- lookup (fromIntegral at) tbl & \case Nothing -> error ("bad-ref-" <> show at) @@ -203,38 +204,45 @@ pills = [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 , 0x3170_c7c1, 0x93_c7c1, 0xa_72e0, 0x1bd5_b7dd_e080 ] -cueTest :: Maybe [Noun] -cueTest = traverse cue pills +-- cueTest :: Maybe [Noun] +-- cueTest = traverse cue pills -jamTest :: Maybe [Atom] -jamTest = fmap jam <$> cueTest +-- jamTest :: Maybe [Atom] +-- jamTest = fmap jam <$> cueTest -prop_fastMatSlow :: Atom -> Bool -prop_fastMatSlow a = jam (Atom a) == Fast.jam (Atom a) +-- prop_fastMatSlow :: Atom -> Bool +-- prop_fastMatSlow a = jam (Atom a) == Fast.jam (Atom a) -prop_fastJamSlow :: Noun -> Bool -prop_fastJamSlow n = jam n == Fast.jam n +-- prop_fastJamSlow :: Noun -> Bool +-- prop_fastJamSlow n = jam n == Fast.jam n prop_fastJam :: Noun -> Bool prop_fastJam n = Just n == cue (Fast.jam n) -prop_jamCue :: Noun -> Bool -prop_jamCue n = Just n == cue (jam n) +-- prop_jamCue :: Noun -> Bool +-- prop_jamCue n = Just n == cue (jam n) -prop_matRub :: Atom -> Bool -prop_matRub atm = matSz==rubSz && rubRes==atm - where - Buf matSz matBuf = mat atm - Buf rubSz rubRes = fromMaybe mempty (rub $ Cursor 0 matBuf) +-- prop_matRub :: Atom -> Bool +-- prop_matRub atm = matSz==rubSz && rubRes==atm + -- where + -- Buf matSz matBuf = mat atm + -- Buf rubSz rubRes = fromMaybe mempty (rub $ Cursor 0 matBuf) -prop_jamCue' :: Noun -> Bool -prop_jamCue' n = Just n == cue' (jam' n) +-- prop_jamCue' :: Noun -> Bool +-- prop_jamCue' n = Just n == cue' (jam' n) -prop_matRub' :: Atom -> Bool -prop_matRub' atm = matSz==rubSz && rubRes==atm - where - Buf matSz matBuf = mat' atm - Buf rubSz rubRes = fromMaybe mempty (rub' $ Cursor 0 matBuf) +-- prop_matRub' :: Atom -> Bool +-- prop_matRub' atm = matSz==rubSz && rubRes==atm + -- where + -- Buf matSz matBuf = mat' atm + -- Buf rubSz rubRes = fromMaybe mempty (rub' $ Cursor 0 matBuf) main :: IO () main = $(defaultMainGenerator) + +matSz' :: Atom -> Int +matSz' a = length s - 1 + where + s :: String + s = printf "%b" $ fromIntegral @Atom @Integer $ jam $ Atom a + diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs index 4ed24265c..0242c7ffc 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs @@ -9,7 +9,7 @@ import GHC.Integer.GMP.Internals import Control.Lens (view, to, from, (&)) import Control.Monad (guard) -import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.), (.&.)) +import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.), (.&.)) import Data.Map (Map) import Data.Noun.Atom ( Atom(MkAtom), wordBitWidth, wordBitWidth# , atomBitWidth#, takeBitsWord ) @@ -24,6 +24,8 @@ import GHC.Int (Int(I#)) import GHC.Word (Word(W#)) import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Hashable as Hash +import qualified Data.Map as M import qualified Data.ByteString.Unsafe as BS import qualified Data.HashTable.IO as H import qualified Data.Vector.Primitive as VP @@ -57,13 +59,15 @@ newtype Put a = Put -------------------------------------------------------------------------------- -{-# INLINE insRef #-} -insRef :: Noun -> Word -> Put () -insRef n w = Put \tbl s -> PutResult s <$> H.insert tbl n w - {-# INLINE getRef #-} getRef :: Noun -> Put (Maybe Word) -getRef n = Put \tbl s -> PutResult s <$> H.lookup tbl n +getRef n = Put \tbl s -> do + pos <- pure (pos s) + traceM ("getRef: " <> show n <> " @" <> show pos) + res <- H.lookup tbl n + pure $ PutResult s $ case res of + Just w | w Just w + _ -> Nothing {- 1. Write the register to the output, and increment the output pointer. @@ -236,10 +240,10 @@ instance Monad Put where -------------------------------------------------------------------------------- -doPut :: Word -> Put () -> ByteString -doPut sz m = +doPut :: Map Noun Word -> Word -> Put () -> ByteString +doPut tbl sz m = unsafePerformIO $ do - tbl <- H.new + tbl <- H.fromListWithSizeHint (M.size tbl) (mapToList tbl) buf <- callocBytes (fromIntegral $ 4 * wordSz*8) _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) BS.unsafePackCStringFinalizer (castPtr buf) (2*byteSz) (free buf) @@ -263,7 +267,6 @@ writeNoun :: Noun -> Put () writeNoun n = do -- traceM "writeNoun" - p <- pos <$> getS mRef <- getRef n case (mRef, n) of @@ -272,9 +275,6 @@ writeNoun n = do (Just bk, Atom a) | bitWidth a <= wordBitWidth bk -> writeAtom a (Just bk, _) -> writeBackRef bk - when (mRef == Nothing) $ - insRef n p - {-# INLINE writeMat #-} writeMat :: Atom -> Put () writeMat 0 = do @@ -308,7 +308,8 @@ writeAtom a = do {-# INLINE writeBackRef #-} writeBackRef :: Word -> Put () writeBackRef a = do - -- traceM ("writeBackRef: " <> show a) + p <- pos <$> getS + traceM ("writeBackRef: " <> show a <> " @" <> show p) writeBit True writeBit True writeMat (toAtom a) @@ -316,13 +317,31 @@ writeBackRef a = do -------------------------------------------------------------------------------- jamBS :: Noun -> ByteString -jamBS n = doPut (fst $ preJam n) (writeNoun n) +jamBS n = trace (show $ sort $ swap <$> mapToList tbl) + $ doPut tbl sz (writeNoun n) + where (sz, tbl) = preJam n jam :: Noun -> Atom jam = view (to jamBS . from atomBS) -------------------------------------------------------------------------------- +{-# INLINE matSz #-} +matSz :: Atom -> Word +matSz a = W# (matSz# a) + +{-# INLINE matSz# #-} +matSz# :: Atom -> Word# +matSz# 0 = 1## +matSz# a = preW `plusWord#` preW `plusWord#` atmW + where + atmW = atomBitWidth# a + preW = wordBitWidth# atmW + +{-# INLINE refSz# #-} +refSz# :: Word# -> Word# +refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) + preJam :: Noun -> (Word, Map Noun Word) preJam = go 0 mempty where @@ -332,37 +351,171 @@ preJam = go 0 mempty go :: Word -> Map Noun Word -> Noun -> (Word, Map Noun Word) go off oldTbl noun = - let tbl = insertNoun noun off oldTbl in case lookup noun oldTbl of Nothing -> + let tbl = insertNoun noun off oldTbl in case noun of Atom atm -> - (1 + W# (matSz# atm), tbl) + (1 + matSz atm, tbl) Cell l r -> - let (lSz, tbl') = go (2+off) tbl l in + let (lSz, tbl') = go (2+off) tbl l in let (rSz, tbl'') = go (2+off+lSz) tbl' r in (2 + lSz + rSz, tbl'') Just (W# ref) -> let refSz = W# (wordBitWidth# ref) in case noun of Atom atm -> - let worSz = W# (matSz# atm) in + let worSz = matSz atm in if worSz > refSz then (2 + refSz, oldTbl) - else (1 + worSz, tbl) + else (1 + worSz, oldTbl) Cell _ _ -> (2 + refSz, oldTbl) - matSz# :: Atom -> Word# - matSz# 0 = 1## - matSz# a = preW `plusWord#` preW `plusWord#` atmW - where - atmW = atomBitWidth# a - preW = wordBitWidth# atmW - refSz# :: Word# -> Word# - refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) +-- Fast Pre-Jam ---------------------------------------------------------------- - nounSz# :: Noun -> Word# - nounSz# (Atom a) = 1## `plusWord#` (matSz# a) - nounSz# (Cell l r) = 2## `plusWord#` (nounSz# l) `plusWord#` (nounSz# r) +{- + An `SHN` is a noun and some pre-computed information. + + - `size` is the serialized size without backreferences, we use this + for fast equality checks. + - `jmSz` is the serialized size, we use this to allocate a buffer + at the end. + - `hash` is a precomputed noun hash. We use this to get better, + cheaper hashes for our hashtable. + - `noun` is the actual noun. +-} +data SHN = SHN + { size :: {-# UNPACK #-} !Word + , jmSz :: {-# UNPACK #-} !Word + , hash :: {-# UNPACK #-} !Int + , noun :: {-# UNPACK #-} !Noun + } + deriving (Show) + +instance Hashable SHN where + hash (SHN _ _ h _) = h + {-# INLINE hash #-} + hashWithSalt = defaultHashWithSalt + {-# INLINE hashWithSalt #-} + +instance Eq SHN where + x == y = (size x == size y) && (noun x == noun y) + +preJam' :: Noun -> IO (SHN, H.LinearHashTable Word Word) +preJam' top = do + nodes :: H.LinearHashTable SHN Word <- H.new + backs :: H.LinearHashTable Word Word <- H.new + + let goAtom :: Word -> Atom -> IO SHN + goAtom pos a@(MkAtom nat) = do + let atmSz = matSz a + let res = SHN (1+atmSz) (1+atmSz) (Hash.hash nat) (Atom a) + H.lookup nodes res >>= \case + Nothing -> do + H.insert nodes res pos + pure (traceShowId res) + Just bak -> do + let refSz = matSz (toAtom bak) + if refSz < atmSz + then do H.insert backs pos bak + pure (traceShowId (res{jmSz=2+refSz})) + else pure (traceShowId res) + + goCell :: Word -> Noun -> Noun -> IO SHN + goCell pos h t = do + SHN hSz hJmSz hHash _ <- go (pos+2) h + SHN tSz tJmSz tHash _ <- go (pos+2+hSz) t + let sz = 2+hSz+tSz + let jmSz = 2+hJmSz+tJmSz + let res = SHN sz jmSz (combine hHash tHash) (Cell h t) + H.lookup nodes res >>= \case + Nothing -> do + H.insert nodes res pos + pure (traceShowId res) + Just bak -> do + let refSz = matSz (toAtom bak) + H.insert backs pos bak + pure (traceShowId (res{jmSz=2+refSz})) + + go :: Word -> Noun -> IO SHN + go p (Atom a) = goAtom p a + go p (Cell h t) = goCell p h t + + res <- go 0 top + pure (res, backs) + +-- Stolen from Hashable Library ------------------------------------------------ + +{-# INLINE combine #-} +combine :: Int -> Int -> Int +combine h1 h2 = (h1 * 16777619) `xor` h2 + +{-# INLINE defaultHashWithSalt #-} +defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt salt x = salt `combine` Hash.hash x + + +{- + I suspect that hashing these big atoms recursively is going to be the bottleneck: + Unless you have a good hashing system. + Which we totally do in the nock runtime. + Checking the hash for the top-level node precomputes the hashes for + everything else, recursively. + This is really smart. + Maybe I could implement this as well? + But hashing traverses the whole structure. + So, now we have + 1. precompute hashes. + 2. precompute size and backref table. + 3. serialize + This seems excessive. + We insert into the backref table right away, but actually: + Backreferences can't exist until the whole node is processed. + + Which implies a smarter algorithm: + - Setup a atom dup table + atoms :: Hashtable BigNum Word + - Setup a cell dup table + cells :: Hashtable (Noun, Noun) Word + - Setup a backref table (map from dup. pos to orig. pos) + backs :: Hashtable Word Word + - go :: Noun -> ST s (Hash, Word) + - If atom, + - Compute size and hash + - Check atom table for backref + - If atom in `atoms` table: + - If backref smaller than atom + - Insert (pos, bak) into `backs` table. + - Return (backref size, atom hash) + - If backref not smaller than atom + - Return (atom size, atom hash) + - Otherwise: + - Insert atom into `atoms` table. + - Return (atom size, atom hash) + - If cell + - process head + - process tail + - produce size+hash from results + - Check cell table for backref + - If backref exists + - Insert `(pos, bak)` into `backs` table + - Return (backref size, cell hash) + - Else + - Return (cell size, cell hash) + + Then, to serialize: + - Allocate a buffer of `size` bits + - If current pos in `backs` table: + - Write `11` + - Write backref (mat) + - Otherwise: + - If Atom: + - Write `0` + - Write atom (mat) + - If Cell + - Write `10` + - Write head + - Write tail +-} diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 6bd1768a5..76346290c 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -21,6 +21,7 @@ dependencies: - flat - ghc-prim - hashable + - hashable - hashtables - http-client - http-types From a089cfea12c23ba7175e4feb0a407f56c5850da2 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 30 Jun 2019 20:12:25 -0700 Subject: [PATCH 089/431] Got this working except there is a mistake in my approach. I am traversing each subtree even if it will eventually become a back reference. While, traversing, I insert any backreferences that I find. However, if the enclosing noun is a backreference, then all of the backreferences found in subtrees will be invalid. --- pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 117 ++++++++++++++------------ 1 file changed, 63 insertions(+), 54 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs index 0242c7ffc..37688fee8 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs @@ -52,7 +52,7 @@ data PutResult a = PutResult {-# UNPACK #-} !S !a deriving Functor newtype Put a = Put - { runPut :: H.LinearHashTable Noun Word + { runPut :: H.LinearHashTable Word Word -> S -> IO (PutResult a) } @@ -60,14 +60,8 @@ newtype Put a = Put -------------------------------------------------------------------------------- {-# INLINE getRef #-} -getRef :: Noun -> Put (Maybe Word) -getRef n = Put \tbl s -> do - pos <- pure (pos s) - traceM ("getRef: " <> show n <> " @" <> show pos) - res <- H.lookup tbl n - pure $ PutResult s $ case res of - Just w | w Just w - _ -> Nothing +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. @@ -110,15 +104,15 @@ putS s = Put $ \tbl _ -> pure (PutResult s ()) {-# INLINE writeBit #-} writeBit :: Bool -> Put () writeBit b = Put $ \tbl s@S{..} -> do - -- traceM ("writeBit: " <> show b) - let s' = s { reg = (if b then setBit else clearBit) reg off - , off = (off + 1) `mod` 64 - , pos = pos + 1 - } + traceM ("writeBit: " <> show b) + let s' = s { reg = (if b then setBit else clearBit) reg off + , off = (off + 1) `mod` 64 + , pos = pos + 1 + } - if off == 63 - then runPut (flush >> setRegOff 0 0) tbl s' - else pure $ PutResult s' () + if off == 63 + then runPut (flush >> setRegOff 0 0) tbl s' + else pure $ PutResult s' () {- To write a 64bit word: @@ -130,7 +124,7 @@ writeBit b = Put $ \tbl s@S{..} -> do {-# INLINE writeWord #-} writeWord :: Word -> Put () writeWord wor = do - -- traceM ("writeWord: " <> show wor) + traceM ("writeWord: " <> show wor) S{..} <- getS setReg (reg .|. shiftL wor off) flush @@ -155,7 +149,7 @@ writeBitsFromWord :: Int -> Word -> Put () writeBitsFromWord wid wor = do wor <- pure (takeBitsWord wid wor) - -- traceM ("writeBitsFromWord: " <> show wid <> ", " <> show wor) + traceM ("writeBitsFromWord: " <> show wid <> ", " <> show wor) oldSt <- getS @@ -175,7 +169,7 @@ writeBitsFromWord wid wor = do {-# INLINE writeAtomWord# #-} writeAtomWord# :: Word# -> Put () writeAtomWord# w = do - -- traceM "writeAtomWord" + traceM "writeAtomWord" writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) {-# INLINE writeAtomWord #-} @@ -240,10 +234,12 @@ instance Monad Put where -------------------------------------------------------------------------------- -doPut :: Map Noun Word -> Word -> Put () -> ByteString +doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString doPut tbl sz m = unsafePerformIO $ do - tbl <- H.fromListWithSizeHint (M.size tbl) (mapToList tbl) + traceM "" + H.toList tbl >>= traceM . show . sort + traceM "" buf <- callocBytes (fromIntegral $ 4 * wordSz*8) _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) BS.unsafePackCStringFinalizer (castPtr buf) (2*byteSz) (free buf) @@ -265,15 +261,28 @@ doPut tbl sz m = -} writeNoun :: Noun -> Put () writeNoun n = do - -- traceM "writeNoun" + p <- pos <$> getS + traceM ("writeNoun: " <> show p) + traceM ("\t" <> show n) - mRef <- getRef n + -- getRef >>= \case + -- Nothing -> pure () + -- Just rf -> do + -- p <- pos <$> getS + -- traceM ("backref: " <> show p <> "-> " <> show rf) - case (mRef, n) of - (Nothing, Atom a) -> writeAtom a - (Nothing, Cell h t) -> writeCell h t - (Just bk, Atom a) | bitWidth a <= wordBitWidth bk -> writeAtom a - (Just bk, _) -> writeBackRef bk + -- case n of + -- Atom a -> writeAtom a + -- Cell h t -> writeCell h t + + getRef >>= \case + Just bk -> do + p <- pos <$> getS + traceM $ mconcat (force ["backref: (", show p, " -> ", show bk, ")\n\t", show n]) + writeBackRef bk + Nothing -> case n of + Atom a -> writeAtom a + Cell h t -> writeCell h t {-# INLINE writeMat #-} writeMat :: Atom -> Put () @@ -318,8 +327,10 @@ writeBackRef a = do jamBS :: Noun -> ByteString jamBS n = trace (show $ sort $ swap <$> mapToList tbl) - $ doPut tbl sz (writeNoun n) +-- $ trace (show $ sort $ swap <$> unsafePerformIO (H.toList ht)) + $ doPut ht (size shn) (writeNoun n) where (sz, tbl) = preJam n + (shn, ht) = unsafePerformIO (preJam' n) jam :: Noun -> Atom jam = view (to jamBS . from atomBS) @@ -403,6 +414,10 @@ instance Hashable SHN where instance Eq SHN where x == y = (size x == size y) && (noun x == noun y) +{- + This is slightly different that the stock `jam`, since we use + backreferences if-and-only-if they save space. +-} preJam' :: Noun -> IO (SHN, H.LinearHashTable Word Word) preJam' top = do nodes :: H.LinearHashTable SHN Word <- H.new @@ -410,38 +425,32 @@ preJam' top = do let goAtom :: Word -> Atom -> IO SHN goAtom pos a@(MkAtom nat) = do - let atmSz = matSz a - let res = SHN (1+atmSz) (1+atmSz) (Hash.hash nat) (Atom a) - H.lookup nodes res >>= \case - Nothing -> do - H.insert nodes res pos - pure (traceShowId res) - Just bak -> do - let refSz = matSz (toAtom bak) - if refSz < atmSz - then do H.insert backs pos bak - pure (traceShowId (res{jmSz=2+refSz})) - else pure (traceShowId res) + let atmSz = 1 + matSz a + pure $ SHN atmSz atmSz (Hash.hash nat) (Atom a) goCell :: Word -> Noun -> Noun -> IO SHN goCell pos h t = do SHN hSz hJmSz hHash _ <- go (pos+2) h - SHN tSz tJmSz tHash _ <- go (pos+2+hSz) t + SHN tSz tJmSz tHash _ <- go (pos+2+hJmSz) t let sz = 2+hSz+tSz let jmSz = 2+hJmSz+tJmSz - let res = SHN sz jmSz (combine hHash tHash) (Cell h t) - H.lookup nodes res >>= \case - Nothing -> do - H.insert nodes res pos - pure (traceShowId res) - Just bak -> do - let refSz = matSz (toAtom bak) - H.insert backs pos bak - pure (traceShowId (res{jmSz=2+refSz})) + pure $ SHN sz jmSz (combine hHash tHash) (Cell h t) go :: Word -> Noun -> IO SHN - go p (Atom a) = goAtom p a - go p (Cell h t) = goCell p h t + go p n = do + res <- case n of Atom a -> goAtom p a + Cell h t -> goCell p h t + + H.lookup nodes res >>= \case + Nothing -> do + H.insert nodes res p + pure res + Just bak -> do + let refSz = 2 + matSz (toAtom bak) + if (refSz < jmSz res) + then do H.insert backs p bak + pure (res { jmSz = refSz }) + else pure res res <- go 0 top pure (res, backs) From 3a406f3860f49dbedbf7b2803f45ec160eb2e405 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 30 Jun 2019 21:09:42 -0700 Subject: [PATCH 090/431] Reworked the algorithm, and implemented it. It works! --- pkg/hs-urbit/lib/Data/Noun/Atom.hs | 4 +- pkg/hs-urbit/lib/Data/Noun/Jam.hs | 16 +++-- pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 96 +++++++++++++++++++++++---- 3 files changed, 94 insertions(+), 22 deletions(-) diff --git a/pkg/hs-urbit/lib/Data/Noun/Atom.hs b/pkg/hs-urbit/lib/Data/Noun/Atom.hs index a78e76f89..b87fb907b 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Atom.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Atom.hs @@ -21,7 +21,9 @@ import Data.Hashable (Hashable) -------------------------------------------------------------------------------- newtype Atom = MkAtom { unAtom :: Natural } - deriving newtype (Eq, Ord, Num, Bits, Enum, Real, Integral, Flat, Hashable, NFData) + deriving newtype ( Eq, Ord, Num, Bits, Enum, Real, Integral, Flat, Hashable + , NFData + ) instance Show Atom where show (MkAtom a) = show a diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam.hs b/pkg/hs-urbit/lib/Data/Noun/Jam.hs index 144454b23..06f397c43 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam.hs @@ -140,7 +140,7 @@ jam = toAtom . fst . go 0 mempty go off oldTbl noun = let tbl = insertNoun noun off oldTbl in case (lookup noun oldTbl, noun) of - (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) -> + (Just ref, Atom atm) | bitWidth atm <= (1+bitWidth (toAtom ref)) -> (Buf (1+sz) (shiftL res 1), tbl) where Buf sz res = mat atm (Just ref, _) -> @@ -170,11 +170,11 @@ cue buf = view _2 <$> go mempty 0 case (bitIdx i buf, bitIdx (i+1) buf) of (False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf) let r = Atom at - pure (1+wid, r, trace (show ('c', i, r)) $ insertMap i r tbl) + pure (1+wid, r, insertMap i r tbl) (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) let r = Cell lef rit - pure (2+lSz+rSz, r, trace (show ('c', i, r)) $ insertMap i r tbl) + pure (2+lSz+rSz, r, insertMap i r tbl) (True, True ) -> do Buf wid at <- rub (Cursor (i+2) buf) r <- lookup (fromIntegral at) tbl & \case Nothing -> error ("bad-ref-" <> show at) @@ -210,11 +210,13 @@ pills = [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 -- jamTest :: Maybe [Atom] -- jamTest = fmap jam <$> cueTest --- prop_fastMatSlow :: Atom -> Bool --- prop_fastMatSlow a = jam (Atom a) == Fast.jam (Atom a) +prop_fastMatSlow :: Atom -> Bool +prop_fastMatSlow a = jam (Atom a) == Fast.jam (Atom a) --- prop_fastJamSlow :: Noun -> Bool --- prop_fastJamSlow n = jam n == Fast.jam n +prop_fastJamSlow :: Noun -> Bool +prop_fastJamSlow n = x == y || (bitWidth y <= bitWidth x && cue y == cue x) + where x = jam n + y = Fast.jam n prop_fastJam :: Noun -> Bool prop_fastJam n = Just n == cue (Fast.jam n) diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs index 37688fee8..bf25f34e5 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs @@ -2,7 +2,7 @@ module Data.Noun.Jam.Put where -import ClassyPrelude +import ClassyPrelude hiding (hash) import GHC.Prim import GHC.Natural import GHC.Integer.GMP.Internals @@ -104,7 +104,7 @@ putS s = Put $ \tbl _ -> pure (PutResult s ()) {-# INLINE writeBit #-} writeBit :: Bool -> Put () writeBit b = Put $ \tbl s@S{..} -> do - traceM ("writeBit: " <> show b) + -- traceM ("writeBit: " <> show b) let s' = s { reg = (if b then setBit else clearBit) reg off , off = (off + 1) `mod` 64 , pos = pos + 1 @@ -124,7 +124,7 @@ writeBit b = Put $ \tbl s@S{..} -> do {-# INLINE writeWord #-} writeWord :: Word -> Put () writeWord wor = do - traceM ("writeWord: " <> show wor) + -- traceM ("writeWord: " <> show wor) S{..} <- getS setReg (reg .|. shiftL wor off) flush @@ -149,7 +149,7 @@ writeBitsFromWord :: Int -> Word -> Put () writeBitsFromWord wid wor = do wor <- pure (takeBitsWord wid wor) - traceM ("writeBitsFromWord: " <> show wid <> ", " <> show wor) + -- traceM ("writeBitsFromWord: " <> show wid <> ", " <> show wor) oldSt <- getS @@ -169,7 +169,7 @@ writeBitsFromWord wid wor = do {-# INLINE writeAtomWord# #-} writeAtomWord# :: Word# -> Put () writeAtomWord# w = do - traceM "writeAtomWord" + -- traceM "writeAtomWord" writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) {-# INLINE writeAtomWord #-} @@ -237,9 +237,9 @@ instance Monad Put where doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString doPut tbl sz m = unsafePerformIO $ do - traceM "" - H.toList tbl >>= traceM . show . sort - traceM "" + -- traceM "" + -- H.toList tbl >>= traceM . show . sort + -- traceM "" buf <- callocBytes (fromIntegral $ 4 * wordSz*8) _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) BS.unsafePackCStringFinalizer (castPtr buf) (2*byteSz) (free buf) @@ -262,8 +262,8 @@ doPut tbl sz m = writeNoun :: Noun -> Put () writeNoun n = do p <- pos <$> getS - traceM ("writeNoun: " <> show p) - traceM ("\t" <> show n) + -- traceM ("writeNoun: " <> show p) + -- traceM ("\t" <> show n) -- getRef >>= \case -- Nothing -> pure () @@ -278,7 +278,7 @@ writeNoun n = do getRef >>= \case Just bk -> do p <- pos <$> getS - traceM $ mconcat (force ["backref: (", show p, " -> ", show bk, ")\n\t", show n]) + -- traceM $ mconcat (force ["backref: (", show p, " -> ", show bk, ")\n\t", show n]) writeBackRef bk Nothing -> case n of Atom a -> writeAtom a @@ -318,7 +318,7 @@ writeAtom a = do writeBackRef :: Word -> Put () writeBackRef a = do p <- pos <$> getS - traceM ("writeBackRef: " <> show a <> " @" <> show p) + -- traceM ("writeBackRef: " <> show a <> " @" <> show p) writeBit True writeBit True writeMat (toAtom a) @@ -326,11 +326,12 @@ writeBackRef a = do -------------------------------------------------------------------------------- jamBS :: Noun -> ByteString -jamBS n = trace (show $ sort $ swap <$> mapToList tbl) +jamBS n = -- trace (show $ sort $ swap <$> mapToList tbl) -- $ trace (show $ sort $ swap <$> unsafePerformIO (H.toList ht)) - $ doPut ht (size shn) (writeNoun n) + doPut bt sz' (writeNoun n) where (sz, tbl) = preJam n (shn, ht) = unsafePerformIO (preJam' n) + (sz', bt) = unsafePerformIO (compress $ toBigNoun n) jam :: Noun -> Atom jam = view (to jamBS . from atomBS) @@ -384,6 +385,73 @@ preJam = go 0 mempty (2 + refSz, oldTbl) +-- Nouns with pre-computed size and hash --------------------------------------- + +data BigNoun + = BigCell { bSize :: {-# UNPACK #-} !Word + , bHash :: {-# UNPACK #-} !Int + , bHead :: BigNoun + , bTail :: BigNoun + } + | BigAtom { bSize :: {-# UNPACK #-} !Word + , bHash :: {-# UNPACK #-} !Int + , bAtom :: {-# UNPACK #-} !Atom + } + deriving (Show) + +instance Hashable BigNoun where + hash = bHash + {-# INLINE hash #-} + hashWithSalt = defaultHashWithSalt + {-# INLINE hashWithSalt #-} + +instance Eq BigNoun where + BigAtom s1 _ a1 == BigAtom s2 _ a2 = s1==s2 && a1==a2 + BigCell s1 _ h1 t1 == BigCell s2 _ h2 t2 = s1==s2 && h1==h2 && t1==t2 + _ == _ = False + +toBigNoun :: Noun -> BigNoun +toBigNoun (Atom a) = BigAtom (1 + matSz a) (Hash.hash a) a +toBigNoun (Cell h t) = BigCell siz has hed tel + where + hed = toBigNoun h + tel = toBigNoun t + siz = 2 + bSize hed + bSize tel + has = fromIntegral siz `combine` bHash hed `combine` bHash tel + + +-- Yet Another Fast Pre Jam ---------------------------------------------------- + +compress :: BigNoun -> IO (Word, H.LinearHashTable Word Word) +compress top = do + nodes :: H.LinearHashTable BigNoun Word <- H.new + backs :: H.LinearHashTable Word Word <- H.new + + let proc :: Word -> BigNoun -> IO Word + proc pos = \case + BigAtom _ _ a -> pure (1 + matSz a) + BigCell _ _ h t -> do + hSz <- go (pos+2) h + tSz <- go (pos+2+hSz) t + pure (2+hSz+tSz) + + go :: Word -> BigNoun -> IO Word + go p inp = do + H.lookup nodes inp >>= \case + Nothing -> do + -- traceM ("inserting " <> show inp) + H.insert nodes inp p + proc p inp + Just bak -> do + -- traceM ("found backref for " <> show inp) + let refSz = 2 + matSz (toAtom bak) + if (refSz < bSize inp) + then H.insert backs p bak $> refSz + else proc p inp + + res <- go 0 top + pure (res, backs) + -- Fast Pre-Jam ---------------------------------------------------------------- {- From af1055b0f61278887f82d13631ceb561aaeb5b4c Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 30 Jun 2019 21:47:21 -0700 Subject: [PATCH 091/431] Progress towards being able to replay whole event log. --- pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 41 +++++++++------------------ pkg/hs-urbit/lib/Data/Noun/Lens.hs | 32 +++++++++++++++++++++ pkg/hs-urbit/lib/Data/Noun/Poet.hs | 6 ++++ pkg/hs-urbit/lib/Urbit/Time.hs | 7 +++-- pkg/hs-urbit/lib/Vere/Log.hs | 1 + pkg/hs-urbit/lib/Vere/Pier/Types.hs | 18 ++++++------ pkg/hs-urbit/lib/Vere/Serf.hs | 17 ++++++++--- pkg/hs-vere/app/uterm/Main.hs | 1 + 8 files changed, 81 insertions(+), 42 deletions(-) create mode 100644 pkg/hs-urbit/lib/Data/Noun/Lens.hs diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs index bf25f34e5..e6db84918 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs @@ -261,28 +261,10 @@ doPut tbl sz m = -} writeNoun :: Noun -> Put () writeNoun n = do - p <- pos <$> getS - -- traceM ("writeNoun: " <> show p) - -- traceM ("\t" <> show n) - - -- getRef >>= \case - -- Nothing -> pure () - -- Just rf -> do - -- p <- pos <$> getS - -- traceM ("backref: " <> show p <> "-> " <> show rf) - - -- case n of - -- Atom a -> writeAtom a - -- Cell h t -> writeCell h t - getRef >>= \case - Just bk -> do - p <- pos <$> getS - -- traceM $ mconcat (force ["backref: (", show p, " -> ", show bk, ")\n\t", show n]) - writeBackRef bk - Nothing -> case n of - Atom a -> writeAtom a - Cell h t -> writeCell h t + Just bk -> writeBackRef bk + Nothing -> case n of Atom a -> writeAtom a + Cell h t -> writeCell h t {-# INLINE writeMat #-} writeMat :: Atom -> Put () @@ -409,19 +391,24 @@ instance Eq BigNoun where BigAtom s1 _ a1 == BigAtom s2 _ a2 = s1==s2 && a1==a2 BigCell s1 _ h1 t1 == BigCell s2 _ h2 t2 = s1==s2 && h1==h2 && t1==t2 _ == _ = False + {-# INLINE (==) #-} +{-# INLINE toBigNoun #-} toBigNoun :: Noun -> BigNoun -toBigNoun (Atom a) = BigAtom (1 + matSz a) (Hash.hash a) a -toBigNoun (Cell h t) = BigCell siz has hed tel +toBigNoun = go where - hed = toBigNoun h - tel = toBigNoun t - siz = 2 + bSize hed + bSize tel - has = fromIntegral siz `combine` bHash hed `combine` bHash tel + go (Atom a) = BigAtom (1 + matSz a) (Hash.hash a) a + go (Cell h t) = BigCell siz has hed tel + where + hed = toBigNoun h + tel = toBigNoun t + siz = 2 + bSize hed + bSize tel + has = fromIntegral siz `combine` bHash hed `combine` bHash tel -- Yet Another Fast Pre Jam ---------------------------------------------------- +{-# INLINE compress #-} compress :: BigNoun -> IO (Word, H.LinearHashTable Word Word) compress top = do nodes :: H.LinearHashTable BigNoun Word <- H.new diff --git a/pkg/hs-urbit/lib/Data/Noun/Lens.hs b/pkg/hs-urbit/lib/Data/Noun/Lens.hs new file mode 100644 index 000000000..12f7933b8 --- /dev/null +++ b/pkg/hs-urbit/lib/Data/Noun/Lens.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MagicHash #-} + +module Data.Noun.Lens where + +import ClassyPrelude +import Data.Noun.Pill +import Data.Noun +import Data.Noun.Atom +import Control.Lens +import Data.Noun.Jam.Put (jam, jamBS) +import Data.Noun.Jam (cue) + +-------------------------------------------------------------------------------- + +_CueBytes :: Prism' ByteString Noun +_CueBytes = prism' jamBS unJamBS + where unJamBS = preview (from pillBS . from pill . _Cue) + +_Cue :: Prism' Atom Noun +_Cue = prism' jam cue + +loadNoun :: FilePath -> IO (Maybe Noun) +loadNoun = fmap (preview $ from pillBS . from pill . _Cue) . readFile + +dumpJam :: FilePath -> Noun -> IO () +dumpJam fp = writeFile fp . view (re _Cue . pill . pillBS) + +tryCuePill :: PillFile -> IO () +tryCuePill pill = + loadNoun (show pill) >>= \case Nothing -> print "nil" + Just (Atom _) -> print "atom" + _ -> print "cell" diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Data/Noun/Poet.hs index 11509cd4f..1e514c08b 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Poet.hs @@ -403,6 +403,12 @@ instance FromNoun Atom where instance ToNoun Natural where toNoun = toNoun . MkAtom instance FromNoun Natural where parseNoun = fmap unAtom . parseNoun +instance ToNoun Integer where + toNoun = toNoun . (fromIntegral :: Integer -> Natural) + +instance FromNoun Integer where + parseNoun = fmap ((fromIntegral :: Natural -> Integer) . unAtom) . parseNoun + -- Word Conversion ------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Urbit/Time.hs b/pkg/hs-urbit/lib/Urbit/Time.hs index 962b7c185..29dd5fb10 100644 --- a/pkg/hs-urbit/lib/Urbit/Time.hs +++ b/pkg/hs-urbit/lib/Urbit/Time.hs @@ -12,18 +12,19 @@ import Data.Time.Clock (DiffTime, UTCTime, picosecondsToDiffTime, diffTimeToPicoseconds) import Data.Time.Clock.System (SystemTime(..), getSystemTime, utcToSystemTime, systemToUTCTime) +import Data.Noun.Poet (FromNoun, ToNoun) -- Types ----------------------------------------------------------------------- newtype Gap = Gap { _fractoSecs :: Integer } - deriving (Eq, Ord, Show, Num) + deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun) newtype Unix = Unix { _sinceUnixEpoch :: Gap } - deriving (Eq, Ord, Show) + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) newtype Wen = Wen { _sinceUrbitEpoch :: Gap } - deriving (Eq, Ord, Show) + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) -- Lenses ---------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index 88b05bc98..1ab467e36 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -20,6 +20,7 @@ import Data.Noun import Data.Noun.Atom import Data.Noun.Jam import Data.Noun.Pill +import Data.Noun.Lens import Data.Void import Database.LMDB.Raw import Foreign.Ptr diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 5dae02855..47a216f34 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -39,14 +39,16 @@ data NewtEx = NE Word data Eff = HttpServer Server.Eff | HttpClient Client.Eff - | Behn Void - | Clay Void - | Boat Void - | Sync Void - | Newt Void - | Ames Void - | Init Void - | Term Void + | Init + | Doze (Maybe Wen) + | Form Noun + | Behn Noun + | Clay Noun + | Boat Noun + | Sync Noun + | Newt Noun + | Ames Noun + | Term Noun | Blit [Blit] | Hill [Term] | Turf (Maybe (PutDel, [Text])) -- TODO Unsure diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index e87164480..2f60ca531 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -6,7 +6,8 @@ import Data.Void import Data.Noun import Data.Noun.Atom -import Data.Noun.Jam +import Data.Noun.Jam hiding (jam) +import Data.Noun.Jam.Put (jam, jamBS) import Data.Noun.Poet import Data.Noun.Pill import Vere.Pier.Types @@ -161,8 +162,16 @@ sendAndRecv :: Serf -> EventId -> Atom -> IO SerfResp sendAndRecv w eventId event = do traceM ("sendAndRecv: " <> show eventId) - traceM (maybe "bad cue" showNoun $ cue event) - sendAtom w $ work eventId (Jam event) + + -- traceM ("") + -- traceM (maybe "bad cue" showNoun $ cue event) + -- traceM ("") + + traceM ("") + wEv <- evaluate $ force $ work eventId (Jam event) + traceM ("") + + sendAtom w wEv res <- loop traceM ("sendAndRecv.done " <> show res) pure res @@ -365,7 +374,7 @@ recvPlea w = do traceM ("recvPlea.cue " <> show (length $ a ^. atomBytes)) n <- fromJustExn (cue a) (BadPleaAtom a) traceM "recvPlea.doneCue" - p <- fromRightExn (fromNounErr n) (BadPleaNoun n) + p <- fromRightExn (fromNounErr n) (BadPleaNoun (trace (showNoun n) n)) traceM "recvPlea.done" diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index 01ca5e0f9..d398923c0 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/pkg/hs-vere/app/uterm/Main.hs @@ -3,6 +3,7 @@ module Main where import ClassyPrelude import Control.Lens import Data.Noun.Pill hiding (main) +import Data.Noun.Lens -------------------------------------------------------------------------------- From d0893ae23497dbdf59434e36fbbc3e8bd6f5d004 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Sun, 30 Jun 2019 21:55:45 -0700 Subject: [PATCH 092/431] Can now fully replay my fakezod's event log! --- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 32 +++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 47a216f34..b155a6e0c 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -39,19 +39,33 @@ data NewtEx = NE Word data Eff = HttpServer Server.Eff | HttpClient Client.Eff - | Init - | Doze (Maybe Wen) - | Form Noun - | Behn Noun - | Clay Noun - | Boat Noun - | Sync Noun - | Newt Noun | Ames Noun - | Term Noun + | Bbye Noun + | Behn Noun | Blit [Blit] + | Boat Noun + | Clay Noun + | Crud Noun + | Dirk Noun + | Doze (Maybe Wen) + | Ergo Noun + | Exit Noun + | Flog Noun + | Form Noun | Hill [Term] + | Init + | Logo Noun + | Mass Noun + | Newt Noun + | Ogre Noun + | Send [Blit] + | Sync Noun + | Term Noun + | Thou Noun | Turf (Maybe (PutDel, [Text])) -- TODO Unsure + | Vega Noun + | West Noun + | Woot Noun deriving (Eq, Ord, Show) newtype Path = Path [Knot] From 2d25c21528699c8aca923d5b184a655fc294a724 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 1 Jul 2019 19:43:10 -0700 Subject: [PATCH 093/431] Jam: Cleanup --- .../lib/Data/Noun/{Jam/Get.hs => Cue/Fast.hs} | 82 ++- pkg/hs-urbit/lib/Data/Noun/Jam.hs | 4 +- pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs | 499 +++++++++++---- pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs | 585 ------------------ pkg/hs-urbit/lib/Data/Noun/Lens.hs | 2 +- pkg/hs-urbit/lib/Vere/Serf.hs | 2 +- 6 files changed, 452 insertions(+), 722 deletions(-) rename pkg/hs-urbit/lib/Data/Noun/{Jam/Get.hs => Cue/Fast.hs} (78%) delete mode 100644 pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Get.hs b/pkg/hs-urbit/lib/Data/Noun/Cue/Fast.hs similarity index 78% rename from pkg/hs-urbit/lib/Data/Noun/Jam/Get.hs rename to pkg/hs-urbit/lib/Data/Noun/Cue/Fast.hs index c53874ba1..31e9e39cb 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Get.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Cue/Fast.hs @@ -1,7 +1,21 @@ -module Data.Noun.Jam.Get where +{-# LANGUAGE MagicHash #-} + +module Data.Noun.Cue.Fast where import ClassyPrelude +import ClassyPrelude +import Data.Noun +import Data.Noun.Atom +import Data.Noun.Poet +import Data.Bits hiding (Bits) +import Control.Lens +import Text.Printf +import GHC.Prim +import GHC.Word +import GHC.Natural +import Foreign.Ptr +import Foreign.Storable (peek) import Data.Noun (Noun) import Data.Bits (shiftR, (.|.), (.&.)) import Foreign.Ptr (Ptr, plusPtr, ptrToWordPtr) @@ -11,6 +25,11 @@ import Control.Monad (guard) import qualified Data.HashTable.IO as H +import Test.Tasty +import Test.Tasty.TH +import qualified Test.Tasty.QuickCheck as QC +import Test.QuickCheck hiding ((.&.)) + -- Types ----------------------------------------------------------------------- @@ -218,3 +237,64 @@ dWordBits n = do w <- peekWord advance n pure (takeLowBits n w) + + +-- Fast Cue -------------------------------------------------------------------- + +{- + Get the exponent-prefix of an atom: + + - Peek at the next word. + - Calculate the number of least-significant bits in that word (there's + a primitive for this). + - Advance by that number of bits. + - Return the number of bits +-} +dExp :: Get Word +dExp = do + W# w <- peekWord + let res = W# (ctz# w) + advance res + pure res + +dAtomLen :: Get Word +dAtomLen = do + e <- dExp + p <- dWordBits (e-1) + pure (2^e .|. p) + +dRef :: Get Word +dRef = dAtomLen >>= dWordBits + +dAtom :: Get Atom +dAtom = do + n <- dAtomLen + b <- dBits n + pure (bitsToAtom b) + +bitsToAtom :: Bits -> Atom +bitsToAtom = undefined + +dCell :: Get Noun +dCell = Cell <$> dNoun <*> dNoun + +{-| + Get a Noun. + + - Get a bit + - If it's zero, get an atom. + - Otherwise, get another bit. + - If it's zero, get a cell. + - If it's one, get an atom. +-} +dNoun :: Get Noun +dNoun = do + p <- getPos + + let yield r = insRef p r >> pure r + + dBit >>= \case + False -> (Atom <$> dAtom) >>= yield + True -> dBit >>= \case + False -> dCell >>= yield + True -> dRef >>= getRef diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam.hs b/pkg/hs-urbit/lib/Data/Noun/Jam.hs index 06f397c43..7f1004f0d 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam.hs @@ -16,8 +16,8 @@ import Test.Tasty.TH import Test.Tasty.QuickCheck as QC import Test.QuickCheck -import qualified Data.Noun.Jam.Put as Fast -import qualified Data.Noun.Pill as Pill +import qualified Data.Noun.Jam.Fast as Fast +import qualified Data.Noun.Pill as Pill -- Length-Encoded Atoms -------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs index fa71373a3..a5a339d9c 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs @@ -1,160 +1,395 @@ {-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} -module Data.Noun.Jam.Fast where +module Data.Noun.Jam.Fast (jam, jamBS) where -import ClassyPrelude -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Poet -import Data.Bits hiding (Bits) -import Control.Lens -import Text.Printf -import GHC.Prim -import GHC.Word -import GHC.Natural -import Foreign.Ptr -import Foreign.Storable (peek) -import Data.Noun.Jam.Get +import ClassyPrelude hiding (hash) -import Data.Map (Map) -import Control.Monad (guard) +import Control.Lens (view, to, from) +import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.)) +import Data.Noun.Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) +import Data.Noun.Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) +import Data.Noun (Noun(Atom, Cell)) +import Data.Noun.Pill (bigNatWords, atomBS) +import Data.Vector.Primitive ((!)) +import Foreign.Marshal.Alloc (callocBytes, free) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (poke) +import GHC.Integer.GMP.Internals (BigNat) +import GHC.Int (Int(I#)) +import GHC.Natural (Natural(NatS#, NatJ#)) +import GHC.Prim (Word#, plusWord#, word2Int#) +import GHC.Word (Word(W#)) +import System.IO.Unsafe (unsafePerformIO) -import Test.Tasty -import Test.Tasty.TH -import qualified Test.Tasty.QuickCheck as QC -import Test.QuickCheck hiding ((.&.)) - -import qualified Data.HashTable.IO as H +import qualified Data.ByteString.Unsafe as BS +import qualified Data.Hashable as Hash +import qualified Data.HashTable.IO as H +import qualified Data.Vector.Primitive as VP --- Pre-compute the bit-width of a jammed noun. --------------------------------- +-- Exports --------------------------------------------------------------------- -jamSz :: Noun -> Word -jamSz = fst . go 0 mempty +jamBS :: Noun -> ByteString +jamBS n = doPut bt sz (writeNoun n) where - insertNoun :: Noun -> Word -> Map Noun Word -> Map Noun Word - insertNoun n i tbl = lookup n tbl - & maybe tbl (const $ insertMap n i tbl) + (sz, bt) = unsafePerformIO (compress $ toBigNoun n) - go :: Word -> Map Noun Word -> Noun -> (Word, Map Noun Word) - go off oldTbl noun = - let tbl = insertNoun noun off oldTbl in - case lookup noun oldTbl of - Nothing -> - case noun of - Atom atm -> - (1 + W# (matSz# atm), tbl) - Cell l r -> - let (lSz, tbl) = go (2+off) tbl l in - let (rSz, tbl) = go (2+off+lSz) tbl r in - (2 + lSz + rSz, tbl) - Just (W# ref) -> - let refSz = W# (wordBitWidth# ref) in - case noun of - Atom atm -> - let worSz = W# (matSz# atm) in - if worSz > refSz - then (refSz, oldTbl) - else (1 + worSz, tbl) - Cell _ _ -> - (refSz, oldTbl) +jam :: Noun -> Atom +jam = view (to jamBS . from atomBS) - matSz# :: Atom -> Word# - matSz# 0 = 1## - matSz# a = preW `plusWord#` preW `plusWord#` atmW - where - atmW = atomBitWidth# a - preW = wordBitWidth# atmW - refSz# :: Word# -> Word# - refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) +-- Types ----------------------------------------------------------------------- - nounSz# :: Noun -> Word# - nounSz# (Atom a) = 1## `plusWord#` (matSz# a) - nounSz# (Cell l r) = 2## `plusWord#` (nounSz# l) `plusWord#` (nounSz# r) +{-| + The encoder state. + + - ptr: Pointer into the output buffer. + - reg: Next 64 bits of output, partially written. + - off: Number of bits already written into `reg` + - pos: Total number of bits written. +-} +data S = S + { ptr :: {-# UNPACK #-} !(Ptr Word) + , reg :: {-# UNPACK #-} !Word + , off :: {-# UNPACK #-} !Int + , pos :: {-# UNPACK #-} !Word + } deriving (Show,Eq,Ord) + +data PutResult a = PutResult {-# UNPACK #-} !S !a + deriving Functor + +newtype Put a = Put + { runPut :: H.LinearHashTable Word Word + -> S + -> IO (PutResult a) + } -------------------------------------------------------------------------------- -jamFast :: Noun -> Vector Word64 -jamFast n = undefined - -bitsToAtom :: Bits -> Atom -bitsToAtom = undefined - - --- Fast Cue -------------------------------------------------------------------- +{-# INLINE getRef #-} +getRef :: Put (Maybe Word) +getRef = Put \tbl s -> PutResult s <$> H.lookup tbl (pos s) {- - Get the exponent-prefix of an atom: - - - Peek at the next word. - - Calculate the number of least-significant bits in that word (there's - a primitive for this). - - Advance by that number of bits. - - Return the number of bits + 1. Write the register to the output, and increment the output pointer. -} -dExp :: Get Word -dExp = do - W# w <- peekWord - let res = W# (ctz# w) - advance res - pure res +{-# INLINE flush #-} +flush :: Put () +flush = Put $ \tbl s@S{..} -> do + poke ptr reg + pure $ PutResult (s { ptr = ptr `plusPtr` 8 }) () -dAtomLen :: Get Word -dAtomLen = do - e <- dExp - p <- dWordBits (e-1) - pure (2^e .|. p) +{-# INLINE update #-} +update :: (S -> S) -> Put () +update f = Put \tbl s@S{..} -> pure (PutResult (f s) ()) -dRef :: Get Word -dRef = dAtomLen >>= dWordBits +{-# INLINE setRegOff #-} +setRegOff :: Word -> Int -> Put () +setRegOff r o = update \s@S{..} -> (s {reg=r, off=o}) -dAtom :: Get Atom -dAtom = do - n <- dAtomLen - b <- dBits n - pure (bitsToAtom b) +{-# INLINE setReg #-} +setReg :: Word -> Put () +setReg r = update \s@S{..} -> (s { reg=r }) -dCell :: Get Noun -dCell = Cell <$> dNoun <*> dNoun +{-# INLINE getS #-} +getS :: Put S +getS = Put $ \tbl s -> pure (PutResult s s) -{-| - Get a Noun. - - - Get a bit - - If it's zero, get an atom. - - Otherwise, get another bit. - - If it's zero, get a cell. - - If it's one, get an atom. --} -dNoun :: Get Noun -dNoun = do - p <- getPos - - let yield r = insRef p r >> pure r - - dBit >>= \case - False -> (Atom <$> dAtom) >>= yield - True -> dBit >>= \case - False -> dCell >>= yield - True -> dRef >>= getRef +{-# INLINE putS #-} +putS :: S -> Put () +putS s = Put $ \tbl _ -> pure (PutResult s ()) {- - TODO Count leading zero bits. + To write a bit: - Read a 64 bit word from the buffer and get the number of leading - zeros in that word. This works as long as no atom is larger than - 2 zettabytes. - - - TODO Need to handle the edge-case where there are less than 64 bits - remaining in the buffer. Those extra bytes need to be zeros. One way - to handle this might be to add a zero word to the end of the buffer, - but that would require a re-alloc. Probably the right way is to - write new `peek` primitives that handle this case. - - - TODO Error out if we hit the end *and* the word is all zeros. - - Alright, let's pseudo-code this out: - - Grab the next 64 bits. Pill files are always LSB-first + | reg |= 1 << off + | off <- (off + 1) % 64 + | if (!off): + | buf[w++] <- reg + | reg <- 0 -} +{-# INLINE writeBit #-} +writeBit :: Bool -> Put () +writeBit b = Put $ \tbl s@S{..} -> do + let s' = s { reg = (if b then setBit else clearBit) reg off + , off = (off + 1) `mod` 64 + , pos = pos + 1 + } + + if off == 63 + then runPut (flush >> setRegOff 0 0) tbl s' + else pure $ PutResult s' () + +{- + To write a 64bit word: + + | reg |= w << off + | buf[bufI++] = reg + | reg = w >> (64 - off) +-} +{-# INLINE writeWord #-} +writeWord :: Word -> Put () +writeWord wor = do + S{..} <- getS + setReg (reg .|. shiftL wor off) + flush + update \s -> s { pos = 64 + pos + , reg = shiftR wor (64 - off) + } + +{- + To write some bits (< 64) from a word: + + | wor = takeBits(wid, wor) + | reg = reg .|. (wor << off) + | off = (off + wid) % 64 + | + | if (off + wid >= 64) + | buf[w] = x + | reg = wor >> (wid - off) +-} +{-# INLINE writeBitsFromWord #-} +writeBitsFromWord :: Int -> Word -> Put () +writeBitsFromWord wid wor = do + wor <- pure (takeBitsWord wid wor) + + oldSt <- getS + + let newSt = oldSt { reg = reg oldSt .|. shiftL wor (off oldSt) + , off = (off oldSt + wid) `mod` 64 + , pos = fromIntegral wid + pos oldSt + } + + putS newSt + + when (wid + off oldSt >= 64) $ do + flush + setReg (shiftR wor (wid - off newSt)) +{- + Write all of the the signficant bits of a direct atom. +-} +{-# INLINE writeAtomWord# #-} +writeAtomWord# :: Word# -> Put () +writeAtomWord# w = do + writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) + +{-# INLINE writeAtomWord #-} +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. +-} +{-# INLINE writeAtomBigNat #-} +writeAtomBigNat :: BigNat -> Put () +writeAtomBigNat (view bigNatWords -> words) = do + let lastIdx = VP.length words - 1 + for_ [0..(lastIdx-1)] \i -> + writeWord (words ! i) + writeAtomWord (words ! lastIdx) + +{-# INLINE writeAtomBits #-} +writeAtomBits :: Atom -> Put () +writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd + MkAtom (NatJ# bn) -> writeAtomBigNat bn + + +-- Put Instances --------------------------------------------------------------- + +instance Functor Put where + fmap f g = Put $ \tbl s -> do + PutResult s' a <- runPut g tbl s + pure $ PutResult s' (f a) + {-# INLINE fmap #-} + +instance Applicative Put where + pure x = Put (\_ s -> return $ PutResult s x) + {-# INLINE pure #-} + + Put f <*> Put g = Put $ \tbl s1 -> do + PutResult s2 f' <- f tbl s1 + PutResult s3 g' <- g tbl s2 + return $ PutResult s3 (f' g') + {-# INLINE (<*>) #-} + + Put f *> Put g = Put $ \tbl s1 -> do + PutResult s2 _ <- f tbl s1 + g tbl s2 + {-# INLINE (*>) #-} + +instance Monad Put where + return = pure + {-# INLINE return #-} + + (>>) = (*>) + {-# INLINE (>>) #-} + + Put x >>= f = Put $ \tbl s -> do + PutResult s' x' <- x tbl s + runPut (f x') tbl s' + {-# INLINE (>>=) #-} + + +-------------------------------------------------------------------------------- + +doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString +doPut tbl sz m = + unsafePerformIO $ do + buf <- callocBytes (fromIntegral (wordSz*8)) + _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) + BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf) + where + wordSz = fromIntegral (sz `divUp` 64) + byteSz = fromIntegral (sz `divUp` 8) + divUp = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1) + + mbFlush :: Put () + mbFlush = do + shouldFlush <- (/= 0) . off <$> getS + when shouldFlush flush + + +-------------------------------------------------------------------------------- + +{- + TODO Handle back references +-} +writeNoun :: Noun -> Put () +writeNoun n = + getRef >>= \case + Just bk -> writeBackRef bk + Nothing -> case n of Atom a -> writeAtom a + Cell h t -> writeCell h t + +{-# INLINE writeMat #-} +writeMat :: Atom -> Put () +writeMat 0 = writeBit True +writeMat atm = do + writeBitsFromWord (preWid+1) (shiftL 1 preWid) + writeBitsFromWord (preWid-1) atmWid + writeAtomBits atm + where + atmWid = bitWidth atm + preWid = fromIntegral (wordBitWidth atmWid) + +{-# INLINE writeCell #-} +writeCell :: Noun -> Noun -> Put () +writeCell h t = do + writeBit True + writeBit False + writeNoun h + writeNoun t + +{-# INLINE writeAtom #-} +writeAtom :: Atom -> Put () +writeAtom a = do + writeBit False + writeMat a + +{-# INLINE writeBackRef #-} +writeBackRef :: Word -> Put () +writeBackRef a = do + p <- pos <$> getS + writeBit True + writeBit True + writeMat (toAtom a) + + +-- Compute Hashes and Jam Size (with no backrefs) ------------------------------ + +data BigNoun + = BigCell { bSize :: {-# UNPACK #-} !Word + , bHash :: {-# UNPACK #-} !Int + , bHead :: BigNoun + , bTail :: BigNoun + } + | BigAtom { bSize :: {-# UNPACK #-} !Word + , bHash :: {-# UNPACK #-} !Int + , bAtom :: {-# UNPACK #-} !Atom + } + deriving (Show) + +instance Hashable BigNoun where + hash = bHash + {-# INLINE hash #-} + hashWithSalt = defaultHashWithSalt + {-# INLINE hashWithSalt #-} + +instance Eq BigNoun where + BigAtom s1 _ a1 == BigAtom s2 _ a2 = s1==s2 && a1==a2 + BigCell s1 _ h1 t1 == BigCell s2 _ h2 t2 = s1==s2 && h1==h2 && t1==t2 + _ == _ = False + {-# INLINE (==) #-} + +{-# INLINE toBigNoun #-} +toBigNoun :: Noun -> BigNoun +toBigNoun = go + where + go (Atom a) = BigAtom (1 + matSz a) (Hash.hash a) a + go (Cell h t) = BigCell siz has hed tel + where + hed = toBigNoun h + tel = toBigNoun t + siz = 2 + bSize hed + bSize tel + has = fromIntegral siz `combine` bHash hed `combine` bHash tel + + +-- Calculate Jam Size and Backrefs --------------------------------------------- + +{-# INLINE matSz #-} +matSz :: Atom -> Word +matSz a = W# (matSz# a) + +{-# INLINE matSz# #-} +matSz# :: Atom -> Word# +matSz# 0 = 1## +matSz# a = preW `plusWord#` preW `plusWord#` atmW + where + atmW = atomBitWidth# a + preW = wordBitWidth# atmW + +{-# INLINE refSz# #-} +refSz# :: Word# -> Word# +refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) + +compress :: BigNoun -> IO (Word, H.LinearHashTable Word Word) +compress top = do + nodes :: H.LinearHashTable BigNoun Word <- H.new + backs :: H.LinearHashTable Word Word <- H.new + + let proc :: Word -> BigNoun -> IO Word + proc pos = \case + BigAtom _ _ a -> pure (1 + matSz a) + BigCell _ _ h t -> do + hSz <- go (pos+2) h + tSz <- go (pos+2+hSz) t + pure (2+hSz+tSz) + + go :: Word -> BigNoun -> IO Word + go p inp = do + H.lookup nodes inp >>= \case + Nothing -> do + H.insert nodes inp p + proc p inp + Just bak@(W# bakRaw) -> do + let refSz = W# (refSz# bakRaw) + if (refSz < bSize inp) + then H.insert backs p bak $> refSz + else proc p inp + + res <- go 0 top + pure (res, backs) + + +-- Stolen from Hashable Library ------------------------------------------------ + +{-# INLINE combine #-} +combine :: Int -> Int -> Int +combine h1 h2 = (h1 * 16777619) `xor` h2 + +{-# INLINE defaultHashWithSalt #-} +defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt salt x = salt `combine` Hash.hash x diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs b/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs deleted file mode 100644 index e6db84918..000000000 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Put.hs +++ /dev/null @@ -1,585 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -module Data.Noun.Jam.Put where - -import ClassyPrelude hiding (hash) -import GHC.Prim -import GHC.Natural -import GHC.Integer.GMP.Internals - -import Control.Lens (view, to, from, (&)) -import Control.Monad (guard) -import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.), (.&.)) -import Data.Map (Map) -import Data.Noun.Atom ( Atom(MkAtom), wordBitWidth, wordBitWidth# - , atomBitWidth#, takeBitsWord ) -import Data.Noun.Atom (toAtom, takeBits, bitWidth) -import Data.Noun (Noun(Atom, Cell)) -import Data.Noun.Pill (bigNatWords, atomBS) -import Data.Vector.Primitive ((!)) -import Foreign.Marshal.Alloc (callocBytes, free) -import Foreign.Ptr (Ptr, castPtr, plusPtr, ptrToWordPtr) -import Foreign.Storable (peek, poke) -import GHC.Int (Int(I#)) -import GHC.Word (Word(W#)) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Data.Hashable as Hash -import qualified Data.Map as M -import qualified Data.ByteString.Unsafe as BS -import qualified Data.HashTable.IO as H -import qualified Data.Vector.Primitive as VP - - --- Types ----------------------------------------------------------------------- - -{-| - The encoder state. - - - ptr: Pointer into the output buffer. - - reg: Next 64 bits of output, partially written. - - off: Number of bits already written into `reg` - - pos: Total number of bits written. --} -data S = S - { ptr :: {-# UNPACK #-} !(Ptr Word) - , reg :: {-# UNPACK #-} !Word - , off :: {-# UNPACK #-} !Int - , pos :: {-# UNPACK #-} !Word - } deriving (Show,Eq,Ord) - -data PutResult a = PutResult {-# UNPACK #-} !S !a - deriving Functor - -newtype Put a = Put - { runPut :: H.LinearHashTable Word Word - -> S - -> IO (PutResult a) - } - --------------------------------------------------------------------------------- - -{-# INLINE getRef #-} -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 #-} -flush :: Put () -flush = Put $ \tbl s@S{..} -> do - poke ptr reg - pure $ PutResult (s { ptr = ptr `plusPtr` 8 }) () - -{-# INLINE update #-} -update :: (S -> S) -> Put () -update f = Put \tbl s@S{..} -> pure (PutResult (f s) ()) - -{-# INLINE setRegOff #-} -setRegOff :: Word -> Int -> Put () -setRegOff r o = update \s@S{..} -> (s {reg=r, off=o}) - -{-# INLINE setReg #-} -setReg :: Word -> Put () -setReg r = update \s@S{..} -> (s { reg=r }) - -{-# INLINE getS #-} -getS :: Put S -getS = Put $ \tbl s -> pure (PutResult s s) - -{-# INLINE putS #-} -putS :: S -> Put () -putS s = Put $ \tbl _ -> pure (PutResult s ()) - -{- - To write a bit: - - | reg |= 1 << off - | off <- (off + 1) % 64 - | if (!off): - | buf[w++] <- reg - | reg <- 0 --} -{-# INLINE writeBit #-} -writeBit :: Bool -> Put () -writeBit b = Put $ \tbl s@S{..} -> do - -- traceM ("writeBit: " <> show b) - let s' = s { reg = (if b then setBit else clearBit) reg off - , off = (off + 1) `mod` 64 - , pos = pos + 1 - } - - if off == 63 - then runPut (flush >> setRegOff 0 0) tbl s' - else pure $ PutResult s' () - -{- - To write a 64bit word: - - | reg |= w << off - | buf[bufI++] = reg - | reg = w >> (64 - off) --} -{-# INLINE writeWord #-} -writeWord :: Word -> Put () -writeWord wor = do - -- traceM ("writeWord: " <> show wor) - S{..} <- getS - setReg (reg .|. shiftL wor off) - flush - update \s -> s { pos = 64 + pos - , reg = shiftR wor (64 - off) - } - -{- - To write some bits (< 64) from a word: - - | wor = takeBits(wid, wor) - | reg = reg .|. (wor << off) - | off = (off + wid) % 64 - | - | if (off + wid >= 64) - | buf[w] = x - | reg = wor >> (wid - off) --} - -{-# INLINE writeBitsFromWord #-} -writeBitsFromWord :: Int -> Word -> Put () -writeBitsFromWord wid wor = do - wor <- pure (takeBitsWord wid wor) - - -- traceM ("writeBitsFromWord: " <> show wid <> ", " <> show wor) - - oldSt <- getS - - let newSt = oldSt { reg = reg oldSt .|. shiftL wor (off oldSt) - , off = (off oldSt + wid) `mod` 64 - , pos = fromIntegral wid + pos oldSt - } - - putS newSt - - when (wid + off oldSt >= 64) $ do - flush - setReg (shiftR wor (wid - off newSt)) -{- - Write all of the the signficant bits of a direct atom. --} -{-# INLINE writeAtomWord# #-} -writeAtomWord# :: Word# -> Put () -writeAtomWord# w = do - -- traceM "writeAtomWord" - writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) - -{-# INLINE writeAtomWord #-} -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. --} -{-# INLINE writeAtomBigNat #-} -writeAtomBigNat :: BigNat -> Put () -writeAtomBigNat (view bigNatWords -> words) = do - -- traceM "writeAtomBigNat" - let lastIdx = VP.length words - 1 - for_ [0..(lastIdx-1)] \i -> - writeWord (words ! i) - writeAtomWord (words ! lastIdx) - -{-# INLINE writeAtomBits #-} -writeAtomBits :: Atom -> Put () -writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd - MkAtom (NatJ# bn) -> writeAtomBigNat bn - - --- Put Instances --------------------------------------------------------------- - -instance Functor Put where - fmap f g = Put $ \tbl s -> do - PutResult s' a <- runPut g tbl s - pure $ PutResult s' (f a) - {-# INLINE fmap #-} - -instance Applicative Put where - pure x = Put (\_ s -> return $ PutResult s x) - {-# INLINE pure #-} - - Put f <*> Put g = Put $ \tbl s1 -> do - PutResult s2 f' <- f tbl s1 - PutResult s3 g' <- g tbl s2 - return $ PutResult s3 (f' g') - {-# INLINE (<*>) #-} - - Put f *> Put g = Put $ \tbl s1 -> do - PutResult s2 _ <- f tbl s1 - g tbl s2 - {-# INLINE (*>) #-} - -instance Monad Put where - return = pure - {-# INLINE return #-} - - (>>) = (*>) - {-# INLINE (>>) #-} - - Put x >>= f = Put $ \tbl s -> do - PutResult s' x' <- x tbl s - runPut (f x') tbl s' - {-# INLINE (>>=) #-} - - --------------------------------------------------------------------------------- - -doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString -doPut tbl sz m = - unsafePerformIO $ do - -- traceM "" - -- H.toList tbl >>= traceM . show . sort - -- traceM "" - buf <- callocBytes (fromIntegral $ 4 * wordSz*8) - _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) - BS.unsafePackCStringFinalizer (castPtr buf) (2*byteSz) (free buf) - where - wordSz = fromIntegral (sz `divUp` 64) - byteSz = fromIntegral (sz `divUp` 8) - divUp x y = (x `div` y) + (if x `mod` y == 0 then 0 else 1) - - mbFlush :: Put () - mbFlush = do - shouldFlush <- (/= 0) . off <$> getS - when shouldFlush flush - - --------------------------------------------------------------------------------- - -{- - TODO Handle back references --} -writeNoun :: Noun -> Put () -writeNoun n = do - getRef >>= \case - Just bk -> writeBackRef bk - Nothing -> case n of Atom a -> writeAtom a - Cell h t -> writeCell h t - -{-# INLINE writeMat #-} -writeMat :: Atom -> Put () -writeMat 0 = do - -- traceM "writeMat: 0" - writeBit True -writeMat atm = do - -- traceM ("writeMat: " <> show atm) - writeBitsFromWord (preWid+1) (shiftL 1 preWid) - writeBitsFromWord (preWid-1) atmWid - writeAtomBits atm - where - atmWid = bitWidth atm - preWid = fromIntegral (wordBitWidth atmWid) - -{-# INLINE writeCell #-} -writeCell :: Noun -> Noun -> Put () -writeCell h t = do - -- traceM "writeCell" - writeBit True - writeBit False - writeNoun h - writeNoun t - -{-# INLINE writeAtom #-} -writeAtom :: Atom -> Put () -writeAtom a = do - -- traceM "writeAtom" - writeBit False - writeMat a - -{-# INLINE writeBackRef #-} -writeBackRef :: Word -> Put () -writeBackRef a = do - p <- pos <$> getS - -- traceM ("writeBackRef: " <> show a <> " @" <> show p) - writeBit True - writeBit True - writeMat (toAtom a) - --------------------------------------------------------------------------------- - -jamBS :: Noun -> ByteString -jamBS n = -- trace (show $ sort $ swap <$> mapToList tbl) --- $ trace (show $ sort $ swap <$> unsafePerformIO (H.toList ht)) - doPut bt sz' (writeNoun n) - where (sz, tbl) = preJam n - (shn, ht) = unsafePerformIO (preJam' n) - (sz', bt) = unsafePerformIO (compress $ toBigNoun n) - -jam :: Noun -> Atom -jam = view (to jamBS . from atomBS) - --------------------------------------------------------------------------------- - -{-# INLINE matSz #-} -matSz :: Atom -> Word -matSz a = W# (matSz# a) - -{-# INLINE matSz# #-} -matSz# :: Atom -> Word# -matSz# 0 = 1## -matSz# a = preW `plusWord#` preW `plusWord#` atmW - where - atmW = atomBitWidth# a - preW = wordBitWidth# atmW - -{-# INLINE refSz# #-} -refSz# :: Word# -> Word# -refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) - -preJam :: Noun -> (Word, Map Noun Word) -preJam = go 0 mempty - where - insertNoun :: Noun -> Word -> Map Noun Word -> Map Noun Word - insertNoun n i tbl = lookup n tbl - & maybe (insertMap n i tbl) (const tbl) - - go :: Word -> Map Noun Word -> Noun -> (Word, Map Noun Word) - go off oldTbl noun = - case lookup noun oldTbl of - Nothing -> - let tbl = insertNoun noun off oldTbl in - case noun of - Atom atm -> - (1 + matSz atm, tbl) - Cell l r -> - let (lSz, tbl') = go (2+off) tbl l in - let (rSz, tbl'') = go (2+off+lSz) tbl' r in - (2 + lSz + rSz, tbl'') - Just (W# ref) -> - let refSz = W# (wordBitWidth# ref) in - case noun of - Atom atm -> - let worSz = matSz atm in - if worSz > refSz - then (2 + refSz, oldTbl) - else (1 + worSz, oldTbl) - Cell _ _ -> - (2 + refSz, oldTbl) - - --- Nouns with pre-computed size and hash --------------------------------------- - -data BigNoun - = BigCell { bSize :: {-# UNPACK #-} !Word - , bHash :: {-# UNPACK #-} !Int - , bHead :: BigNoun - , bTail :: BigNoun - } - | BigAtom { bSize :: {-# UNPACK #-} !Word - , bHash :: {-# UNPACK #-} !Int - , bAtom :: {-# UNPACK #-} !Atom - } - deriving (Show) - -instance Hashable BigNoun where - hash = bHash - {-# INLINE hash #-} - hashWithSalt = defaultHashWithSalt - {-# INLINE hashWithSalt #-} - -instance Eq BigNoun where - BigAtom s1 _ a1 == BigAtom s2 _ a2 = s1==s2 && a1==a2 - BigCell s1 _ h1 t1 == BigCell s2 _ h2 t2 = s1==s2 && h1==h2 && t1==t2 - _ == _ = False - {-# INLINE (==) #-} - -{-# INLINE toBigNoun #-} -toBigNoun :: Noun -> BigNoun -toBigNoun = go - where - go (Atom a) = BigAtom (1 + matSz a) (Hash.hash a) a - go (Cell h t) = BigCell siz has hed tel - where - hed = toBigNoun h - tel = toBigNoun t - siz = 2 + bSize hed + bSize tel - has = fromIntegral siz `combine` bHash hed `combine` bHash tel - - --- Yet Another Fast Pre Jam ---------------------------------------------------- - -{-# INLINE compress #-} -compress :: BigNoun -> IO (Word, H.LinearHashTable Word Word) -compress top = do - nodes :: H.LinearHashTable BigNoun Word <- H.new - backs :: H.LinearHashTable Word Word <- H.new - - let proc :: Word -> BigNoun -> IO Word - proc pos = \case - BigAtom _ _ a -> pure (1 + matSz a) - BigCell _ _ h t -> do - hSz <- go (pos+2) h - tSz <- go (pos+2+hSz) t - pure (2+hSz+tSz) - - go :: Word -> BigNoun -> IO Word - go p inp = do - H.lookup nodes inp >>= \case - Nothing -> do - -- traceM ("inserting " <> show inp) - H.insert nodes inp p - proc p inp - Just bak -> do - -- traceM ("found backref for " <> show inp) - let refSz = 2 + matSz (toAtom bak) - if (refSz < bSize inp) - then H.insert backs p bak $> refSz - else proc p inp - - res <- go 0 top - pure (res, backs) - --- Fast Pre-Jam ---------------------------------------------------------------- - -{- - An `SHN` is a noun and some pre-computed information. - - - `size` is the serialized size without backreferences, we use this - for fast equality checks. - - `jmSz` is the serialized size, we use this to allocate a buffer - at the end. - - `hash` is a precomputed noun hash. We use this to get better, - cheaper hashes for our hashtable. - - `noun` is the actual noun. --} -data SHN = SHN - { size :: {-# UNPACK #-} !Word - , jmSz :: {-# UNPACK #-} !Word - , hash :: {-# UNPACK #-} !Int - , noun :: {-# UNPACK #-} !Noun - } - deriving (Show) - -instance Hashable SHN where - hash (SHN _ _ h _) = h - {-# INLINE hash #-} - hashWithSalt = defaultHashWithSalt - {-# INLINE hashWithSalt #-} - -instance Eq SHN where - x == y = (size x == size y) && (noun x == noun y) - -{- - This is slightly different that the stock `jam`, since we use - backreferences if-and-only-if they save space. --} -preJam' :: Noun -> IO (SHN, H.LinearHashTable Word Word) -preJam' top = do - nodes :: H.LinearHashTable SHN Word <- H.new - backs :: H.LinearHashTable Word Word <- H.new - - let goAtom :: Word -> Atom -> IO SHN - goAtom pos a@(MkAtom nat) = do - let atmSz = 1 + matSz a - pure $ SHN atmSz atmSz (Hash.hash nat) (Atom a) - - goCell :: Word -> Noun -> Noun -> IO SHN - goCell pos h t = do - SHN hSz hJmSz hHash _ <- go (pos+2) h - SHN tSz tJmSz tHash _ <- go (pos+2+hJmSz) t - let sz = 2+hSz+tSz - let jmSz = 2+hJmSz+tJmSz - pure $ SHN sz jmSz (combine hHash tHash) (Cell h t) - - go :: Word -> Noun -> IO SHN - go p n = do - res <- case n of Atom a -> goAtom p a - Cell h t -> goCell p h t - - H.lookup nodes res >>= \case - Nothing -> do - H.insert nodes res p - pure res - Just bak -> do - let refSz = 2 + matSz (toAtom bak) - if (refSz < jmSz res) - then do H.insert backs p bak - pure (res { jmSz = refSz }) - else pure res - - res <- go 0 top - pure (res, backs) - --- Stolen from Hashable Library ------------------------------------------------ - -{-# INLINE combine #-} -combine :: Int -> Int -> Int -combine h1 h2 = (h1 * 16777619) `xor` h2 - -{-# INLINE defaultHashWithSalt #-} -defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt salt x = salt `combine` Hash.hash x - - -{- - I suspect that hashing these big atoms recursively is going to be the bottleneck: - Unless you have a good hashing system. - Which we totally do in the nock runtime. - Checking the hash for the top-level node precomputes the hashes for - everything else, recursively. - This is really smart. - Maybe I could implement this as well? - But hashing traverses the whole structure. - So, now we have - 1. precompute hashes. - 2. precompute size and backref table. - 3. serialize - This seems excessive. - We insert into the backref table right away, but actually: - Backreferences can't exist until the whole node is processed. - - Which implies a smarter algorithm: - - Setup a atom dup table - atoms :: Hashtable BigNum Word - - Setup a cell dup table - cells :: Hashtable (Noun, Noun) Word - - Setup a backref table (map from dup. pos to orig. pos) - backs :: Hashtable Word Word - - go :: Noun -> ST s (Hash, Word) - - If atom, - - Compute size and hash - - Check atom table for backref - - If atom in `atoms` table: - - If backref smaller than atom - - Insert (pos, bak) into `backs` table. - - Return (backref size, atom hash) - - If backref not smaller than atom - - Return (atom size, atom hash) - - Otherwise: - - Insert atom into `atoms` table. - - Return (atom size, atom hash) - - If cell - - process head - - process tail - - produce size+hash from results - - Check cell table for backref - - If backref exists - - Insert `(pos, bak)` into `backs` table - - Return (backref size, cell hash) - - Else - - Return (cell size, cell hash) - - Then, to serialize: - - Allocate a buffer of `size` bits - - If current pos in `backs` table: - - Write `11` - - Write backref (mat) - - Otherwise: - - If Atom: - - Write `0` - - Write atom (mat) - - If Cell - - Write `10` - - Write head - - Write tail --} diff --git a/pkg/hs-urbit/lib/Data/Noun/Lens.hs b/pkg/hs-urbit/lib/Data/Noun/Lens.hs index 12f7933b8..3f1fdfb42 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Data/Noun/Lens.hs @@ -7,7 +7,7 @@ import Data.Noun.Pill import Data.Noun import Data.Noun.Atom import Control.Lens -import Data.Noun.Jam.Put (jam, jamBS) +import Data.Noun.Jam.Fast (jam, jamBS) import Data.Noun.Jam (cue) -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 2f60ca531..24f9e35a3 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -7,7 +7,7 @@ import Data.Void import Data.Noun import Data.Noun.Atom import Data.Noun.Jam hiding (jam) -import Data.Noun.Jam.Put (jam, jamBS) +import Data.Noun.Jam.Fast (jam, jamBS) import Data.Noun.Poet import Data.Noun.Pill import Vere.Pier.Types From 5044379f309993b8a09fd3b89e6a7aa00652befa Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 1 Jul 2019 19:51:26 -0700 Subject: [PATCH 094/431] More cleanup. --- pkg/hs-urbit/lib/Arvo.hs | 42 -------------------- pkg/hs-urbit/lib/{Data => }/Noun.hs | 4 +- pkg/hs-urbit/lib/{Data => }/Noun/Atom.hs | 2 +- pkg/hs-urbit/lib/{Data => }/Noun/Cue/Fast.hs | 10 ++--- pkg/hs-urbit/lib/{Data => }/Noun/Jam.hs | 10 ++--- pkg/hs-urbit/lib/{Data => }/Noun/Jam/Fast.hs | 10 ++--- pkg/hs-urbit/lib/{Data => }/Noun/Lens.hs | 12 +++--- pkg/hs-urbit/lib/{Data => }/Noun/Pill.hs | 7 ++-- pkg/hs-urbit/lib/{Data => }/Noun/Poet.hs | 8 ++-- pkg/hs-urbit/lib/{Data => }/Noun/Poet/TH.hs | 4 +- pkg/hs-urbit/lib/{Data => }/Noun/Zip.hs | 22 +++++----- pkg/hs-urbit/lib/Urbit/Time.hs | 10 ++--- pkg/hs-urbit/lib/Vere.hs | 8 ---- pkg/hs-urbit/lib/Vere/Http.hs | 8 ++-- pkg/hs-urbit/lib/Vere/Http/Client.hs | 4 +- pkg/hs-urbit/lib/Vere/Http/Server.hs | 8 ++-- pkg/hs-urbit/lib/Vere/Log.hs | 11 +++-- pkg/hs-urbit/lib/Vere/Pier.hs | 5 +-- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 8 ++-- pkg/hs-urbit/lib/Vere/Serf.hs | 12 +++--- pkg/hs-vere/app/test/Main.hs | 2 - pkg/hs-vere/app/uterm/Main.hs | 4 +- 22 files changed, 78 insertions(+), 133 deletions(-) delete mode 100644 pkg/hs-urbit/lib/Arvo.hs rename pkg/hs-urbit/lib/{Data => }/Noun.hs (97%) rename pkg/hs-urbit/lib/{Data => }/Noun/Atom.hs (99%) rename pkg/hs-urbit/lib/{Data => }/Noun/Cue/Fast.hs (98%) rename pkg/hs-urbit/lib/{Data => }/Noun/Jam.hs (98%) rename pkg/hs-urbit/lib/{Data => }/Noun/Jam/Fast.hs (97%) rename pkg/hs-urbit/lib/{Data => }/Noun/Lens.hs (83%) rename pkg/hs-urbit/lib/{Data => }/Noun/Pill.hs (98%) rename pkg/hs-urbit/lib/{Data => }/Noun/Poet.hs (99%) rename pkg/hs-urbit/lib/{Data => }/Noun/Poet/TH.hs (98%) rename pkg/hs-urbit/lib/{Data => }/Noun/Zip.hs (98%) delete mode 100644 pkg/hs-urbit/lib/Vere.hs diff --git a/pkg/hs-urbit/lib/Arvo.hs b/pkg/hs-urbit/lib/Arvo.hs deleted file mode 100644 index 9909ff93d..000000000 --- a/pkg/hs-urbit/lib/Arvo.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Arvo where - -import ClassyPrelude - --------------------------------------------------------------------------------- - -data Event = Event -data Effect = Effect - -data ArvoFn = MkArvoFn (Event -> ([Effect], ArvoFn)) - -data Arvo r - = Yield [Effect] (Event -> Arvo r) - | Pure r - - --- Arvo is a Monad ------------------------------------------------------------- - -bind :: Arvo a -> (a -> Arvo b) -> Arvo b -bind (Pure x) f = f x -bind (Yield fx k) f = Yield fx (\ev -> bind (k ev) f) - -instance Functor Arvo where - fmap f (Pure v) = Pure (f v) - fmap f (Yield fx cont) = Yield fx (fmap (fmap f) cont) - -instance Applicative Arvo where - pure = Pure - mx <*> y = mx `bind` (\f -> f <$> y) - -instance Monad Arvo where - (>>=) = bind - --------------------------------------------------------------------------------- - -yield :: [Effect] -> Arvo Event -yield fx = Yield fx Pure - -example :: Arvo a -example = do - Event <- yield [Effect, Effect] - example diff --git a/pkg/hs-urbit/lib/Data/Noun.hs b/pkg/hs-urbit/lib/Noun.hs similarity index 97% rename from pkg/hs-urbit/lib/Data/Noun.hs rename to pkg/hs-urbit/lib/Noun.hs index fe79d8a6f..04c85d326 100644 --- a/pkg/hs-urbit/lib/Data/Noun.hs +++ b/pkg/hs-urbit/lib/Noun.hs @@ -1,4 +1,4 @@ -module Data.Noun where +module Noun where import Prelude hiding (all) @@ -13,7 +13,7 @@ import Data.Flat hiding (getSize) import ClassyPrelude (Text, all, unpack) import Data.Hashable (Hashable) import Data.List (intercalate) -import Data.Noun.Atom (Atom) +import Noun.Atom (Atom) import Data.Typeable (Typeable) import qualified Control.Monad.Fail as Fail diff --git a/pkg/hs-urbit/lib/Data/Noun/Atom.hs b/pkg/hs-urbit/lib/Noun/Atom.hs similarity index 99% rename from pkg/hs-urbit/lib/Data/Noun/Atom.hs rename to pkg/hs-urbit/lib/Noun/Atom.hs index b87fb907b..58fb0f236 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Atom.hs +++ b/pkg/hs-urbit/lib/Noun/Atom.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MagicHash, GeneralizedNewtypeDeriving, UnboxedTuples #-} -module Data.Noun.Atom where +module Noun.Atom where import ClassyPrelude import Control.Lens diff --git a/pkg/hs-urbit/lib/Data/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs similarity index 98% rename from pkg/hs-urbit/lib/Data/Noun/Cue/Fast.hs rename to pkg/hs-urbit/lib/Noun/Cue/Fast.hs index 31e9e39cb..e98cee3e9 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -1,12 +1,12 @@ {-# LANGUAGE MagicHash #-} -module Data.Noun.Cue.Fast where +module Noun.Cue.Fast where import ClassyPrelude import ClassyPrelude -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Poet +import Noun +import Noun.Atom +import Noun.Poet import Data.Bits hiding (Bits) import Control.Lens import Text.Printf @@ -16,7 +16,7 @@ import GHC.Natural import Foreign.Ptr import Foreign.Storable (peek) -import Data.Noun (Noun) +import Noun (Noun) import Data.Bits (shiftR, (.|.), (.&.)) import Foreign.Ptr (Ptr, plusPtr, ptrToWordPtr) import Foreign.Storable (peek) diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam.hs b/pkg/hs-urbit/lib/Noun/Jam.hs similarity index 98% rename from pkg/hs-urbit/lib/Data/Noun/Jam.hs rename to pkg/hs-urbit/lib/Noun/Jam.hs index 7f1004f0d..aeb2f0752 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Noun/Jam.hs @@ -1,8 +1,8 @@ -module Data.Noun.Jam where +module Noun.Jam where import ClassyPrelude -import Data.Noun -import Data.Noun.Atom +import Noun +import Noun.Atom import Data.Bits import Control.Lens import Text.Printf @@ -16,8 +16,8 @@ import Test.Tasty.TH import Test.Tasty.QuickCheck as QC import Test.QuickCheck -import qualified Data.Noun.Jam.Fast as Fast -import qualified Data.Noun.Pill as Pill +import qualified Noun.Jam.Fast as Fast +import qualified Noun.Pill as Pill -- Length-Encoded Atoms -------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs similarity index 97% rename from pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs rename to pkg/hs-urbit/lib/Noun/Jam/Fast.hs index a5a339d9c..ee3d76dcc 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs @@ -1,16 +1,16 @@ {-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} -module Data.Noun.Jam.Fast (jam, jamBS) where +module Noun.Jam.Fast (jam, jamBS) where import ClassyPrelude hiding (hash) import Control.Lens (view, to, from) import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.)) -import Data.Noun.Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) -import Data.Noun.Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) -import Data.Noun (Noun(Atom, Cell)) -import Data.Noun.Pill (bigNatWords, atomBS) +import Noun.Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) +import Noun.Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) +import Noun (Noun(Atom, Cell)) +import Noun.Pill (bigNatWords, atomBS) import Data.Vector.Primitive ((!)) import Foreign.Marshal.Alloc (callocBytes, free) import Foreign.Ptr (Ptr, castPtr, plusPtr) diff --git a/pkg/hs-urbit/lib/Data/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs similarity index 83% rename from pkg/hs-urbit/lib/Data/Noun/Lens.hs rename to pkg/hs-urbit/lib/Noun/Lens.hs index 3f1fdfb42..7e504b796 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -1,14 +1,14 @@ {-# LANGUAGE MagicHash #-} -module Data.Noun.Lens where +module Noun.Lens where import ClassyPrelude -import Data.Noun.Pill -import Data.Noun -import Data.Noun.Atom +import Noun.Pill +import Noun +import Noun.Atom import Control.Lens -import Data.Noun.Jam.Fast (jam, jamBS) -import Data.Noun.Jam (cue) +import Noun.Jam.Fast (jam, jamBS) +import Noun.Jam (cue) -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Data/Noun/Pill.hs b/pkg/hs-urbit/lib/Noun/Pill.hs similarity index 98% rename from pkg/hs-urbit/lib/Data/Noun/Pill.hs rename to pkg/hs-urbit/lib/Noun/Pill.hs index 6532899f3..c415097cf 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Pill.hs +++ b/pkg/hs-urbit/lib/Noun/Pill.hs @@ -20,12 +20,11 @@ machines. -} -module Data.Noun.Pill where +module Noun.Pill where import ClassyPrelude -import Data.Noun hiding (toList, fromList) -import Data.Noun.Atom --- import Data.Noun.Jam hiding (main) +import Noun hiding (toList, fromList) +import Noun.Atom import Data.Flat hiding (from, to) import Control.Monad.Except import Control.Lens hiding (index, Index) diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet.hs b/pkg/hs-urbit/lib/Noun/Poet.hs similarity index 99% rename from pkg/hs-urbit/lib/Data/Noun/Poet.hs rename to pkg/hs-urbit/lib/Noun/Poet.hs index 1e514c08b..b3219a164 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet.hs +++ b/pkg/hs-urbit/lib/Noun/Poet.hs @@ -1,16 +1,16 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} -module Data.Noun.Poet where +module Noun.Poet where import ClassyPrelude hiding (fromList) import Control.Lens import Control.Applicative import Control.Monad -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Pill +import Noun +import Noun.Atom +import Noun.Pill import Data.Void import Data.Word import GHC.Natural diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Noun/Poet/TH.hs similarity index 98% rename from pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs rename to pkg/hs-urbit/lib/Noun/Poet/TH.hs index 38576d43d..46bfc01a0 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs +++ b/pkg/hs-urbit/lib/Noun/Poet/TH.hs @@ -2,13 +2,13 @@ Generate FromNoun and ToNoun instances. -} -module Data.Noun.Poet.TH where +module Noun.Poet.TH where import ClassyPrelude hiding (fromList) import Control.Lens -import Data.Noun.Poet hiding (hsToHoon) import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Noun.Poet hiding (hsToHoon) import RIO (decodeUtf8Lenient) diff --git a/pkg/hs-urbit/lib/Data/Noun/Zip.hs b/pkg/hs-urbit/lib/Noun/Zip.hs similarity index 98% rename from pkg/hs-urbit/lib/Data/Noun/Zip.hs rename to pkg/hs-urbit/lib/Noun/Zip.hs index 6a548f92b..786251779 100644 --- a/pkg/hs-urbit/lib/Data/Noun/Zip.hs +++ b/pkg/hs-urbit/lib/Noun/Zip.hs @@ -2,25 +2,25 @@ Can de-duplication be orthogonal to serialization? -} -module Data.Noun.Zip where +module Noun.Zip where import ClassyPrelude hiding (zip, unzip) -import Control.Lens -import Text.Printf import Control.Applicative -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Jam +import Control.Lens import Data.Bits -import GHC.Generics -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen +import Data.Either.Extra +import Data.Flat import Data.Flat import Data.Flat.Bits -import Data.Either.Extra +import GHC.Generics import GHC.Natural -import Data.Flat +import Noun +import Noun.Atom +import Noun.Jam +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Text.Printf import Data.Maybe (fromJust) import Data.List (intercalate) diff --git a/pkg/hs-urbit/lib/Urbit/Time.hs b/pkg/hs-urbit/lib/Urbit/Time.hs index 29dd5fb10..8001ac822 100644 --- a/pkg/hs-urbit/lib/Urbit/Time.hs +++ b/pkg/hs-urbit/lib/Urbit/Time.hs @@ -8,11 +8,11 @@ import Prelude import Control.Lens import Data.Bits (shiftL, shiftR) -import Data.Time.Clock (DiffTime, UTCTime, picosecondsToDiffTime, - diffTimeToPicoseconds) -import Data.Time.Clock.System (SystemTime(..), getSystemTime, utcToSystemTime, - systemToUTCTime) -import Data.Noun.Poet (FromNoun, ToNoun) +import Data.Time.Clock (DiffTime, UTCTime, picosecondsToDiffTime) +import Data.Time.Clock (picosecondsToDiffTime, diffTimeToPicoseconds) +import Data.Time.Clock.System (SystemTime(..), getSystemTime) +import Data.Time.Clock.System (utcToSystemTime, systemToUTCTime) +import Noun.Poet (FromNoun, ToNoun) -- Types ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere.hs b/pkg/hs-urbit/lib/Vere.hs deleted file mode 100644 index 5a68023aa..000000000 --- a/pkg/hs-urbit/lib/Vere.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Vere where - -import ClassyPrelude -import Data.Void -import Data.Noun -import Vere.Pier.Types - --- +vere ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index 4fe12d334..08043131c 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -3,10 +3,10 @@ module Vere.Http where import ClassyPrelude -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Poet -import Data.Noun.Poet.TH +import Noun +import Noun.Atom +import Noun.Poet +import Noun.Poet.TH import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index 44b553a91..d37d72e6f 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Client.hs @@ -7,8 +7,8 @@ module Vere.Http.Client where import ClassyPrelude import Vere.Http -import Data.Noun.Poet -import Data.Noun.Poet.TH +import Noun.Poet +import Noun.Poet.TH import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index c47bfe63b..0e575db47 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -4,13 +4,13 @@ module Vere.Http.Server where import ClassyPrelude import Vere.Http -import Data.Noun.Atom -import Data.Noun.Poet -import Data.Noun.Poet.TH +import Noun.Atom +import Noun.Poet +import Noun.Poet.TH import Control.Lens import Control.Concurrent (ThreadId, killThread, forkIO) -import Data.Noun.Pill (pill, pillBS, Pill(..)) +import Noun.Pill (pill, pillBS, Pill(..)) import qualified Data.ByteString as BS import qualified Network.HTTP.Types as H diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index 1ab467e36..ec95b665a 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -16,16 +16,15 @@ module Vere.Log ( open import ClassyPrelude hiding (init) import Control.Lens hiding ((<|)) -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Jam -import Data.Noun.Pill -import Data.Noun.Lens +import Noun +import Noun.Atom +import Noun.Jam +import Noun.Pill +import Noun.Lens import Data.Void import Database.LMDB.Raw import Foreign.Ptr import Foreign.Marshal.Alloc -import Vere import Vere.Pier.Types import Control.Concurrent (runInBoundThread) diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 4eab9960c..9daa0b913 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -2,9 +2,8 @@ module Vere.Pier where import ClassyPrelude -import Data.Noun -import Data.Noun.Pill -import Vere +import Noun +import Noun.Pill import Vere.Pier.Types import qualified Vere.Log as Log diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index b155a6e0c..4d75ad357 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -2,10 +2,10 @@ module Vere.Pier.Types where import ClassyPrelude import Data.Void -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Poet -import Data.Noun.Poet.TH +import Noun +import Noun.Atom +import Noun.Poet +import Noun.Poet.TH import Database.LMDB.Raw import Urbit.Time diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 24f9e35a3..abc4faeda 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -4,12 +4,12 @@ import ClassyPrelude import Control.Lens import Data.Void -import Data.Noun -import Data.Noun.Atom -import Data.Noun.Jam hiding (jam) -import Data.Noun.Jam.Fast (jam, jamBS) -import Data.Noun.Poet -import Data.Noun.Pill +import Noun +import Noun.Atom +import Noun.Jam hiding (jam) +import Noun.Jam.Fast (jam, jamBS) +import Noun.Poet +import Noun.Pill import Vere.Pier.Types import System.Process diff --git a/pkg/hs-vere/app/test/Main.hs b/pkg/hs-vere/app/test/Main.hs index 3c7913002..e879466db 100644 --- a/pkg/hs-vere/app/test/Main.hs +++ b/pkg/hs-vere/app/test/Main.hs @@ -3,8 +3,6 @@ module Main where import ClassyPrelude import Vere.Pier.Types -import Data.Noun.Jam () - import qualified Vere.Log as Log import qualified Vere.Persist as Persist import qualified Vere.Pier as Pier diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index d398923c0..56808d30e 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/pkg/hs-vere/app/uterm/Main.hs @@ -2,8 +2,8 @@ module Main where import ClassyPrelude import Control.Lens -import Data.Noun.Pill hiding (main) -import Data.Noun.Lens +import Noun.Pill hiding (main) +import Noun.Lens -------------------------------------------------------------------------------- From 36f8f9420e0637733bbc3b76d214a4b733a9a2e5 Mon Sep 17 00:00:00 2001 From: Elliot Glaysher Date: Tue, 2 Jul 2019 16:37:10 -0700 Subject: [PATCH 095/431] Skeleton of Ames support --- pkg/hs-urbit/lib/Urbit/Ames.hs | 63 +++++++++++++++++++++++++++++ pkg/hs-urbit/lib/Vere/Ames.hs | 50 +++++++++++++++++++++++ pkg/hs-urbit/lib/Vere/Pier/Types.hs | 3 +- pkg/hs-urbit/package.yaml | 2 + 4 files changed, 117 insertions(+), 1 deletion(-) create mode 100644 pkg/hs-urbit/lib/Urbit/Ames.hs create mode 100644 pkg/hs-urbit/lib/Vere/Ames.hs diff --git a/pkg/hs-urbit/lib/Urbit/Ames.hs b/pkg/hs-urbit/lib/Urbit/Ames.hs new file mode 100644 index 000000000..e97fcb067 --- /dev/null +++ b/pkg/hs-urbit/lib/Urbit/Ames.hs @@ -0,0 +1,63 @@ +module Urbit.Ames where + +import ClassyPrelude +import Data.IP + +import Noun +import Noun.Atom + +import Network.Socket + +import qualified Data.Vector as V +import qualified Urbit.Time as Time + +import qualified Vere.Ames as VA + +data GalaxyInfo = GalaxyInfo { ip :: IPv4, age :: Time.Unix } + +data Ames = Ames + { live :: Bool -- ^ whether the listener is on + , ourPort :: Maybe Int +-- , threadId :: Thread + , globalDomain :: Maybe Text -- ^ something like "urbit.org" + , imperial :: V.Vector (Maybe GalaxyInfo) + } + +init :: Ames +init = Ames { live = False + , ourPort = Nothing + , globalDomain = Nothing + , imperial = V.replicate 256 Nothing + } + +turf :: Ames -> [VA.Turf] -> IO Ames +turf ames [] = undefined +turf ames (VA.MkTurf turf:_) = do + let t = mconcat (intersperse "." turf) + + pure ames{globalDomain = Just t} + + +data NetworkMode + = LocalOnlyNetworking + | GlobalNetworking + +-- +ioStart :: Ames -> NetworkMode -> Int -> Noun -> IO Ames +ioStart ames isLocal defaultPort (Atom who) = do + let port = if who < 256 + then computePort isLocal who + else defaultPort + + -- TODO: set up another thread to own the recv socket, which makes the Ovums + -- which get put into the computeQueue, like in _ames_recv_cb. + withSocketsDo do + s <- socket AF_INET Datagram 17 + -- bind s (SockAddrInet port ) + pure () + + pure ames + +computePort :: NetworkMode -> Atom -> Int +computePort LocalOnlyNetworking who = 31337 + (fromIntegral who) +computePort GlobalNetworking who = 13337 + (fromIntegral who) diff --git a/pkg/hs-urbit/lib/Vere/Ames.hs b/pkg/hs-urbit/lib/Vere/Ames.hs new file mode 100644 index 000000000..b124106fc --- /dev/null +++ b/pkg/hs-urbit/lib/Vere/Ames.hs @@ -0,0 +1,50 @@ +module Vere.Ames where + +import ClassyPrelude +import Data.IP +import Data.Void +import Noun +import Noun.Atom +import Noun.Poet +import Noun.Poet.TH +import Control.Lens + +import qualified Urbit.Time as Time + +type Packet = ByteString + +type Port = Word + +data Ev + = EvBarn -- [%barn ~] + | EvHear Lane Packet -- [%hear lane @] + deriving (Eq, Ord, Show) + +data Eff + = Send Lane Packet + | Turf [Turf] + deriving (Eq, Ord, Show) + +newtype Turf = MkTurf [Text] + deriving (Eq, Ord, Show) + +data Lane + = Ip4f Time.Wen Port IPv4 -- [%if @da @ud @if] + | Ip6 Void (Maybe Lane) Void -- [%is @ud (unit lane) @is] + | Ip4x Time.Wen Port IPv4 -- [%ix @da @ud @if] + deriving (Eq, Ord, Show) + +-- todo: manual instance needed? +deriveNoun ''IPv4 + +deriveNoun ''Ev +deriveNoun ''Eff +deriveNoun ''Turf +deriveNoun ''Lane + +toIpv4 :: Lane -> IPv4 +toIpv4 = \case + Ip4f _ _ i -> i + Ip6 _ (Just l) _ -> toIpv4 l + Ip6 _ _ _ -> error "IPv6 doesn't exist in practice" + Ip4x _ _ i -> i diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 4d75ad357..eb2597422 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -11,6 +11,7 @@ import Urbit.Time import RIO (decodeUtf8Lenient) +import qualified Vere.Ames as Ames import qualified Vere.Http.Client as Client import qualified Vere.Http.Server as Server @@ -39,7 +40,7 @@ data NewtEx = NE Word data Eff = HttpServer Server.Eff | HttpClient Client.Eff - | Ames Noun + | Ames Ames.Eff | Bbye Noun | Behn Noun | Blit [Blit] diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 76346290c..448b0e821 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -26,12 +26,14 @@ dependencies: - http-client - http-types - integer-gmp + - iproute - largeword - lens - lmdb - megaparsec - mtl - multimap + - network - para - pretty-show - primitive From 095aba7509931465d57b525225340a364f45b5f6 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 2 Jul 2019 18:15:48 -0700 Subject: [PATCH 096/431] Flushed out and wired up my new impl.; doesn't work yet. --- pkg/hs-urbit/lib/Noun/Cue/Fast.hs | 58 ++++++++++++++++++++++++------- pkg/hs-urbit/lib/Noun/Jam.hs | 12 ++++--- pkg/hs-urbit/lib/Noun/Pill.hs | 3 ++ 3 files changed, 57 insertions(+), 16 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index e98cee3e9..f59c2941d 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -15,15 +15,19 @@ import GHC.Word import GHC.Natural import Foreign.Ptr -import Foreign.Storable (peek) -import Noun (Noun) +import Control.Monad (guard) import Data.Bits (shiftR, (.|.), (.&.)) +import Data.Map (Map) import Foreign.Ptr (Ptr, plusPtr, ptrToWordPtr) import Foreign.Storable (peek) -import Data.Map (Map) -import Control.Monad (guard) +import Foreign.Storable (peek) +import Noun (Noun) +import Noun.Pill (atomBS, atomWords) +import System.IO.Unsafe (unsafePerformIO) -import qualified Data.HashTable.IO as H +import qualified Data.ByteString.Unsafe as BS +import qualified Data.HashTable.IO as H +import qualified Data.Vector.Primitive as VP import Test.Tasty import Test.Tasty.TH @@ -31,6 +35,15 @@ import qualified Test.Tasty.QuickCheck as QC import Test.QuickCheck hiding ((.&.)) +-------------------------------------------------------------------------------- + +cueBS :: ByteString -> Either DecodeExn Noun +cueBS = doGet dNoun + +cue :: Atom -> Either DecodeExn Noun +cue = cueBS . view atomBS + + -- Types ----------------------------------------------------------------------- {-| @@ -67,6 +80,14 @@ newtype Get a = Get type Bits = Vector Bool +doGet :: Get a -> ByteString -> Either DecodeExn a +doGet m bs = + unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do + let endPtr = ptr `plusPtr` len + tbl <- H.new + GetResult _ r <- runGet m endPtr tbl (S (castPtr ptr) 0 0) + pure r + -------------------------------------------------------------------------------- instance Exception DecodeExn @@ -174,6 +195,12 @@ dBit = do advance 1 pure (0 /= shiftR wor use .&. 1) +dWord :: Get Word +dWord = do + res <- peekWord + advance 64 + pure res + {-| Get n bits, where n > 64: @@ -183,8 +210,19 @@ dBit = do - Calculate the length (equal to n) - Construct a bit-vector using the buffer*length*offset. -} -dBits :: Word -> Get Bits -dBits = undefined +dAtomBits :: Word -> Get Atom +dAtomBits (fromIntegral -> bits) = + fmap (view $ from atomWords) $ + VP.generateM bufSize \i -> + if (i == lastIdx && numExtraBits /= 0) + then dWordBits (fromIntegral numExtraBits) + else dWord + + where + bufSize = numFullWords + min 1 numExtraBits + lastIdx = bufSize - 1 + numFullWords = bits `div` 64 + numExtraBits = bits `mod` 64 {-| In order to peek at the next Word64: @@ -269,11 +307,7 @@ dRef = dAtomLen >>= dWordBits dAtom :: Get Atom dAtom = do n <- dAtomLen - b <- dBits n - pure (bitsToAtom b) - -bitsToAtom :: Bits -> Atom -bitsToAtom = undefined + dAtomBits n dCell :: Get Noun dCell = Cell <$> dNoun <*> dNoun diff --git a/pkg/hs-urbit/lib/Noun/Jam.hs b/pkg/hs-urbit/lib/Noun/Jam.hs index aeb2f0752..4a2b3bef8 100644 --- a/pkg/hs-urbit/lib/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Noun/Jam.hs @@ -16,7 +16,8 @@ import Test.Tasty.TH import Test.Tasty.QuickCheck as QC import Test.QuickCheck -import qualified Noun.Jam.Fast as Fast +import qualified Noun.Jam.Fast as Jam +import qualified Noun.Cue.Fast as Cue import qualified Noun.Pill as Pill @@ -211,15 +212,18 @@ pills = [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 -- jamTest = fmap jam <$> cueTest prop_fastMatSlow :: Atom -> Bool -prop_fastMatSlow a = jam (Atom a) == Fast.jam (Atom a) +prop_fastMatSlow a = jam (Atom a) == Jam.jam (Atom a) prop_fastJamSlow :: Noun -> Bool prop_fastJamSlow n = x == y || (bitWidth y <= bitWidth x && cue y == cue x) where x = jam n - y = Fast.jam n + y = Jam.jam n + +prop_fastRub :: Atom -> Bool +prop_fastRub a = Right (Atom a) == Cue.cue (jam (Atom a)) prop_fastJam :: Noun -> Bool -prop_fastJam n = Just n == cue (Fast.jam n) +prop_fastJam n = Just n == cue (Jam.jam n) -- prop_jamCue :: Noun -> Bool -- prop_jamCue n = Just n == cue (jam n) diff --git a/pkg/hs-urbit/lib/Noun/Pill.hs b/pkg/hs-urbit/lib/Noun/Pill.hs index c415097cf..6e17210fb 100644 --- a/pkg/hs-urbit/lib/Noun/Pill.hs +++ b/pkg/hs-urbit/lib/Noun/Pill.hs @@ -194,6 +194,9 @@ dumbPackAtom = go 0 0 . toList . view pillBS atomNat :: Iso' Atom Natural atomNat = iso unAtom MkAtom +atomWords :: Iso' Atom (VP.Vector Word) +atomWords = atomNat . natWords + pill :: Iso' Atom Pill pill = iso toAtom fromPill where From f4db869fd23523bc33c2e90a90a6a6109ed9822c Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 2 Jul 2019 22:14:39 -0700 Subject: [PATCH 097/431] Got fast cue working. --- pkg/hs-urbit/lib/Noun/Cue/Fast.hs | 130 +++++++++++++++++++----------- pkg/hs-urbit/lib/Noun/Jam.hs | 9 +++ pkg/hs-urbit/lib/Noun/Lens.hs | 29 +++++-- pkg/hs-urbit/lib/Noun/Pill.hs | 18 ----- pkg/hs-vere/app/uterm/Main.hs | 18 ++--- 5 files changed, 122 insertions(+), 82 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index f59c2941d..655c55e23 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -2,7 +2,6 @@ module Noun.Cue.Fast where -import ClassyPrelude import ClassyPrelude import Noun import Noun.Atom @@ -44,6 +43,23 @@ cue :: Atom -> Either DecodeExn Noun cue = cueBS . view atomBS +-- Debugging ------------------------------------------------------------------- + +{-# INLINE debugM #-} +debugM :: Monad m => String -> m () +debugM _ = pure () + +{-# INLINE debugMId #-} +debugMId :: (Monad m, Show a) => String -> m a -> m a +debugMId _ a = a + +-- debugMId tag m = do + -- r <- m + -- debugM (tag <> ": " <> show r) + -- pure r + + + -- Types ----------------------------------------------------------------------- {-| @@ -69,7 +85,7 @@ data DecodeExn deriving (Show, Eq, Ord) data GetResult a = GetResult {-# UNPACK #-} !S !a - deriving Functor + deriving (Show, Functor) newtype Get a = Get { runGet :: Ptr Word @@ -125,7 +141,7 @@ instance Monad Get where runGet (f x') end tbl s' {-# INLINE (>>=) #-} - fail msg = Get $ \end tbl s -> + fail msg = Get $ \end tbl s -> do badEncoding end s msg {-# INLINE fail #-} @@ -146,18 +162,20 @@ insRef pos now = Get \_ tbl s -> do pure $ GetResult s () getRef :: Word -> Get Noun -getRef ref = Get \_ tbl s -> do +getRef ref = Get \x tbl s -> do H.lookup tbl ref >>= \case - Nothing -> fail "Invalid Reference" + Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s Just no -> pure (GetResult s no) advance :: Word -> Get () +advance 0 = debugM "advance: 0" >> pure () advance n = Get \_ _ s -> do + debugM ("advance: " <> show n) let newUsed = n + usedBits s newS = s { pos = pos s + n , usedBits = newUsed `mod` 64 , currPtr = plusPtr (currPtr s) - (fromIntegral $ newUsed `div` 64) + (8 * (fromIntegral (newUsed `div` 64))) } pure (GetResult newS ()) @@ -166,20 +184,25 @@ advance n = Get \_ _ s -> do -- TODO Should this be (>= end) or (> end)? peekCurWord :: Get Word -peekCurWord = Get \end _ s -> +peekCurWord = Get \end _ s -> do + debugMId "peekCurWord" $ do if ptrToWordPtr (currPtr s) >= ptrToWordPtr end then pure (GetResult s 0) else GetResult s <$> peek (currPtr s) -- TODO Same question as above. peekNextWord :: Get Word -peekNextWord = Get \end _ s -> - if ptrToWordPtr (currPtr s) > ptrToWordPtr end +peekNextWord = Get \end _ s -> do + debugMId "peekNextWord" $ do + let pTarget = currPtr s `plusPtr` 8 + if ptrToWordPtr pTarget >= ptrToWordPtr end then pure (GetResult s 0) - else GetResult s <$> peek (currPtr s `plusPtr` 1) + else GetResult s <$> peek pTarget peekUsedBits :: Get Word -peekUsedBits = Get \_ _ s -> pure (GetResult s (usedBits s)) +peekUsedBits = + debugMId "peekUsedBits" $ do + Get \_ _ s -> pure (GetResult s (usedBits s)) {-| Get a bit. @@ -190,16 +213,18 @@ peekUsedBits = Get \_ _ s -> pure (GetResult s (usedBits s)) -} dBit :: Get Bool dBit = do - wor <- peekCurWord - use <- fromIntegral <$> peekUsedBits - advance 1 - pure (0 /= shiftR wor use .&. 1) + debugMId "dBit" $ do + wor <- peekCurWord + use <- fromIntegral <$> peekUsedBits + advance 1 + pure (0 /= shiftR wor use .&. 1) dWord :: Get Word dWord = do - res <- peekWord - advance 64 - pure res + debugMId "dWord" $ do + res <- peekWord + advance 64 + pure res {-| Get n bits, where n > 64: @@ -211,13 +236,14 @@ dWord = do - Construct a bit-vector using the buffer*length*offset. -} dAtomBits :: Word -> Get Atom -dAtomBits (fromIntegral -> bits) = - fmap (view $ from atomWords) $ - VP.generateM bufSize \i -> - if (i == lastIdx && numExtraBits /= 0) - then dWordBits (fromIntegral numExtraBits) - else dWord - +dAtomBits (fromIntegral -> bits) = do + debugMId ("dAtomBits(" <> show bits <> ")") $ do + fmap (view $ from atomWords) $ + VP.generateM bufSize \i -> do + debugM (show i) + if (i == lastIdx && numExtraBits /= 0) + then dWordBits (fromIntegral numExtraBits) + else dWord where bufSize = numFullWords + min 1 numExtraBits lastIdx = bufSize - 1 @@ -241,27 +267,22 @@ dAtomBits (fromIntegral -> bits) = -} peekWord :: Get Word peekWord = do + debugMId "peekWord" $ do off <- peekUsedBits cur <- peekCurWord - if off == 0 then pure cur else - do - nex <- peekNextWord - advance 64 - pure (dropLowBits off cur .|. dropHighBits off nex) + nex <- peekNextWord + let res = swiz off (cur, nex) + debugM ("\t" <> (take 10 $ reverse $ printf "%b" (fromIntegral res :: Integer)) <> "..") + pure res -dropLowBits :: Word -> Word -> Word -dropLowBits bits wor = shiftR wor (fromIntegral bits :: Int) +swiz :: Word -> (Word, Word) -> Word +swiz (fromIntegral -> off) (low, hig) = + (.|.) (shiftR low off) (shiftL hig (64-off)) takeLowBits :: Word -> Word -> Word takeLowBits 64 wor = wor takeLowBits wid wor = (2^wid - 1) .&. wor -takeHighBits :: Word -> Word -> Word -takeHighBits off wor = dropLowBits (64-off) wor - -dropHighBits :: Word -> Word -> Word -dropHighBits off wor = takeLowBits (64-off) wor - {-| Make a word from the next n bits (where n <= 64). @@ -272,8 +293,10 @@ dropHighBits off wor = takeLowBits (64-off) wor -} dWordBits :: Word -> Get Word dWordBits n = do + debugMId ("dWordBits(" <> show n <> ")") $ do w <- peekWord advance n + debugM ("dWordBits: " <> show (takeLowBits n w)) pure (takeLowBits n w) @@ -290,27 +313,32 @@ dWordBits n = do -} dExp :: Get Word dExp = do + debugMId "dExp" $ do W# w <- peekWord let res = W# (ctz# w) - advance res + advance (res+1) pure res dAtomLen :: Get Word dAtomLen = do - e <- dExp - p <- dWordBits (e-1) - pure (2^e .|. p) + debugMId "dAtomLen" $ do + dExp >>= \case + 0 -> pure 0 + e -> do p <- dWordBits (e-1) + pure (2^(e-1) .|. p) dRef :: Get Word -dRef = dAtomLen >>= dWordBits +dRef = debugMId "dRef" (dAtomLen >>= dWordBits) dAtom :: Get Atom dAtom = do - n <- dAtomLen - dAtomBits n + debugMId "dAtom" $ do + dAtomLen >>= \case + 0 -> pure 0 + n -> dAtomBits n dCell :: Get Noun -dCell = Cell <$> dNoun <*> dNoun +dCell = debugMId "dCell" $ Cell <$> dNoun <*> dNoun {-| Get a Noun. @@ -323,12 +351,16 @@ dCell = Cell <$> dNoun <*> dNoun -} dNoun :: Get Noun dNoun = do + debugMId "dNoun" $ do p <- getPos let yield r = insRef p r >> pure r dBit >>= \case - False -> (Atom <$> dAtom) >>= yield + False -> do debugM "It's an atom" + (Atom <$> dAtom) >>= yield True -> dBit >>= \case - False -> dCell >>= yield - True -> dRef >>= getRef + False -> do debugM "It's a cell" + dCell >>= yield + True -> do debugM "It's a backref" + dRef >>= getRef diff --git a/pkg/hs-urbit/lib/Noun/Jam.hs b/pkg/hs-urbit/lib/Noun/Jam.hs index 4a2b3bef8..49f73c9c4 100644 --- a/pkg/hs-urbit/lib/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Noun/Jam.hs @@ -222,6 +222,9 @@ prop_fastJamSlow n = x == y || (bitWidth y <= bitWidth x && cue y == cue x) prop_fastRub :: Atom -> Bool prop_fastRub a = Right (Atom a) == Cue.cue (jam (Atom a)) +prop_fastCue :: Noun -> Bool +prop_fastCue n = Right n == Cue.cue (jam n) + prop_fastJam :: Noun -> Bool prop_fastJam n = Just n == cue (Jam.jam n) @@ -252,3 +255,9 @@ matSz' a = length s - 1 s :: String s = printf "%b" $ fromIntegral @Atom @Integer $ jam $ Atom a +(a, c) = (Atom, Cell) + +printJam :: Noun -> IO () +printJam n = do + j <- evaluate (force (fromIntegral $ jam n)) + printf "0b%b\n" (j :: Integer) diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 7e504b796..6bc71ba53 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -8,25 +8,42 @@ import Noun import Noun.Atom import Control.Lens import Noun.Jam.Fast (jam, jamBS) -import Noun.Jam (cue) +import Noun.Cue.Fast (cue, cueBS) -------------------------------------------------------------------------------- +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right x) = Just x + _CueBytes :: Prism' ByteString Noun -_CueBytes = prism' jamBS unJamBS - where unJamBS = preview (from pillBS . from pill . _Cue) +_CueBytes = prism' jamBS (eitherToMaybe . cueBS) _Cue :: Prism' Atom Noun -_Cue = prism' jam cue +_Cue = prism' jam (eitherToMaybe . cue) loadNoun :: FilePath -> IO (Maybe Noun) -loadNoun = fmap (preview $ from pillBS . from pill . _Cue) . readFile +loadNoun = fmap (preview _CueBytes) . readFile dumpJam :: FilePath -> Noun -> IO () -dumpJam fp = writeFile fp . view (re _Cue . pill . pillBS) +dumpJam fp = writeFile fp . view (re _CueBytes) tryCuePill :: PillFile -> IO () tryCuePill pill = loadNoun (show pill) >>= \case Nothing -> print "nil" Just (Atom _) -> print "atom" _ -> print "cell" + +tryCueJamPill :: PillFile -> IO () +tryCueJamPill pill = do + + n <- loadNoun (show pill) >>= \case + Nothing -> do print "failure" + pure (Atom 0) + Just (Atom a) -> do print "atom" + pure (Atom a) + Just (Cell h t) -> do print "cell" + pure (Cell h t) + + bs <- evaluate (force (jamBS n)) + + print ("jam size: " <> show (length bs)) diff --git a/pkg/hs-urbit/lib/Noun/Pill.hs b/pkg/hs-urbit/lib/Noun/Pill.hs index 6e17210fb..501943a29 100644 --- a/pkg/hs-urbit/lib/Noun/Pill.hs +++ b/pkg/hs-urbit/lib/Noun/Pill.hs @@ -177,9 +177,6 @@ pillWords = iso toVec fromVec toVec = view (pillBS . to bsToWords) fromVec = view (to wordsToBytes . bytesBS . from pillBS) --- _CueBytes :: Prism' ByteString Noun --- _CueBytes = from pillBS . from pill . _Cue - -------------------------------------------------------------------------------- {- @@ -208,9 +205,6 @@ atomBS = pill . pillBS -------------------------------------------------------------------------------- --- _Cue :: Prism' Atom Noun --- _Cue = prism' jam cue - _Tall :: Flat a => Prism' ByteString a _Tall = prism' flat (eitherToMaybe . unflat) where @@ -226,9 +220,6 @@ loadPill = fmap Pill . readFile loadAtom :: FilePath -> IO Atom loadAtom = fmap (view $ from pillBS . from pill) . readFile --- loadNoun :: FilePath -> IO (Maybe Noun) --- loadNoun = fmap (preview $ from pillBS . from pill . _Cue) . readFile - loadFlat :: Flat a => FilePath -> IO (Either Text a) loadFlat = fmap (mapLeft tshow . unflat) . readFile @@ -240,9 +231,6 @@ dumpPill fp = writeFile fp . view pillBS dumpAtom :: FilePath -> Atom -> IO () dumpAtom fp = writeFile fp . view (pill . pillBS) --- dumpJam :: FilePath -> Noun -> IO () --- dumpJam fp = writeFile fp . view (re _Cue . pill . pillBS) - dumpFlat :: Flat a => FilePath -> a -> IO () dumpFlat fp = writeFile fp . flat @@ -270,12 +258,6 @@ tryPackPill pf = do atm <- tryLoadPill pf print $ length (atm ^. pill . pillBS) --- tryCuePill :: PillFile -> IO () --- tryCuePill pill = - -- loadNoun (show pill) >>= \case Nothing -> print "nil" - -- Just (Atom _) -> print "atom" - -- _ -> print "cell" - -- Tests ----------------------------------------------------------------------- instance Arbitrary ByteString where diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index 56808d30e..b354e0b24 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/pkg/hs-vere/app/uterm/Main.hs @@ -9,20 +9,20 @@ import Noun.Lens main :: IO () main = do - print "load brass" >> void getLine + print "load brass" -- void getLine tryLoadPill Brass - print "load ivory" >> void getLine + print "load ivory" -- void getLine tryLoadPill Ivory - print "load solid" >> void getLine + print "load solid" -- void getLine tryLoadPill Solid - print "cue brass" >> void getLine - tryCuePill Brass + print "cue brass" -- void getLine + tryCueJamPill Brass - print "cue ivory" >> void getLine - tryCuePill Ivory + print "cue ivory" -- void getLine + tryCueJamPill Ivory - print "cue solid" >> void getLine - tryCuePill Solid + print "cue solid" -- void getLine + tryCueJamPill Solid From 221cb78c771bfe00105c356d5dcf8fe529443f1e Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 3 Jul 2019 17:53:21 -0700 Subject: [PATCH 098/431] Jam and cue are both quite fast now! 5 seconds to load+jam+cue all three pills. --- pkg/hs-urbit/lib/Noun/Cue/Fast.hs | 29 ++- pkg/hs-urbit/lib/Noun/Fat.hs | 408 ++++++++++++++++++++++++++++++ pkg/hs-urbit/lib/Noun/Jam/Fast.hs | 107 +++----- pkg/hs-urbit/lib/Noun/Lens.hs | 40 +-- pkg/hs-vere/app/uterm/Main.hs | 12 +- pkg/hs-vere/package.yaml | 4 +- stack.yaml | 6 +- 7 files changed, 503 insertions(+), 103 deletions(-) create mode 100644 pkg/hs-urbit/lib/Noun/Fat.hs diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index 655c55e23..a92905f49 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -1,9 +1,10 @@ {-# LANGUAGE MagicHash #-} -module Noun.Cue.Fast where +module Noun.Cue.Fast (cueFatBS, cueFat, cueBS, cue) where import ClassyPrelude import Noun +import Noun.Fat import Noun.Atom import Noun.Poet import Data.Bits hiding (Bits) @@ -36,11 +37,17 @@ import Test.QuickCheck hiding ((.&.)) -------------------------------------------------------------------------------- +cueFatBS :: ByteString -> Either DecodeExn FatNoun +cueFatBS = doGet dNoun + +cueFat :: Atom -> Either DecodeExn FatNoun +cueFat = cueFatBS . view atomBS + cueBS :: ByteString -> Either DecodeExn Noun -cueBS = doGet dNoun +cueBS = fmap fromFatNoun . cueFatBS cue :: Atom -> Either DecodeExn Noun -cue = cueBS . view atomBS +cue = fmap fromFatNoun . cueFat -- Debugging ------------------------------------------------------------------- @@ -89,7 +96,7 @@ data GetResult a = GetResult {-# UNPACK #-} !S !a newtype Get a = Get { runGet :: Ptr Word - -> H.LinearHashTable Word Noun + -> H.BasicHashTable Word FatNoun -> S -> IO (GetResult a) } @@ -100,7 +107,7 @@ doGet :: Get a -> ByteString -> Either DecodeExn a doGet m bs = unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do let endPtr = ptr `plusPtr` len - tbl <- H.new + tbl <- H.newSized 1000000 GetResult _ r <- runGet m endPtr tbl (S (castPtr ptr) 0 0) pure r @@ -156,12 +163,12 @@ getPos :: Get Word getPos = Get $ \_ _ s -> pure (GetResult s (pos s)) -insRef :: Word -> Noun -> Get () +insRef :: Word -> FatNoun -> Get () insRef pos now = Get \_ tbl s -> do H.insert tbl pos now pure $ GetResult s () -getRef :: Word -> Get Noun +getRef :: Word -> Get FatNoun getRef ref = Get \x tbl s -> do H.lookup tbl ref >>= \case Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s @@ -337,8 +344,8 @@ dAtom = do 0 -> pure 0 n -> dAtomBits n -dCell :: Get Noun -dCell = debugMId "dCell" $ Cell <$> dNoun <*> dNoun +dCell :: Get FatNoun +dCell = debugMId "dCell" $ fatCell <$> dNoun <*> dNoun {-| Get a Noun. @@ -349,7 +356,7 @@ dCell = debugMId "dCell" $ Cell <$> dNoun <*> dNoun - If it's zero, get a cell. - If it's one, get an atom. -} -dNoun :: Get Noun +dNoun :: Get FatNoun dNoun = do debugMId "dNoun" $ do p <- getPos @@ -358,7 +365,7 @@ dNoun = do dBit >>= \case False -> do debugM "It's an atom" - (Atom <$> dAtom) >>= yield + (fatAtom <$> dAtom) >>= yield True -> dBit >>= \case False -> do debugM "It's a cell" dCell >>= yield diff --git a/pkg/hs-urbit/lib/Noun/Fat.hs b/pkg/hs-urbit/lib/Noun/Fat.hs new file mode 100644 index 000000000..1e4a98356 --- /dev/null +++ b/pkg/hs-urbit/lib/Noun/Fat.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} + +module Noun.Fat ( FatNoun(..), fatSize, fatHash + , fatCell, fatAtom + , toFatNoun, fromFatNoun + , jamWordSz + , atomSz + ) where + +import ClassyPrelude hiding (hash) + +import Control.Lens (view, to, from) +import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.)) +import Noun.Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) +import Noun.Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) +import Noun (Noun(Atom, Cell)) +import Noun.Pill (bigNatWords, atomBS) +import Data.Vector.Primitive ((!)) +import Foreign.Marshal.Alloc (callocBytes, free) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (poke) +import GHC.Integer.GMP.Internals (BigNat) +import GHC.Int (Int(I#)) +import GHC.Natural (Natural(NatS#, NatJ#)) +import GHC.Prim (Word#, plusWord#, word2Int#, reallyUnsafePtrEquality#) +import GHC.Word (Word(W#)) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.ByteString.Unsafe as BS +import qualified Data.Hashable as Hash +import qualified Data.HashTable.IO as H +import qualified Data.Vector.Primitive as VP + + +-- Types ----------------------------------------------------------------------- + +{-| + The encoder state. + + - ptr: Pointer into the output buffer. + - reg: Next 64 bits of output, partially written. + - off: Number of bits already written into `reg` + - pos: Total number of bits written. +-} +data S = S + { ptr :: {-# UNPACK #-} !(Ptr Word) + , reg :: {-# UNPACK #-} !Word + , off :: {-# UNPACK #-} !Int + , pos :: {-# UNPACK #-} !Word + } deriving (Show,Eq,Ord) + +data PutResult a = PutResult {-# UNPACK #-} !S !a + deriving Functor + +newtype Put a = Put + { runPut :: H.LinearHashTable Word Word + -> S + -> IO (PutResult a) + } + +-------------------------------------------------------------------------------- + +{-# INLINE getRef #-} +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 #-} +flush :: Put () +flush = Put $ \tbl s@S{..} -> do + poke ptr reg + pure $ PutResult (s { ptr = ptr `plusPtr` 8 }) () + +{-# INLINE update #-} +update :: (S -> S) -> Put () +update f = Put \tbl s@S{..} -> pure (PutResult (f s) ()) + +{-# INLINE setRegOff #-} +setRegOff :: Word -> Int -> Put () +setRegOff r o = update \s@S{..} -> (s {reg=r, off=o}) + +{-# INLINE setReg #-} +setReg :: Word -> Put () +setReg r = update \s@S{..} -> (s { reg=r }) + +{-# INLINE getS #-} +getS :: Put S +getS = Put $ \tbl s -> pure (PutResult s s) + +{-# INLINE putS #-} +putS :: S -> Put () +putS s = Put $ \tbl _ -> pure (PutResult s ()) + +{- + To write a bit: + + | reg |= 1 << off + | off <- (off + 1) % 64 + | if (!off): + | buf[w++] <- reg + | reg <- 0 +-} +{-# INLINE writeBit #-} +writeBit :: Bool -> Put () +writeBit b = Put $ \tbl s@S{..} -> do + let s' = s { reg = (if b then setBit else clearBit) reg off + , off = (off + 1) `mod` 64 + , pos = pos + 1 + } + + if off == 63 + then runPut (flush >> setRegOff 0 0) tbl s' + else pure $ PutResult s' () + +{- + To write a 64bit word: + + | reg |= w << off + | buf[bufI++] = reg + | reg = w >> (64 - off) +-} +{-# INLINE writeWord #-} +writeWord :: Word -> Put () +writeWord wor = do + S{..} <- getS + setReg (reg .|. shiftL wor off) + flush + update \s -> s { pos = 64 + pos + , reg = shiftR wor (64 - off) + } + +{- + To write some bits (< 64) from a word: + + | wor = takeBits(wid, wor) + | reg = reg .|. (wor << off) + | off = (off + wid) % 64 + | + | if (off + wid >= 64) + | buf[w] = x + | reg = wor >> (wid - off) +-} +{-# INLINE writeBitsFromWord #-} +writeBitsFromWord :: Int -> Word -> Put () +writeBitsFromWord wid wor = do + wor <- pure (takeBitsWord wid wor) + + oldSt <- getS + + let newSt = oldSt { reg = reg oldSt .|. shiftL wor (off oldSt) + , off = (off oldSt + wid) `mod` 64 + , pos = fromIntegral wid + pos oldSt + } + + putS newSt + + when (wid + off oldSt >= 64) $ do + flush + setReg (shiftR wor (wid - off newSt)) +{- + Write all of the the signficant bits of a direct atom. +-} +{-# INLINE writeAtomWord# #-} +writeAtomWord# :: Word# -> Put () +writeAtomWord# w = do + writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) + +{-# INLINE writeAtomWord #-} +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. +-} +{-# INLINE writeAtomBigNat #-} +writeAtomBigNat :: BigNat -> Put () +writeAtomBigNat (view bigNatWords -> words) = do + let lastIdx = VP.length words - 1 + for_ [0..(lastIdx-1)] \i -> + writeWord (words ! i) + writeAtomWord (words ! lastIdx) + +{-# INLINE writeAtomBits #-} +writeAtomBits :: Atom -> Put () +writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd + MkAtom (NatJ# bn) -> writeAtomBigNat bn + + +-- Put Instances --------------------------------------------------------------- + +instance Functor Put where + fmap f g = Put $ \tbl s -> do + PutResult s' a <- runPut g tbl s + pure $ PutResult s' (f a) + {-# INLINE fmap #-} + +instance Applicative Put where + pure x = Put (\_ s -> return $ PutResult s x) + {-# INLINE pure #-} + + Put f <*> Put g = Put $ \tbl s1 -> do + PutResult s2 f' <- f tbl s1 + PutResult s3 g' <- g tbl s2 + return $ PutResult s3 (f' g') + {-# INLINE (<*>) #-} + + Put f *> Put g = Put $ \tbl s1 -> do + PutResult s2 _ <- f tbl s1 + g tbl s2 + {-# INLINE (*>) #-} + +instance Monad Put where + return = pure + {-# INLINE return #-} + + (>>) = (*>) + {-# INLINE (>>) #-} + + Put x >>= f = Put $ \tbl s -> do + PutResult s' x' <- x tbl s + runPut (f x') tbl s' + {-# INLINE (>>=) #-} + + +-------------------------------------------------------------------------------- + +doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString +doPut tbl sz m = + unsafePerformIO $ do + traceM "doPut" + buf <- callocBytes (fromIntegral (wordSz*8)) + _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) + BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf) + where + wordSz = fromIntegral (sz `divUp` 64) + byteSz = fromIntegral (sz `divUp` 8) + divUp = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1) + + mbFlush :: Put () + mbFlush = do + shouldFlush <- (/= 0) . off <$> getS + when shouldFlush flush + + +-------------------------------------------------------------------------------- + +{- + TODO Handle back references +-} +writeNoun :: Noun -> Put () +writeNoun n = + getRef >>= \case + Just bk -> writeBackRef bk + Nothing -> case n of Atom a -> writeAtom a + Cell h t -> writeCell h t + +{-# INLINE writeMat #-} +writeMat :: Atom -> Put () +writeMat 0 = writeBit True +writeMat atm = do + writeBitsFromWord (preWid+1) (shiftL 1 preWid) + writeBitsFromWord (preWid-1) atmWid + writeAtomBits atm + where + atmWid = bitWidth atm + preWid = fromIntegral (wordBitWidth atmWid) + +{-# INLINE writeCell #-} +writeCell :: Noun -> Noun -> Put () +writeCell h t = do + writeBit True + writeBit False + writeNoun h + writeNoun t + +{-# INLINE writeAtom #-} +writeAtom :: Atom -> Put () +writeAtom a = do + writeBit False + writeMat a + +{-# INLINE writeBackRef #-} +writeBackRef :: Word -> Put () +writeBackRef a = do + p <- pos <$> getS + writeBit True + writeBit True + writeMat (toAtom a) + + +-- Compute Hashes and Jam Size (with no backrefs) ------------------------------ + +data FatNoun + = FatCell {-# UNPACK #-} !Word + {-# UNPACK #-} !Int + !FatNoun + !FatNoun + | FatWord {-# UNPACK #-} !Word + | FatAtom {-# UNPACK #-} !Word + {-# UNPACK #-} !Int + {-# UNPACK #-} !BigNat + deriving (Show) + +{-# INLINE fatSize #-} +fatSize :: FatNoun -> Word +fatSize = \case + FatCell s _ _ _ -> s + FatAtom s _ _ -> s + FatWord w -> atomSz (fromIntegral w) + +{-# INLINE fatHash #-} +fatHash :: FatNoun -> Int +fatHash = \case + FatCell _ h _ _ -> h + FatAtom _ h _ -> h + FatWord w -> Hash.hash w + +instance Hashable FatNoun where + hash = fatHash + {-# INLINE hash #-} + hashWithSalt = defaultHashWithSalt + {-# INLINE hashWithSalt #-} + +instance Eq FatNoun where + (==) x y = + case reallyUnsafePtrEquality# x y of + 1# -> True + 0# -> case (x, y) of + (FatWord w1, FatWord w2 ) -> + w1==w2 + (FatAtom s1 x1 a1, FatAtom s2 x2 a2 ) -> + s1==s2 && x1==x2 && a1==a2 + (FatCell s1 x1 h1 t1, FatCell s2 x2 h2 t2) -> + s1==s2 && x1==x2 && h1==h2 && t1==t2 + (_, _ ) -> + False + {-# INLINE (==) #-} + + +-------------------------------------------------------------------------------- + +{-# INLINE fatAtom #-} +fatAtom :: Atom -> FatNoun +fatAtom = \case + a@(MkAtom (NatS# w)) -> FatWord (W# w) + a@(MkAtom n@(NatJ# bn)) -> FatAtom (atomSz a) (Hash.hash bn) bn + +{-# INLINE fatCell #-} +fatCell :: FatNoun -> FatNoun -> FatNoun +fatCell h t = FatCell siz has h t + where + siz = 2 + fatSize h + fatSize t + has = fatHash h `combine` fatHash t + +{-# INLINE jamWordSz #-} +jamWordSz :: Word -> Word +jamWordSz 0 = 2 +jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW) + where + atmW = wordBitWidth# w + preW = wordBitWidth# atmW + +{-# INLINE atomSz #-} +atomSz :: Atom -> Word +atomSz = (1+) . matSz + +{-# INLINE matSz #-} +matSz :: Atom -> Word +matSz a = W# (matSz# a) + +{-# INLINE matSz# #-} +matSz# :: Atom -> Word# +matSz# 0 = 1## +matSz# a = preW `plusWord#` preW `plusWord#` atmW + where + atmW = atomBitWidth# a + preW = wordBitWidth# atmW + +{-# INLINE toFatNoun #-} +toFatNoun :: Noun -> FatNoun +toFatNoun = trace "toFatNoun" . go + where + go (Atom a) = fatAtom a + go (Cell h t) = fatCell (go h) (go t) + +{-# INLINE fromFatNoun #-} +fromFatNoun :: FatNoun -> Noun +fromFatNoun = trace "fromFatNoun" . go + where go = \case + FatAtom _ _ a -> Atom (MkAtom $ NatJ# a) + FatCell _ _ h t -> Cell (go h) (go t) + FatWord w -> Atom (fromIntegral w) + + +-- Stolen from Hashable Library ------------------------------------------------ + +{-# INLINE combine #-} +combine :: Int -> Int -> Int +combine h1 h2 = (h1 * 16777619) `xor` h2 + +{-# INLINE defaultHashWithSalt #-} +defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt salt x = salt `combine` Hash.hash x diff --git a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs index ee3d76dcc..7b0e41fcf 100644 --- a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} -module Noun.Jam.Fast (jam, jamBS) where +module Noun.Jam.Fast (jam, jamBS, jamFat, jamFatBS) where import ClassyPrelude hiding (hash) @@ -10,6 +10,7 @@ import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.)) import Noun.Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) import Noun.Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) import Noun (Noun(Atom, Cell)) +import Noun.Fat import Noun.Pill (bigNatWords, atomBS) import Data.Vector.Primitive ((!)) import Foreign.Marshal.Alloc (callocBytes, free) @@ -30,13 +31,19 @@ import qualified Data.Vector.Primitive as VP -- Exports --------------------------------------------------------------------- -jamBS :: Noun -> ByteString -jamBS n = doPut bt sz (writeNoun n) +jamFatBS :: FatNoun -> ByteString +jamFatBS n = doPut bt sz (writeNoun n) where - (sz, bt) = unsafePerformIO (compress $ toBigNoun n) + (sz, bt) = unsafePerformIO (compress n) + +jamFat :: FatNoun -> Atom +jamFat = view (from atomBS) . jamFatBS + +jamBS :: Noun -> ByteString +jamBS = jamFatBS . toFatNoun jam :: Noun -> Atom -jam = view (to jamBS . from atomBS) +jam = jamFat . toFatNoun -- Types ----------------------------------------------------------------------- @@ -60,7 +67,7 @@ data PutResult a = PutResult {-# UNPACK #-} !S !a deriving Functor newtype Put a = Put - { runPut :: H.LinearHashTable Word Word + { runPut :: H.CuckooHashTable Word Word -> S -> IO (PutResult a) } @@ -235,9 +242,10 @@ instance Monad Put where -------------------------------------------------------------------------------- -doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString +doPut :: H.CuckooHashTable Word Word -> Word -> Put () -> ByteString doPut tbl sz m = unsafePerformIO $ do + traceM "doPut" buf <- callocBytes (fromIntegral (wordSz*8)) _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf) @@ -257,12 +265,13 @@ doPut tbl sz m = {- TODO Handle back references -} -writeNoun :: Noun -> Put () +writeNoun :: FatNoun -> Put () writeNoun n = getRef >>= \case Just bk -> writeBackRef bk - Nothing -> case n of Atom a -> writeAtom a - Cell h t -> writeCell h t + Nothing -> case n of FatAtom _ _ n -> writeAtom (MkAtom $ NatJ# n) + FatWord (W# w) -> writeAtom (MkAtom $ NatS# w) + FatCell _ _ h t -> writeCell h t {-# INLINE writeMat #-} writeMat :: Atom -> Put () @@ -276,7 +285,7 @@ writeMat atm = do preWid = fromIntegral (wordBitWidth atmWid) {-# INLINE writeCell #-} -writeCell :: Noun -> Noun -> Put () +writeCell :: FatNoun -> FatNoun -> Put () writeCell h t = do writeBit True writeBit False @@ -298,45 +307,6 @@ writeBackRef a = do writeMat (toAtom a) --- Compute Hashes and Jam Size (with no backrefs) ------------------------------ - -data BigNoun - = BigCell { bSize :: {-# UNPACK #-} !Word - , bHash :: {-# UNPACK #-} !Int - , bHead :: BigNoun - , bTail :: BigNoun - } - | BigAtom { bSize :: {-# UNPACK #-} !Word - , bHash :: {-# UNPACK #-} !Int - , bAtom :: {-# UNPACK #-} !Atom - } - deriving (Show) - -instance Hashable BigNoun where - hash = bHash - {-# INLINE hash #-} - hashWithSalt = defaultHashWithSalt - {-# INLINE hashWithSalt #-} - -instance Eq BigNoun where - BigAtom s1 _ a1 == BigAtom s2 _ a2 = s1==s2 && a1==a2 - BigCell s1 _ h1 t1 == BigCell s2 _ h2 t2 = s1==s2 && h1==h2 && t1==t2 - _ == _ = False - {-# INLINE (==) #-} - -{-# INLINE toBigNoun #-} -toBigNoun :: Noun -> BigNoun -toBigNoun = go - where - go (Atom a) = BigAtom (1 + matSz a) (Hash.hash a) a - go (Cell h t) = BigCell siz has hed tel - where - hed = toBigNoun h - tel = toBigNoun t - siz = 2 + bSize hed + bSize tel - has = fromIntegral siz `combine` bHash hed `combine` bHash tel - - -- Calculate Jam Size and Backrefs --------------------------------------------- {-# INLINE matSz #-} @@ -351,36 +321,41 @@ matSz# a = preW `plusWord#` preW `plusWord#` atmW atmW = atomBitWidth# a preW = wordBitWidth# atmW -{-# INLINE refSz# #-} -refSz# :: Word# -> Word# -refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) +{-# INLINE refSz #-} +refSz :: Word -> Word +refSz w = 1 + (jamWordSz w) -compress :: BigNoun -> IO (Word, H.LinearHashTable Word Word) +compress :: FatNoun -> IO (Word, H.CuckooHashTable Word Word) compress top = do - nodes :: H.LinearHashTable BigNoun Word <- H.new - backs :: H.LinearHashTable Word Word <- H.new + traceM "" + nodes :: H.BasicHashTable FatNoun Word <- H.newSized 1000000 + backs :: H.CuckooHashTable Word Word <- H.newSized 1000000 - let proc :: Word -> BigNoun -> IO Word + let proc :: Word -> FatNoun -> IO Word proc pos = \case - BigAtom _ _ a -> pure (1 + matSz a) - BigCell _ _ h t -> do - hSz <- go (pos+2) h - tSz <- go (pos+2+hSz) t + n@(FatAtom s _ _) -> pure s + FatWord w -> pure (jamWordSz w) + FatCell _ _ h t -> do + !hSz <- go (pos+2) h + !tSz <- go (pos+2+hSz) t pure (2+hSz+tSz) - go :: Word -> BigNoun -> IO Word + go :: Word -> FatNoun -> IO Word go p inp = do H.lookup nodes inp >>= \case Nothing -> do H.insert nodes inp p proc p inp - Just bak@(W# bakRaw) -> do - let refSz = W# (refSz# bakRaw) - if (refSz < bSize inp) - then H.insert backs p bak $> refSz + Just bak -> do + let rs = refSz bak + if (rs < fatSize inp) + then do H.insert backs p bak + pure rs else proc p inp res <- go 0 top + traceM "" + print res pure (res, backs) diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 6bc71ba53..8c828cbee 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -4,46 +4,56 @@ module Noun.Lens where import ClassyPrelude import Noun.Pill +import Noun.Fat import Noun import Noun.Atom import Control.Lens -import Noun.Jam.Fast (jam, jamBS) -import Noun.Cue.Fast (cue, cueBS) +import Noun.Jam.Fast (jam, jamBS, jamFat, jamFatBS) +import Noun.Cue.Fast (cue, cueBS, cueFat, cueFatBS) -------------------------------------------------------------------------------- eitherToMaybe (Left _) = Nothing eitherToMaybe (Right x) = Just x +_CueFatBytes :: Prism' ByteString FatNoun +_CueFatBytes = prism' jamFatBS (eitherToMaybe . cueFatBS) + +_CueFat :: Prism' Atom FatNoun +_CueFat = prism' jamFat (eitherToMaybe . cueFat) + _CueBytes :: Prism' ByteString Noun _CueBytes = prism' jamBS (eitherToMaybe . cueBS) _Cue :: Prism' Atom Noun _Cue = prism' jam (eitherToMaybe . cue) -loadNoun :: FilePath -> IO (Maybe Noun) -loadNoun = fmap (preview _CueBytes) . readFile +-------------------------------------------------------------------------------- -dumpJam :: FilePath -> Noun -> IO () -dumpJam fp = writeFile fp . view (re _CueBytes) +loadNoun :: FilePath -> IO (Maybe FatNoun) +loadNoun = fmap (preview _CueFatBytes) . readFile + +dumpJam :: FilePath -> FatNoun -> IO () +dumpJam fp = writeFile fp . view (re _CueFatBytes) tryCuePill :: PillFile -> IO () tryCuePill pill = - loadNoun (show pill) >>= \case Nothing -> print "nil" - Just (Atom _) -> print "atom" - _ -> print "cell" + loadNoun (show pill) >>= \case Nothing -> print "nil" + Just (FatAtom _ _ _) -> print "atom" + Just (FatWord _) -> print "word" + _ -> print "cell" tryCueJamPill :: PillFile -> IO () tryCueJamPill pill = do n <- loadNoun (show pill) >>= \case Nothing -> do print "failure" - pure (Atom 0) - Just (Atom a) -> do print "atom" - pure (Atom a) - Just (Cell h t) -> do print "cell" - pure (Cell h t) + pure (FatWord 0) + Just n@(FatAtom _ _ _) -> do print "atom" + pure n + Just n@(FatCell _ _ _ _) -> do print "cell" + pure n - bs <- evaluate (force (jamBS n)) + bs <- evaluate (force (jamFatBS n)) print ("jam size: " <> show (length bs)) diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index b354e0b24..4341c96f7 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/pkg/hs-vere/app/uterm/Main.hs @@ -9,14 +9,14 @@ import Noun.Lens main :: IO () main = do - print "load brass" -- void getLine - tryLoadPill Brass + -- print "load brass" -- void getLine + -- tryLoadPill Brass - print "load ivory" -- void getLine - tryLoadPill Ivory + -- print "load ivory" -- void getLine + -- tryLoadPill Ivory - print "load solid" -- void getLine - tryLoadPill Solid + -- print "load solid" -- void getLine + -- tryLoadPill Solid print "cue brass" -- void getLine tryCueJamPill Brass diff --git a/pkg/hs-vere/package.yaml b/pkg/hs-vere/package.yaml index cbe718f9f..ba610bbb7 100644 --- a/pkg/hs-vere/package.yaml +++ b/pkg/hs-vere/package.yaml @@ -10,7 +10,7 @@ executables: ghc-options: - -threaded - -rtsopts - - "-with-rtsopts=-H128m" + - "-with-rtsopts=-H1024m" - -fwarn-incomplete-patterns - -O2 @@ -21,7 +21,7 @@ executables: ghc-options: - -threaded - -rtsopts - - "-with-rtsopts=-H128m" + - "-with-rtsopts=-H4096m" - -fwarn-incomplete-patterns - -O2 diff --git a/stack.yaml b/stack.yaml index 00bb63e7f..73308fae0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,10 +18,10 @@ nix: - SDL2_image - zlib -ghc-options: - urbit: '-fobject-code' +# ghc-options: +# urbit: '-fobject-code' # build: -# library-profiling: true # executable-profiling: true # executable-stripping: false +# library-profiling: true From 54dd7a93f5a84c52e23f4ceea2f8f186474845b4 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 3 Jul 2019 21:01:40 -0700 Subject: [PATCH 099/431] Jam/Cue: Cleanup --- pkg/hs-urbit/lib/Noun/Cue/Fast.hs | 5 +- pkg/hs-urbit/lib/Noun/Fat.hs | 377 +++--------------------------- pkg/hs-urbit/lib/Noun/Jam/Fast.hs | 51 ++-- pkg/hs-urbit/lib/Noun/Lens.hs | 8 +- stack.yaml | 4 +- 5 files changed, 78 insertions(+), 367 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index a92905f49..319506f1d 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -107,7 +107,7 @@ doGet :: Get a -> ByteString -> Either DecodeExn a doGet m bs = unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do let endPtr = ptr `plusPtr` len - tbl <- H.newSized 1000000 + tbl <- H.new -- Sized 1000000 GetResult _ r <- runGet m endPtr tbl (S (castPtr ptr) 0 0) pure r @@ -345,7 +345,7 @@ dAtom = do n -> dAtomBits n dCell :: Get FatNoun -dCell = debugMId "dCell" $ fatCell <$> dNoun <*> dNoun +dCell = fatCell <$> dNoun <*> dNoun {-| Get a Noun. @@ -358,7 +358,6 @@ dCell = debugMId "dCell" $ fatCell <$> dNoun <*> dNoun -} dNoun :: Get FatNoun dNoun = do - debugMId "dNoun" $ do p <- getPos let yield r = insRef p r >> pure r diff --git a/pkg/hs-urbit/lib/Noun/Fat.hs b/pkg/hs-urbit/lib/Noun/Fat.hs index 1e4a98356..dd7c25933 100644 --- a/pkg/hs-urbit/lib/Noun/Fat.hs +++ b/pkg/hs-urbit/lib/Noun/Fat.hs @@ -1,324 +1,39 @@ +{-| + Nouns with Pre-Computed Hash for each node. +-} + {-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} -module Noun.Fat ( FatNoun(..), fatSize, fatHash - , fatCell, fatAtom +module Noun.Fat ( FatNoun(..) + , fatHash, fatCell, fatAtom , toFatNoun, fromFatNoun - , jamWordSz - , atomSz ) where import ClassyPrelude hiding (hash) -import Control.Lens (view, to, from) -import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.)) -import Noun.Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) -import Noun.Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) -import Noun (Noun(Atom, Cell)) -import Noun.Pill (bigNatWords, atomBS) -import Data.Vector.Primitive ((!)) -import Foreign.Marshal.Alloc (callocBytes, free) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (poke) +import Data.Bits (xor) +import Data.Hashable (hash) import GHC.Integer.GMP.Internals (BigNat) -import GHC.Int (Int(I#)) import GHC.Natural (Natural(NatS#, NatJ#)) -import GHC.Prim (Word#, plusWord#, word2Int#, reallyUnsafePtrEquality#) +import GHC.Prim (reallyUnsafePtrEquality#) import GHC.Word (Word(W#)) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Data.ByteString.Unsafe as BS -import qualified Data.Hashable as Hash -import qualified Data.HashTable.IO as H -import qualified Data.Vector.Primitive as VP - - --- Types ----------------------------------------------------------------------- - -{-| - The encoder state. - - - ptr: Pointer into the output buffer. - - reg: Next 64 bits of output, partially written. - - off: Number of bits already written into `reg` - - pos: Total number of bits written. --} -data S = S - { ptr :: {-# UNPACK #-} !(Ptr Word) - , reg :: {-# UNPACK #-} !Word - , off :: {-# UNPACK #-} !Int - , pos :: {-# UNPACK #-} !Word - } deriving (Show,Eq,Ord) - -data PutResult a = PutResult {-# UNPACK #-} !S !a - deriving Functor - -newtype Put a = Put - { runPut :: H.LinearHashTable Word Word - -> S - -> IO (PutResult a) - } - --------------------------------------------------------------------------------- - -{-# INLINE getRef #-} -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 #-} -flush :: Put () -flush = Put $ \tbl s@S{..} -> do - poke ptr reg - pure $ PutResult (s { ptr = ptr `plusPtr` 8 }) () - -{-# INLINE update #-} -update :: (S -> S) -> Put () -update f = Put \tbl s@S{..} -> pure (PutResult (f s) ()) - -{-# INLINE setRegOff #-} -setRegOff :: Word -> Int -> Put () -setRegOff r o = update \s@S{..} -> (s {reg=r, off=o}) - -{-# INLINE setReg #-} -setReg :: Word -> Put () -setReg r = update \s@S{..} -> (s { reg=r }) - -{-# INLINE getS #-} -getS :: Put S -getS = Put $ \tbl s -> pure (PutResult s s) - -{-# INLINE putS #-} -putS :: S -> Put () -putS s = Put $ \tbl _ -> pure (PutResult s ()) - -{- - To write a bit: - - | reg |= 1 << off - | off <- (off + 1) % 64 - | if (!off): - | buf[w++] <- reg - | reg <- 0 --} -{-# INLINE writeBit #-} -writeBit :: Bool -> Put () -writeBit b = Put $ \tbl s@S{..} -> do - let s' = s { reg = (if b then setBit else clearBit) reg off - , off = (off + 1) `mod` 64 - , pos = pos + 1 - } - - if off == 63 - then runPut (flush >> setRegOff 0 0) tbl s' - else pure $ PutResult s' () - -{- - To write a 64bit word: - - | reg |= w << off - | buf[bufI++] = reg - | reg = w >> (64 - off) --} -{-# INLINE writeWord #-} -writeWord :: Word -> Put () -writeWord wor = do - S{..} <- getS - setReg (reg .|. shiftL wor off) - flush - update \s -> s { pos = 64 + pos - , reg = shiftR wor (64 - off) - } - -{- - To write some bits (< 64) from a word: - - | wor = takeBits(wid, wor) - | reg = reg .|. (wor << off) - | off = (off + wid) % 64 - | - | if (off + wid >= 64) - | buf[w] = x - | reg = wor >> (wid - off) --} -{-# INLINE writeBitsFromWord #-} -writeBitsFromWord :: Int -> Word -> Put () -writeBitsFromWord wid wor = do - wor <- pure (takeBitsWord wid wor) - - oldSt <- getS - - let newSt = oldSt { reg = reg oldSt .|. shiftL wor (off oldSt) - , off = (off oldSt + wid) `mod` 64 - , pos = fromIntegral wid + pos oldSt - } - - putS newSt - - when (wid + off oldSt >= 64) $ do - flush - setReg (shiftR wor (wid - off newSt)) -{- - Write all of the the signficant bits of a direct atom. --} -{-# INLINE writeAtomWord# #-} -writeAtomWord# :: Word# -> Put () -writeAtomWord# w = do - writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) - -{-# INLINE writeAtomWord #-} -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. --} -{-# INLINE writeAtomBigNat #-} -writeAtomBigNat :: BigNat -> Put () -writeAtomBigNat (view bigNatWords -> words) = do - let lastIdx = VP.length words - 1 - for_ [0..(lastIdx-1)] \i -> - writeWord (words ! i) - writeAtomWord (words ! lastIdx) - -{-# INLINE writeAtomBits #-} -writeAtomBits :: Atom -> Put () -writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd - MkAtom (NatJ# bn) -> writeAtomBigNat bn - - --- Put Instances --------------------------------------------------------------- - -instance Functor Put where - fmap f g = Put $ \tbl s -> do - PutResult s' a <- runPut g tbl s - pure $ PutResult s' (f a) - {-# INLINE fmap #-} - -instance Applicative Put where - pure x = Put (\_ s -> return $ PutResult s x) - {-# INLINE pure #-} - - Put f <*> Put g = Put $ \tbl s1 -> do - PutResult s2 f' <- f tbl s1 - PutResult s3 g' <- g tbl s2 - return $ PutResult s3 (f' g') - {-# INLINE (<*>) #-} - - Put f *> Put g = Put $ \tbl s1 -> do - PutResult s2 _ <- f tbl s1 - g tbl s2 - {-# INLINE (*>) #-} - -instance Monad Put where - return = pure - {-# INLINE return #-} - - (>>) = (*>) - {-# INLINE (>>) #-} - - Put x >>= f = Put $ \tbl s -> do - PutResult s' x' <- x tbl s - runPut (f x') tbl s' - {-# INLINE (>>=) #-} +import Noun.Atom (Atom(MkAtom)) +import Noun (Noun(Atom, Cell)) -------------------------------------------------------------------------------- -doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString -doPut tbl sz m = - unsafePerformIO $ do - traceM "doPut" - buf <- callocBytes (fromIntegral (wordSz*8)) - _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) - BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf) - where - wordSz = fromIntegral (sz `divUp` 64) - byteSz = fromIntegral (sz `divUp` 8) - divUp = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1) - - mbFlush :: Put () - mbFlush = do - shouldFlush <- (/= 0) . off <$> getS - when shouldFlush flush - - --------------------------------------------------------------------------------- - -{- - TODO Handle back references --} -writeNoun :: Noun -> Put () -writeNoun n = - getRef >>= \case - Just bk -> writeBackRef bk - Nothing -> case n of Atom a -> writeAtom a - Cell h t -> writeCell h t - -{-# INLINE writeMat #-} -writeMat :: Atom -> Put () -writeMat 0 = writeBit True -writeMat atm = do - writeBitsFromWord (preWid+1) (shiftL 1 preWid) - writeBitsFromWord (preWid-1) atmWid - writeAtomBits atm - where - atmWid = bitWidth atm - preWid = fromIntegral (wordBitWidth atmWid) - -{-# INLINE writeCell #-} -writeCell :: Noun -> Noun -> Put () -writeCell h t = do - writeBit True - writeBit False - writeNoun h - writeNoun t - -{-# INLINE writeAtom #-} -writeAtom :: Atom -> Put () -writeAtom a = do - writeBit False - writeMat a - -{-# INLINE writeBackRef #-} -writeBackRef :: Word -> Put () -writeBackRef a = do - p <- pos <$> getS - writeBit True - writeBit True - writeMat (toAtom a) - - --- Compute Hashes and Jam Size (with no backrefs) ------------------------------ - data FatNoun - = FatCell {-# UNPACK #-} !Word - {-# UNPACK #-} !Int + = FatCell {-# UNPACK #-} !Int !FatNoun !FatNoun | FatWord {-# UNPACK #-} !Word - | FatAtom {-# UNPACK #-} !Word - {-# UNPACK #-} !Int + | FatAtom {-# UNPACK #-} !Int {-# UNPACK #-} !BigNat - deriving (Show) -{-# INLINE fatSize #-} -fatSize :: FatNoun -> Word -fatSize = \case - FatCell s _ _ _ -> s - FatAtom s _ _ -> s - FatWord w -> atomSz (fromIntegral w) -{-# INLINE fatHash #-} -fatHash :: FatNoun -> Int -fatHash = \case - FatCell _ h _ _ -> h - FatAtom _ h _ -> h - FatWord w -> Hash.hash w +-------------------------------------------------------------------------------- instance Hashable FatNoun where hash = fatHash @@ -330,71 +45,53 @@ instance Eq FatNoun where (==) x y = case reallyUnsafePtrEquality# x y of 1# -> True - 0# -> case (x, y) of - (FatWord w1, FatWord w2 ) -> + _ -> case (x, y) of + (FatWord w1, FatWord w2 ) -> w1==w2 - (FatAtom s1 x1 a1, FatAtom s2 x2 a2 ) -> - s1==s2 && x1==x2 && a1==a2 - (FatCell s1 x1 h1 t1, FatCell s2 x2 h2 t2) -> - s1==s2 && x1==x2 && h1==h2 && t1==t2 - (_, _ ) -> + (FatAtom x1 a1, FatAtom x2 a2 ) -> + x1==x2 && a1==a2 + (FatCell x1 h1 t1, FatCell x2 h2 t2) -> + x1==x2 && h1==h2 && t1==t2 + (_, _ ) -> False {-# INLINE (==) #-} -------------------------------------------------------------------------------- +{-# INLINE fatHash #-} +fatHash :: FatNoun -> Int +fatHash = \case + FatCell h _ _ -> h + FatAtom h _ -> h + FatWord w -> hash w + {-# INLINE fatAtom #-} fatAtom :: Atom -> FatNoun fatAtom = \case - a@(MkAtom (NatS# w)) -> FatWord (W# w) - a@(MkAtom n@(NatJ# bn)) -> FatAtom (atomSz a) (Hash.hash bn) bn + MkAtom (NatS# wd) -> FatWord (W# wd) + MkAtom n@(NatJ# bn) -> FatAtom (hash bn) bn {-# INLINE fatCell #-} fatCell :: FatNoun -> FatNoun -> FatNoun -fatCell h t = FatCell siz has h t +fatCell h t = FatCell has h t where - siz = 2 + fatSize h + fatSize t has = fatHash h `combine` fatHash t -{-# INLINE jamWordSz #-} -jamWordSz :: Word -> Word -jamWordSz 0 = 2 -jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW) - where - atmW = wordBitWidth# w - preW = wordBitWidth# atmW - -{-# INLINE atomSz #-} -atomSz :: Atom -> Word -atomSz = (1+) . matSz - -{-# INLINE matSz #-} -matSz :: Atom -> Word -matSz a = W# (matSz# a) - -{-# INLINE matSz# #-} -matSz# :: Atom -> Word# -matSz# 0 = 1## -matSz# a = preW `plusWord#` preW `plusWord#` atmW - where - atmW = atomBitWidth# a - preW = wordBitWidth# atmW - {-# INLINE toFatNoun #-} toFatNoun :: Noun -> FatNoun -toFatNoun = trace "toFatNoun" . go +toFatNoun = go where go (Atom a) = fatAtom a go (Cell h t) = fatCell (go h) (go t) {-# INLINE fromFatNoun #-} fromFatNoun :: FatNoun -> Noun -fromFatNoun = trace "fromFatNoun" . go +fromFatNoun = go where go = \case - FatAtom _ _ a -> Atom (MkAtom $ NatJ# a) - FatCell _ _ h t -> Cell (go h) (go t) - FatWord w -> Atom (fromIntegral w) + FatAtom _ a -> Atom (MkAtom $ NatJ# a) + FatCell _ h t -> Cell (go h) (go t) + FatWord w -> Atom (fromIntegral w) -- Stolen from Hashable Library ------------------------------------------------ @@ -405,4 +102,4 @@ combine h1 h2 = (h1 * 16777619) `xor` h2 {-# INLINE defaultHashWithSalt #-} defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt salt x = salt `combine` Hash.hash x +defaultHashWithSalt salt x = salt `combine` hash x diff --git a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs index 7b0e41fcf..1974491f9 100644 --- a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs @@ -245,7 +245,7 @@ instance Monad Put where doPut :: H.CuckooHashTable Word Word -> Word -> Put () -> ByteString doPut tbl sz m = unsafePerformIO $ do - traceM "doPut" + -- traceM "doPut" buf <- callocBytes (fromIntegral (wordSz*8)) _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf) @@ -269,9 +269,9 @@ writeNoun :: FatNoun -> Put () writeNoun n = getRef >>= \case Just bk -> writeBackRef bk - Nothing -> case n of FatAtom _ _ n -> writeAtom (MkAtom $ NatJ# n) - FatWord (W# w) -> writeAtom (MkAtom $ NatS# w) - FatCell _ _ h t -> writeCell h t + Nothing -> case n of FatAtom _ n -> writeAtom (MkAtom $ NatJ# n) + FatWord (W# w) -> writeAtom (MkAtom $ NatS# w) + FatCell _ h t -> writeCell h t {-# INLINE writeMat #-} writeMat :: Atom -> Put () @@ -321,21 +321,33 @@ matSz# a = preW `plusWord#` preW `plusWord#` atmW atmW = atomBitWidth# a preW = wordBitWidth# atmW +{-# INLINE atomSz #-} +atomSz :: Atom -> Word +atomSz = (1+) . matSz + {-# INLINE refSz #-} refSz :: Word -> Word -refSz w = 1 + (jamWordSz w) +refSz = (1+) . jamWordSz + +{-# INLINE jamWordSz #-} +jamWordSz :: Word -> Word +jamWordSz 0 = 2 +jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW) + where + atmW = wordBitWidth# w + preW = wordBitWidth# atmW compress :: FatNoun -> IO (Word, H.CuckooHashTable Word Word) compress top = do - traceM "" - nodes :: H.BasicHashTable FatNoun Word <- H.newSized 1000000 - backs :: H.CuckooHashTable Word Word <- H.newSized 1000000 + -- traceM "" + nodes :: H.BasicHashTable FatNoun Word <- H.new -- Sized 1000000 + backs :: H.CuckooHashTable Word Word <- H.new -- Sized 1000000 let proc :: Word -> FatNoun -> IO Word proc pos = \case - n@(FatAtom s _ _) -> pure s - FatWord w -> pure (jamWordSz w) - FatCell _ _ h t -> do + n@(FatAtom _ a) -> pure $ atomSz (MkAtom (NatJ# a)) + FatWord w -> pure (jamWordSz w) + FatCell _ h t -> do !hSz <- go (pos+2) h !tSz <- go (pos+2+hSz) t pure (2+hSz+tSz) @@ -347,15 +359,18 @@ compress top = do H.insert nodes inp p proc p inp Just bak -> do - let rs = refSz bak - if (rs < fatSize inp) - then do H.insert backs p bak - pure rs - else proc p inp + let rs = refSz bak + doRef = H.insert backs p bak $> rs + noRef = proc p inp + case inp of + FatCell _ _ _ -> doRef + FatWord w | rs < atomSz (fromIntegral w) -> doRef + FatAtom _ a | rs < atomSz (MkAtom (NatJ# a)) -> doRef + _ -> noRef res <- go 0 top - traceM "" - print res + -- traceM "" + -- print res pure (res, backs) diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 8c828cbee..8a4abe6be 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -39,7 +39,7 @@ dumpJam fp = writeFile fp . view (re _CueFatBytes) tryCuePill :: PillFile -> IO () tryCuePill pill = loadNoun (show pill) >>= \case Nothing -> print "nil" - Just (FatAtom _ _ _) -> print "atom" + Just (FatAtom _ _) -> print "atom" Just (FatWord _) -> print "word" _ -> print "cell" @@ -49,10 +49,10 @@ tryCueJamPill pill = do n <- loadNoun (show pill) >>= \case Nothing -> do print "failure" pure (FatWord 0) - Just n@(FatAtom _ _ _) -> do print "atom" + Just n@(FatAtom _ _) -> do print "atom" + pure n + Just n@(FatCell _ _ _) -> do print "cell" pure n - Just n@(FatCell _ _ _ _) -> do print "cell" - pure n bs <- evaluate (force (jamFatBS n)) diff --git a/stack.yaml b/stack.yaml index 73308fae0..6d0fef18f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,8 +18,8 @@ nix: - SDL2_image - zlib -# ghc-options: -# urbit: '-fobject-code' +ghc-options: + urbit: '-fobject-code' # build: # executable-profiling: true From a7bbc9364c029708a951caff4eb941b2ce35310c Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 4 Jul 2019 15:06:41 -0700 Subject: [PATCH 100/431] Faster Jam/Cue by using heuristics to predict hashtable size. --- pkg/hs-urbit/lib/Noun/Cue/Fast.hs | 3 ++- pkg/hs-urbit/lib/Noun/Fat.hs | 28 ++++++++++++++++++---------- pkg/hs-urbit/lib/Noun/Jam/Fast.hs | 20 +++++++++++++------- pkg/hs-urbit/lib/Noun/Lens.hs | 16 ++++++---------- 4 files changed, 39 insertions(+), 28 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index 319506f1d..de32d50fe 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -106,8 +106,9 @@ type Bits = Vector Bool doGet :: Get a -> ByteString -> Either DecodeExn a doGet m bs = unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do + -- traceM ("cue size: " <> show (length bs `div` 10)) let endPtr = ptr `plusPtr` len - tbl <- H.new -- Sized 1000000 + tbl <- H.newSized (length bs `div` 10) GetResult _ r <- runGet m endPtr tbl (S (castPtr ptr) 0 0) pure r diff --git a/pkg/hs-urbit/lib/Noun/Fat.hs b/pkg/hs-urbit/lib/Noun/Fat.hs index dd7c25933..d9183b88b 100644 --- a/pkg/hs-urbit/lib/Noun/Fat.hs +++ b/pkg/hs-urbit/lib/Noun/Fat.hs @@ -6,7 +6,8 @@ {-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} module Noun.Fat ( FatNoun(..) - , fatHash, fatCell, fatAtom + , fatSize, fatHash + , fatCell, fatAtom , toFatNoun, fromFatNoun ) where @@ -26,6 +27,7 @@ import Noun (Noun(Atom, Cell)) data FatNoun = FatCell {-# UNPACK #-} !Int + !Word !FatNoun !FatNoun | FatWord {-# UNPACK #-} !Word @@ -50,8 +52,8 @@ instance Eq FatNoun where w1==w2 (FatAtom x1 a1, FatAtom x2 a2 ) -> x1==x2 && a1==a2 - (FatCell x1 h1 t1, FatCell x2 h2 t2) -> - x1==x2 && h1==h2 && t1==t2 + (FatCell x1 s1 h1 t1, FatCell x2 s2 h2 t2) -> + s1==s2 && x1==x2 && h1==h2 && t1==t2 (_, _ ) -> False {-# INLINE (==) #-} @@ -59,12 +61,17 @@ instance Eq FatNoun where -------------------------------------------------------------------------------- +fatSize :: FatNoun -> Word +fatSize = \case + FatCell _ s _ _ -> s + _ -> 1 + {-# INLINE fatHash #-} fatHash :: FatNoun -> Int fatHash = \case - FatCell h _ _ -> h - FatAtom h _ -> h - FatWord w -> hash w + FatCell h _ _ _ -> h + FatAtom h _ -> h + FatWord w -> hash w {-# INLINE fatAtom #-} fatAtom :: Atom -> FatNoun @@ -74,8 +81,9 @@ fatAtom = \case {-# INLINE fatCell #-} fatCell :: FatNoun -> FatNoun -> FatNoun -fatCell h t = FatCell has h t +fatCell h t = FatCell has siz h t where + siz = fatSize h + fatSize t has = fatHash h `combine` fatHash t {-# INLINE toFatNoun #-} @@ -89,9 +97,9 @@ toFatNoun = go fromFatNoun :: FatNoun -> Noun fromFatNoun = go where go = \case - FatAtom _ a -> Atom (MkAtom $ NatJ# a) - FatCell _ h t -> Cell (go h) (go t) - FatWord w -> Atom (fromIntegral w) + FatAtom _ a -> Atom (MkAtom $ NatJ# a) + FatCell _ _ h t -> Cell (go h) (go t) + FatWord w -> Atom (fromIntegral w) -- Stolen from Hashable Library ------------------------------------------------ diff --git a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs index 1974491f9..f3dd6c71e 100644 --- a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs @@ -269,9 +269,9 @@ writeNoun :: FatNoun -> Put () writeNoun n = getRef >>= \case Just bk -> writeBackRef bk - Nothing -> case n of FatAtom _ n -> writeAtom (MkAtom $ NatJ# n) - FatWord (W# w) -> writeAtom (MkAtom $ NatS# w) - FatCell _ h t -> writeCell h t + Nothing -> case n of FatAtom _ n -> writeAtom (MkAtom $ NatJ# n) + FatWord (W# w) -> writeAtom (MkAtom $ NatS# w) + FatCell _ _ h t -> writeCell h t {-# INLINE writeMat #-} writeMat :: Atom -> Put () @@ -340,18 +340,24 @@ jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW) compress :: FatNoun -> IO (Word, H.CuckooHashTable Word Word) compress top = do -- traceM "" - nodes :: H.BasicHashTable FatNoun Word <- H.new -- Sized 1000000 - backs :: H.CuckooHashTable Word Word <- H.new -- Sized 1000000 + let sz = 10 ^ (floor $ logBase 600 (fromIntegral $ fatSize top)) + + -- traceM ("inp(" <> show (fatSize top) <> ")") + -- traceM ("sz(" <> show sz <> ")") + + nodes :: H.BasicHashTable FatNoun Word <- H.newSized sz + backs :: H.CuckooHashTable Word Word <- H.newSized sz let proc :: Word -> FatNoun -> IO Word proc pos = \case n@(FatAtom _ a) -> pure $ atomSz (MkAtom (NatJ# a)) FatWord w -> pure (jamWordSz w) - FatCell _ h t -> do + FatCell _ _ h t -> do !hSz <- go (pos+2) h !tSz <- go (pos+2+hSz) t pure (2+hSz+tSz) + go :: Word -> FatNoun -> IO Word go p inp = do H.lookup nodes inp >>= \case @@ -363,7 +369,7 @@ compress top = do doRef = H.insert backs p bak $> rs noRef = proc p inp case inp of - FatCell _ _ _ -> doRef + FatCell _ _ _ _ -> doRef FatWord w | rs < atomSz (fromIntegral w) -> doRef FatAtom _ a | rs < atomSz (MkAtom (NatJ# a)) -> doRef _ -> noRef diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 8a4abe6be..51edb786b 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -38,21 +38,17 @@ dumpJam fp = writeFile fp . view (re _CueFatBytes) tryCuePill :: PillFile -> IO () tryCuePill pill = - loadNoun (show pill) >>= \case Nothing -> print "nil" + loadNoun (show pill) >>= \case Nothing -> print "nil" Just (FatAtom _ _) -> print "atom" - Just (FatWord _) -> print "word" - _ -> print "cell" + Just (FatWord _) -> print "word" + _ -> print "cell" tryCueJamPill :: PillFile -> IO () tryCueJamPill pill = do - n <- loadNoun (show pill) >>= \case - Nothing -> do print "failure" - pure (FatWord 0) - Just n@(FatAtom _ _) -> do print "atom" - pure n - Just n@(FatCell _ _ _) -> do print "cell" - pure n + Nothing -> print "failure" >> pure (FatWord 0) + Just n@(FatAtom _ _) -> print "atom" >> pure n + Just n@(FatCell _ _ _ _) -> print "cell" >> pure n bs <- evaluate (force (jamFatBS n)) From 0d057747ccf7f00bad7a8b0a080e13ce3738af5b Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 4 Jul 2019 15:40:36 -0700 Subject: [PATCH 101/431] Jam/Cue: Tuning --- pkg/hs-urbit/lib/Noun/Cue/Fast.hs | 6 ++++-- pkg/hs-urbit/lib/Noun/Jam/Fast.hs | 12 ++++-------- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index de32d50fe..f62710eb5 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -106,9 +106,11 @@ type Bits = Vector Bool doGet :: Get a -> ByteString -> Either DecodeExn a doGet m bs = unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do - -- traceM ("cue size: " <> show (length bs `div` 10)) let endPtr = ptr `plusPtr` len - tbl <- H.newSized (length bs `div` 10) + let sz = max 50 + $ min 10_000_000 + $ length bs `div` 6 + tbl <- H.newSized sz GetResult _ r <- runGet m endPtr tbl (S (castPtr ptr) 0 0) pure r diff --git a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs index f3dd6c71e..0e02a7725 100644 --- a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs @@ -339,11 +339,9 @@ jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW) compress :: FatNoun -> IO (Word, H.CuckooHashTable Word Word) compress top = do - -- traceM "" - let sz = 10 ^ (floor $ logBase 600 (fromIntegral $ fatSize top)) - - -- traceM ("inp(" <> show (fatSize top) <> ")") - -- traceM ("sz(" <> show sz <> ")") + let sz = max 50 + $ min 10_000_000 + $ 2 * (10 ^ (floor $ logBase 600 (fromIntegral $ fatSize top))) nodes :: H.BasicHashTable FatNoun Word <- H.newSized sz backs :: H.CuckooHashTable Word Word <- H.newSized sz @@ -357,7 +355,6 @@ compress top = do !tSz <- go (pos+2+hSz) t pure (2+hSz+tSz) - go :: Word -> FatNoun -> IO Word go p inp = do H.lookup nodes inp >>= \case @@ -375,8 +372,7 @@ compress top = do _ -> noRef res <- go 0 top - -- traceM "" - -- print res + pure (res, backs) From 3a379f4a0aeb31ded94969d074bac52a1ff0719d Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 9 Jul 2019 14:57:48 -0700 Subject: [PATCH 102/431] Separate FatNoun type into FatNoun+FatAtom. --- pkg/hs-urbit/lib/Noun/Cue/Fast.hs | 18 ++++---- pkg/hs-urbit/lib/Noun/Fat.hs | 76 +++++++++++++++++++------------ pkg/hs-urbit/lib/Noun/Jam/Fast.hs | 57 +++++++++++------------ pkg/hs-urbit/lib/Noun/Lens.hs | 11 ++--- 4 files changed, 91 insertions(+), 71 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index f62710eb5..147ae2b3d 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -158,7 +158,7 @@ instance Monad Get where -------------------------------------------------------------------------------- badEncoding :: Ptr Word -> S -> String -> IO a -badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg +badEncoding !endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg -------------------------------------------------------------------------------- @@ -167,19 +167,19 @@ getPos = Get $ \_ _ s -> pure (GetResult s (pos s)) insRef :: Word -> FatNoun -> Get () -insRef pos now = Get \_ tbl s -> do +insRef !pos !now = Get \_ tbl s -> do H.insert tbl pos now pure $ GetResult s () getRef :: Word -> Get FatNoun -getRef ref = Get \x tbl s -> do +getRef !ref = Get \x tbl s -> do H.lookup tbl ref >>= \case Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s Just no -> pure (GetResult s no) advance :: Word -> Get () advance 0 = debugM "advance: 0" >> pure () -advance n = Get \_ _ s -> do +advance !n = Get \_ _ s -> do debugM ("advance: " <> show n) let newUsed = n + usedBits s newS = s { pos = pos s + n @@ -246,7 +246,7 @@ dWord = do - Construct a bit-vector using the buffer*length*offset. -} dAtomBits :: Word -> Get Atom -dAtomBits (fromIntegral -> bits) = do +dAtomBits !(fromIntegral -> bits) = do debugMId ("dAtomBits(" <> show bits <> ")") $ do fmap (view $ from atomWords) $ VP.generateM bufSize \i -> do @@ -286,12 +286,12 @@ peekWord = do pure res swiz :: Word -> (Word, Word) -> Word -swiz (fromIntegral -> off) (low, hig) = +swiz !(fromIntegral -> off) (!low, !hig) = (.|.) (shiftR low off) (shiftL hig (64-off)) takeLowBits :: Word -> Word -> Word -takeLowBits 64 wor = wor -takeLowBits wid wor = (2^wid - 1) .&. wor +takeLowBits 64 !wor = wor +takeLowBits !wid !wor = (2^wid - 1) .&. wor {-| Make a word from the next n bits (where n <= 64). @@ -302,7 +302,7 @@ takeLowBits wid wor = (2^wid - 1) .&. wor - Return the word. -} dWordBits :: Word -> Get Word -dWordBits n = do +dWordBits !n = do debugMId ("dWordBits(" <> show n <> ")") $ do w <- peekWord advance n diff --git a/pkg/hs-urbit/lib/Noun/Fat.hs b/pkg/hs-urbit/lib/Noun/Fat.hs index d9183b88b..20096c5cd 100644 --- a/pkg/hs-urbit/lib/Noun/Fat.hs +++ b/pkg/hs-urbit/lib/Noun/Fat.hs @@ -2,11 +2,12 @@ Nouns with Pre-Computed Hash for each node. -} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MagicHash, Strict #-} {-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} -module Noun.Fat ( FatNoun(..) - , fatSize, fatHash +module Noun.Fat ( FatNoun(..), FatAtom(..) + , fatSize , fatCell, fatAtom , toFatNoun, fromFatNoun ) where @@ -25,66 +26,85 @@ import Noun (Noun(Atom, Cell)) -------------------------------------------------------------------------------- +data FatAtom + = FatWord !Word + | FatBigN !Int !BigNat + data FatNoun - = FatCell {-# UNPACK #-} !Int - !Word - !FatNoun - !FatNoun - | FatWord {-# UNPACK #-} !Word - | FatAtom {-# UNPACK #-} !Int - {-# UNPACK #-} !BigNat + = FatCell !Int !Word !FatNoun !FatNoun + | FatAtom !FatAtom -------------------------------------------------------------------------------- -instance Hashable FatNoun where - hash = fatHash +instance Hashable FatAtom where + hash = atomHash {-# INLINE hash #-} hashWithSalt = defaultHashWithSalt {-# INLINE hashWithSalt #-} +instance Hashable FatNoun where + hash = nounHash + {-# INLINE hash #-} + hashWithSalt = defaultHashWithSalt + {-# INLINE hashWithSalt #-} + +instance Eq FatAtom where + (==) x y = + case reallyUnsafePtrEquality# x y of + 1# -> True + _ -> case (x, y) of + (FatWord w1, FatWord w2 ) -> w1==w2 + (FatBigN x1 a1, FatBigN x2 a2 ) -> x1==x2 && a1==a2 + _ -> False + {-# INLINE (==) #-} + instance Eq FatNoun where (==) x y = case reallyUnsafePtrEquality# x y of 1# -> True _ -> case (x, y) of - (FatWord w1, FatWord w2 ) -> - w1==w2 - (FatAtom x1 a1, FatAtom x2 a2 ) -> - x1==x2 && a1==a2 + (FatAtom a1, FatAtom a2) -> + a1 == a2 (FatCell x1 s1 h1 t1, FatCell x2 s2 h2 t2) -> s1==s2 && x1==x2 && h1==h2 && t1==t2 - (_, _ ) -> + _ -> False {-# INLINE (==) #-} -------------------------------------------------------------------------------- +{-# INLINE fatSize #-} fatSize :: FatNoun -> Word fatSize = \case FatCell _ s _ _ -> s _ -> 1 -{-# INLINE fatHash #-} -fatHash :: FatNoun -> Int -fatHash = \case +{-# INLINE atomHash #-} +atomHash :: FatAtom -> Int +atomHash = \case + FatBigN h _ -> h + FatWord w -> hash w + +{-# INLINE nounHash #-} +nounHash :: FatNoun -> Int +nounHash = \case FatCell h _ _ _ -> h - FatAtom h _ -> h - FatWord w -> hash w + FatAtom a -> hash a {-# INLINE fatAtom #-} fatAtom :: Atom -> FatNoun fatAtom = \case - MkAtom (NatS# wd) -> FatWord (W# wd) - MkAtom n@(NatJ# bn) -> FatAtom (hash bn) bn + MkAtom (NatS# wd) -> FatAtom $ FatWord (W# wd) + MkAtom n@(NatJ# bn) -> FatAtom $ FatBigN (hash bn) bn {-# INLINE fatCell #-} fatCell :: FatNoun -> FatNoun -> FatNoun fatCell h t = FatCell has siz h t where siz = fatSize h + fatSize t - has = fatHash h `combine` fatHash t + has = nounHash h `combine` nounHash t {-# INLINE toFatNoun #-} toFatNoun :: Noun -> FatNoun @@ -97,9 +117,9 @@ toFatNoun = go fromFatNoun :: FatNoun -> Noun fromFatNoun = go where go = \case - FatAtom _ a -> Atom (MkAtom $ NatJ# a) - FatCell _ _ h t -> Cell (go h) (go t) - FatWord w -> Atom (fromIntegral w) + FatCell _ _ h t -> Cell (go h) (go t) + FatAtom (FatBigN _ a) -> Atom (MkAtom $ NatJ# a) + FatAtom (FatWord w) -> Atom (fromIntegral w) -- Stolen from Hashable Library ------------------------------------------------ diff --git a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs index 0e02a7725..546d07484 100644 --- a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs @@ -4,13 +4,13 @@ module Noun.Jam.Fast (jam, jamBS, jamFat, jamFatBS) where import ClassyPrelude hiding (hash) +import Noun.Fat import Control.Lens (view, to, from) import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.)) import Noun.Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) import Noun.Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) import Noun (Noun(Atom, Cell)) -import Noun.Fat import Noun.Pill (bigNatWords, atomBS) import Data.Vector.Primitive ((!)) import Foreign.Marshal.Alloc (callocBytes, free) @@ -192,7 +192,7 @@ writeAtomWord (W# w) = writeAtomWord# w -} {-# INLINE writeAtomBigNat #-} writeAtomBigNat :: BigNat -> Put () -writeAtomBigNat (view bigNatWords -> words) = do +writeAtomBigNat !(view bigNatWords -> words) = do let lastIdx = VP.length words - 1 for_ [0..(lastIdx-1)] \i -> writeWord (words ! i) @@ -243,16 +243,16 @@ instance Monad Put where -------------------------------------------------------------------------------- doPut :: H.CuckooHashTable Word Word -> Word -> Put () -> ByteString -doPut tbl sz m = +doPut !tbl !sz m = unsafePerformIO $ do -- traceM "doPut" buf <- callocBytes (fromIntegral (wordSz*8)) _ <- runPut (m >> mbFlush) tbl (S buf 0 0 0) BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf) where - wordSz = fromIntegral (sz `divUp` 64) - byteSz = fromIntegral (sz `divUp` 8) - divUp = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1) + !wordSz = fromIntegral (sz `divUp` 64) + !byteSz = fromIntegral (sz `divUp` 8) + !divUp = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1) mbFlush :: Put () mbFlush = do @@ -266,12 +266,12 @@ doPut tbl sz m = TODO Handle back references -} writeNoun :: FatNoun -> Put () -writeNoun n = +writeNoun !n = getRef >>= \case Just bk -> writeBackRef bk - Nothing -> case n of FatAtom _ n -> writeAtom (MkAtom $ NatJ# n) - FatWord (W# w) -> writeAtom (MkAtom $ NatS# w) - FatCell _ _ h t -> writeCell h t + Nothing -> case n of FatAtom (FatBigN _ n) -> writeAtom(MkAtom $ NatJ# n) + FatAtom (FatWord (W# w)) -> writeAtom(MkAtom $ NatS# w) + FatCell _ _ h t -> writeCell h t {-# INLINE writeMat #-} writeMat :: Atom -> Put () @@ -286,7 +286,7 @@ writeMat atm = do {-# INLINE writeCell #-} writeCell :: FatNoun -> FatNoun -> Put () -writeCell h t = do +writeCell !h !t = do writeBit True writeBit False writeNoun h @@ -294,13 +294,13 @@ writeCell h t = do {-# INLINE writeAtom #-} writeAtom :: Atom -> Put () -writeAtom a = do +writeAtom !a = do writeBit False writeMat a {-# INLINE writeBackRef #-} writeBackRef :: Word -> Put () -writeBackRef a = do +writeBackRef !a = do p <- pos <$> getS writeBit True writeBit True @@ -311,7 +311,7 @@ writeBackRef a = do {-# INLINE matSz #-} matSz :: Atom -> Word -matSz a = W# (matSz# a) +matSz !a = W# (matSz# a) {-# INLINE matSz# #-} matSz# :: Atom -> Word# @@ -323,11 +323,11 @@ matSz# a = preW `plusWord#` preW `plusWord#` atmW {-# INLINE atomSz #-} atomSz :: Atom -> Word -atomSz = (1+) . matSz +atomSz !w = 1 + matSz w {-# INLINE refSz #-} refSz :: Word -> Word -refSz = (1+) . jamWordSz +refSz !w = 1 + jamWordSz w {-# INLINE jamWordSz #-} jamWordSz :: Word -> Word @@ -338,25 +338,26 @@ jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW) preW = wordBitWidth# atmW compress :: FatNoun -> IO (Word, H.CuckooHashTable Word Word) -compress top = do +compress !top = do let sz = max 50 $ min 10_000_000 - $ 2 * (10 ^ (floor $ logBase 600 (fromIntegral $ fatSize top))) + $ (2*) $ (10^) $ floor $ logBase 600 $ fromIntegral $ fatSize top nodes :: H.BasicHashTable FatNoun Word <- H.newSized sz backs :: H.CuckooHashTable Word Word <- H.newSized sz let proc :: Word -> FatNoun -> IO Word - proc pos = \case - n@(FatAtom _ a) -> pure $ atomSz (MkAtom (NatJ# a)) - FatWord w -> pure (jamWordSz w) + proc !pos = \case + FatAtom atm -> case atm of + n@(FatBigN _ a) -> pure $ atomSz $ MkAtom $ NatJ# a + FatWord w -> pure (jamWordSz w) FatCell _ _ h t -> do !hSz <- go (pos+2) h !tSz <- go (pos+2+hSz) t pure (2+hSz+tSz) go :: Word -> FatNoun -> IO Word - go p inp = do + go !p !inp = do H.lookup nodes inp >>= \case Nothing -> do H.insert nodes inp p @@ -366,10 +367,10 @@ compress top = do doRef = H.insert backs p bak $> rs noRef = proc p inp case inp of - FatCell _ _ _ _ -> doRef - FatWord w | rs < atomSz (fromIntegral w) -> doRef - FatAtom _ a | rs < atomSz (MkAtom (NatJ# a)) -> doRef - _ -> noRef + FatCell _ _ _ _ -> doRef + FatAtom (FatWord w) | rs < atomSz (fromIntegral w) -> doRef + FatAtom (FatBigN _ a) | rs < atomSz (MkAtom (NatJ# a)) -> doRef + _ -> noRef res <- go 0 top @@ -380,8 +381,8 @@ compress top = do {-# INLINE combine #-} combine :: Int -> Int -> Int -combine h1 h2 = (h1 * 16777619) `xor` h2 +combine !h1 !h2 = (h1 * 16777619) `xor` h2 {-# INLINE defaultHashWithSalt #-} defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt salt x = salt `combine` Hash.hash x +defaultHashWithSalt !salt !x = salt `combine` Hash.hash x diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 51edb786b..ff58fe9f9 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -38,16 +38,15 @@ dumpJam fp = writeFile fp . view (re _CueFatBytes) tryCuePill :: PillFile -> IO () tryCuePill pill = - loadNoun (show pill) >>= \case Nothing -> print "nil" - Just (FatAtom _ _) -> print "atom" - Just (FatWord _) -> print "word" - _ -> print "cell" + loadNoun (show pill) >>= \case Nothing -> print "nil" + Just (FatAtom _) -> print "atom" + _ -> print "cell" tryCueJamPill :: PillFile -> IO () tryCueJamPill pill = do n <- loadNoun (show pill) >>= \case - Nothing -> print "failure" >> pure (FatWord 0) - Just n@(FatAtom _ _) -> print "atom" >> pure n + Nothing -> print "failure" >> pure (FatAtom $ FatWord 0) + Just n@(FatAtom _) -> print "atom" >> pure n Just n@(FatCell _ _ _ _) -> print "cell" >> pure n bs <- evaluate (force (jamFatBS n)) From d5244af9d18a19890bb7b1331e56c2cc3b43f238 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 11 Jul 2019 14:41:09 -0700 Subject: [PATCH 103/431] Switch to fat nouns everywhere + a bunch of refactoring. --- pkg/hs-urbit/lib/{Noun => }/Atom.hs | 11 +- pkg/hs-urbit/lib/{Noun/Cue/Fast.hs => Cue.hs} | 60 +- pkg/hs-urbit/lib/{Noun/Jam/Fast.hs => Jam.hs} | 81 +-- pkg/hs-urbit/lib/NockRTS/Noun.hs | 183 ----- pkg/hs-urbit/lib/Noun.hs | 686 ++++++++++++++++-- pkg/hs-urbit/lib/Noun/Fat.hs | 133 ---- pkg/hs-urbit/lib/Noun/Jam.hs | 263 ------- pkg/hs-urbit/lib/Noun/Lens.hs | 39 +- pkg/hs-urbit/lib/Noun/Poet.hs | 661 ----------------- pkg/hs-urbit/lib/Noun/{Poet => }/TH.hs | 4 +- pkg/hs-urbit/lib/Noun/Zip.hs | 234 ------ pkg/hs-urbit/lib/{Noun => }/Pill.hs | 9 +- pkg/hs-urbit/lib/Urbit/Ames.hs | 2 +- pkg/hs-urbit/lib/Urbit/Time.hs | 4 +- pkg/hs-urbit/lib/Vere/Ames.hs | 5 +- pkg/hs-urbit/lib/Vere/Http.hs | 5 +- pkg/hs-urbit/lib/Vere/Http/Client.hs | 4 +- pkg/hs-urbit/lib/Vere/Http/Server.hs | 8 +- pkg/hs-urbit/lib/Vere/Log.hs | 8 +- pkg/hs-urbit/lib/Vere/Pier.hs | 2 +- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 5 +- pkg/hs-urbit/lib/Vere/Serf.hs | 15 +- pkg/hs-urbit/package.yaml | 5 + pkg/hs-vere/app/uterm/Main.hs | 2 +- stack.yaml | 3 - 25 files changed, 737 insertions(+), 1695 deletions(-) rename pkg/hs-urbit/lib/{Noun => }/Atom.hs (97%) rename pkg/hs-urbit/lib/{Noun/Cue/Fast.hs => Cue.hs} (88%) rename pkg/hs-urbit/lib/{Noun/Jam/Fast.hs => Jam.hs} (79%) delete mode 100644 pkg/hs-urbit/lib/NockRTS/Noun.hs delete mode 100644 pkg/hs-urbit/lib/Noun/Fat.hs delete mode 100644 pkg/hs-urbit/lib/Noun/Jam.hs delete mode 100644 pkg/hs-urbit/lib/Noun/Poet.hs rename pkg/hs-urbit/lib/Noun/{Poet => }/TH.hs (99%) delete mode 100644 pkg/hs-urbit/lib/Noun/Zip.hs rename pkg/hs-urbit/lib/{Noun => }/Pill.hs (98%) diff --git a/pkg/hs-urbit/lib/Noun/Atom.hs b/pkg/hs-urbit/lib/Atom.hs similarity index 97% rename from pkg/hs-urbit/lib/Noun/Atom.hs rename to pkg/hs-urbit/lib/Atom.hs index 58fb0f236..c0e8979cb 100644 --- a/pkg/hs-urbit/lib/Noun/Atom.hs +++ b/pkg/hs-urbit/lib/Atom.hs @@ -1,20 +1,17 @@ -{-# LANGUAGE MagicHash, GeneralizedNewtypeDeriving, UnboxedTuples #-} - -module Noun.Atom where +module Atom where import ClassyPrelude import Control.Lens --- import Prelude ((^)) +import Data.Bits +import Data.Flat +import GHC.Int import GHC.Integer.GMP.Internals import GHC.Natural import GHC.Prim import GHC.Word -import GHC.Int -import Data.Bits import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen import Text.Printf -import Data.Flat import Data.Hashable (Hashable) diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Cue.hs similarity index 88% rename from pkg/hs-urbit/lib/Noun/Cue/Fast.hs rename to pkg/hs-urbit/lib/Cue.hs index 147ae2b3d..b076225d9 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Cue.hs @@ -1,53 +1,31 @@ -{-# LANGUAGE MagicHash #-} - -module Noun.Cue.Fast (cueFatBS, cueFat, cueBS, cue) where +module Cue (cue, cueBS) where import ClassyPrelude import Noun -import Noun.Fat -import Noun.Atom -import Noun.Poet -import Data.Bits hiding (Bits) -import Control.Lens -import Text.Printf -import GHC.Prim -import GHC.Word -import GHC.Natural -import Foreign.Ptr -import Control.Monad (guard) -import Data.Bits (shiftR, (.|.), (.&.)) -import Data.Map (Map) -import Foreign.Ptr (Ptr, plusPtr, ptrToWordPtr) +import Atom (Atom(..)) +import Control.Lens (view, from) +import Data.Bits (shiftL, shiftR, (.|.), (.&.)) +import Foreign.Ptr (Ptr, plusPtr, castPtr, ptrToWordPtr) import Foreign.Storable (peek) -import Foreign.Storable (peek) -import Noun (Noun) -import Noun.Pill (atomBS, atomWords) +import GHC.Prim (ctz#) +import GHC.Word (Word(..)) +import Pill (atomBS, atomWords) import System.IO.Unsafe (unsafePerformIO) +import Text.Printf (printf) import qualified Data.ByteString.Unsafe as BS import qualified Data.HashTable.IO as H import qualified Data.Vector.Primitive as VP -import Test.Tasty -import Test.Tasty.TH -import qualified Test.Tasty.QuickCheck as QC -import Test.QuickCheck hiding ((.&.)) - -------------------------------------------------------------------------------- -cueFatBS :: ByteString -> Either DecodeExn FatNoun -cueFatBS = doGet dNoun - -cueFat :: Atom -> Either DecodeExn FatNoun -cueFat = cueFatBS . view atomBS - cueBS :: ByteString -> Either DecodeExn Noun -cueBS = fmap fromFatNoun . cueFatBS +cueBS = doGet dNoun cue :: Atom -> Either DecodeExn Noun -cue = fmap fromFatNoun . cueFat +cue = cueBS . view atomBS -- Debugging ------------------------------------------------------------------- @@ -96,13 +74,11 @@ data GetResult a = GetResult {-# UNPACK #-} !S !a newtype Get a = Get { runGet :: Ptr Word - -> H.BasicHashTable Word FatNoun + -> H.BasicHashTable Word Noun -> S -> IO (GetResult a) } -type Bits = Vector Bool - doGet :: Get a -> ByteString -> Either DecodeExn a doGet m bs = unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do @@ -166,12 +142,12 @@ getPos :: Get Word getPos = Get $ \_ _ s -> pure (GetResult s (pos s)) -insRef :: Word -> FatNoun -> Get () +insRef :: Word -> Noun -> Get () insRef !pos !now = Get \_ tbl s -> do H.insert tbl pos now pure $ GetResult s () -getRef :: Word -> Get FatNoun +getRef :: Word -> Get Noun getRef !ref = Get \x tbl s -> do H.lookup tbl ref >>= \case Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s @@ -347,8 +323,8 @@ dAtom = do 0 -> pure 0 n -> dAtomBits n -dCell :: Get FatNoun -dCell = fatCell <$> dNoun <*> dNoun +dCell :: Get Noun +dCell = Cell <$> dNoun <*> dNoun {-| Get a Noun. @@ -359,7 +335,7 @@ dCell = fatCell <$> dNoun <*> dNoun - If it's zero, get a cell. - If it's one, get an atom. -} -dNoun :: Get FatNoun +dNoun :: Get Noun dNoun = do p <- getPos @@ -367,7 +343,7 @@ dNoun = do dBit >>= \case False -> do debugM "It's an atom" - (fatAtom <$> dAtom) >>= yield + (Atom <$> dAtom) >>= yield True -> dBit >>= \case False -> do debugM "It's a cell" dCell >>= yield diff --git a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Jam.hs similarity index 79% rename from pkg/hs-urbit/lib/Noun/Jam/Fast.hs rename to pkg/hs-urbit/lib/Jam.hs index 546d07484..3f838c30c 100644 --- a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Jam.hs @@ -1,17 +1,12 @@ -{-# LANGUAGE MagicHash #-} -{-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} - -module Noun.Jam.Fast (jam, jamBS, jamFat, jamFatBS) where +module Jam (jam, jamBS) where import ClassyPrelude hiding (hash) -import Noun.Fat +import Noun -import Control.Lens (view, to, from) -import Data.Bits (shiftL, shiftR, setBit, clearBit, xor, (.|.)) -import Noun.Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) -import Noun.Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) -import Noun (Noun(Atom, Cell)) -import Noun.Pill (bigNatWords, atomBS) +import Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) +import Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) +import Control.Lens (view, from) +import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.)) import Data.Vector.Primitive ((!)) import Foreign.Marshal.Alloc (callocBytes, free) import Foreign.Ptr (Ptr, castPtr, plusPtr) @@ -21,29 +16,23 @@ import GHC.Int (Int(I#)) import GHC.Natural (Natural(NatS#, NatJ#)) import GHC.Prim (Word#, plusWord#, word2Int#) import GHC.Word (Word(W#)) +import Pill (bigNatWords, atomBS) import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Unsafe as BS -import qualified Data.Hashable as Hash import qualified Data.HashTable.IO as H import qualified Data.Vector.Primitive as VP -- Exports --------------------------------------------------------------------- -jamFatBS :: FatNoun -> ByteString -jamFatBS n = doPut bt sz (writeNoun n) +jamBS :: Noun -> ByteString +jamBS n = doPut bt sz (writeNoun n) where (sz, bt) = unsafePerformIO (compress n) -jamFat :: FatNoun -> Atom -jamFat = view (from atomBS) . jamFatBS - -jamBS :: Noun -> ByteString -jamBS = jamFatBS . toFatNoun - jam :: Noun -> Atom -jam = jamFat . toFatNoun +jam = view (from atomBS) . jamBS -- Types ----------------------------------------------------------------------- @@ -265,13 +254,12 @@ doPut !tbl !sz m = {- TODO Handle back references -} -writeNoun :: FatNoun -> Put () +writeNoun :: Noun -> Put () writeNoun !n = getRef >>= \case Just bk -> writeBackRef bk - Nothing -> case n of FatAtom (FatBigN _ n) -> writeAtom(MkAtom $ NatJ# n) - FatAtom (FatWord (W# w)) -> writeAtom(MkAtom $ NatS# w) - FatCell _ _ h t -> writeCell h t + Nothing -> case n of Atom a -> writeAtom a + Cell h t -> writeCell h t {-# INLINE writeMat #-} writeMat :: Atom -> Put () @@ -285,7 +273,7 @@ writeMat atm = do preWid = fromIntegral (wordBitWidth atmWid) {-# INLINE writeCell #-} -writeCell :: FatNoun -> FatNoun -> Put () +writeCell :: Noun -> Noun -> Put () writeCell !h !t = do writeBit True writeBit False @@ -337,26 +325,23 @@ jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW) atmW = wordBitWidth# w preW = wordBitWidth# atmW -compress :: FatNoun -> IO (Word, H.CuckooHashTable Word Word) +compress :: Noun -> IO (Word, H.CuckooHashTable Word Word) compress !top = do let sz = max 50 $ min 10_000_000 - $ (2*) $ (10^) $ floor $ logBase 600 $ fromIntegral $ fatSize top + $ (2*) $ (10^) $ floor $ logBase 600 $ fromIntegral $ nounSize top - nodes :: H.BasicHashTable FatNoun Word <- H.newSized sz - backs :: H.CuckooHashTable Word Word <- H.newSized sz + nodes :: H.BasicHashTable Noun Word <- H.newSized sz + backs :: H.CuckooHashTable Word Word <- H.newSized sz - let proc :: Word -> FatNoun -> IO Word + let proc :: Word -> Noun -> IO Word proc !pos = \case - FatAtom atm -> case atm of - n@(FatBigN _ a) -> pure $ atomSz $ MkAtom $ NatJ# a - FatWord w -> pure (jamWordSz w) - FatCell _ _ h t -> do - !hSz <- go (pos+2) h - !tSz <- go (pos+2+hSz) t - pure (2+hSz+tSz) + Atom a -> pure (atomSz a) + Cell h t -> do !hSz <- go (pos+2) h + !tSz <- go (pos+2+hSz) t + pure (2+hSz+tSz) - go :: Word -> FatNoun -> IO Word + go :: Word -> Noun -> IO Word go !p !inp = do H.lookup nodes inp >>= \case Nothing -> do @@ -367,22 +352,10 @@ compress !top = do doRef = H.insert backs p bak $> rs noRef = proc p inp case inp of - FatCell _ _ _ _ -> doRef - FatAtom (FatWord w) | rs < atomSz (fromIntegral w) -> doRef - FatAtom (FatBigN _ a) | rs < atomSz (MkAtom (NatJ# a)) -> doRef - _ -> noRef + Cell _ _ -> doRef + Atom a | rs < atomSz (fromIntegral a) -> doRef + _ -> noRef res <- go 0 top pure (res, backs) - - --- Stolen from Hashable Library ------------------------------------------------ - -{-# INLINE combine #-} -combine :: Int -> Int -> Int -combine !h1 !h2 = (h1 * 16777619) `xor` h2 - -{-# INLINE defaultHashWithSalt #-} -defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt !salt !x = salt `combine` Hash.hash x diff --git a/pkg/hs-urbit/lib/NockRTS/Noun.hs b/pkg/hs-urbit/lib/NockRTS/Noun.hs deleted file mode 100644 index 05328385f..000000000 --- a/pkg/hs-urbit/lib/NockRTS/Noun.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, UnboxedSums #-} - -module NockRTS.Noun where - -import Data.Word -import GHC.Base hiding (C#) -import GHC.Integer.GMP.Internals -import GHC.Prim -import Prelude hiding (cons) - -import Data.List (intercalate) -import GHC.Real (underflowError) - --------------------------------------------------------------------------------- - -type Noun# = (# Word# | BigNat | Cell #) -type Atom# = (# Word# | BigNat #) -type Cell# = (# Noun#, Noun# #) - -data Cell = C# Cell# -data Atom = A# Atom# -data Noun = N# Noun# - - --- Unboxed Atom Operations ----------------------------------------------------- - -wordIsZero# :: Word# -> Bool -wordIsZero# w = 0 == (I# (word2Int# w)) - -words2Atom# :: (# Word#, Word# #) -> Atom# -words2Atom# (# x, y #) = - if wordIsZero# x - then (# y | #) - else (# | wordToBigNat2 x y #) - -inc# :: Atom# -> Atom# -inc# (# w | #) = words2Atom# (plusWord2# w (int2Word# 1#)) -inc# (# | n #) = (# | n #) - -plusAtom# :: Atom# -> Atom# -> Atom# -plusAtom# (# x | #) (# y | #) = words2Atom# (# x, y #) -plusAtom# (# w | #) (# | n #) = (# | plusBigNatWord n w #) -plusAtom# (# | n #) (# w | #) = (# | plusBigNatWord n w #) -plusAtom# (# | x #) (# | y #) = (# | plusBigNat x y #) - -minusAtom# :: Atom# -> Atom# -> Atom# -minusAtom# x (# 0## | #) = x - -{- -minusAtom# (NatS# x) (NatS# y) = case subWordC# x y of - (# l, 0# #) -> NatS# l - _ -> underflowError -minusAtom# (NatS# _) (NatJ# _) = underflowError -minusAtom# (NatJ# x) (NatS# y) = bigNatToAtom# (minusBigNatWord x y) -minusAtom# (NatJ# x) (NatJ# y) = bigNatToAtom# (minusBigNat x y) --} - - -word2Atom# :: Word# -> Atom# -word2Atom# w = (# w | #) - -bigNat2Atom# :: BigNat -> Atom# -bigNat2Atom# bn = (# | bn #) - - --- Unboxed Cell Operations ----------------------------------------------------- - -car# :: Cell# -> Noun# -car# (# x, _ #) = x - -cdr# :: Cell# -> Noun# -cdr# (# _, y #) = y - -cellCons# :: Noun# -> Noun# -> Cell# -cellCons# x y = (# x, y #) - - --- Unboxed Noun Operations ----------------------------------------------------- - -runNoun# :: Noun# -> (Cell -> a) -> (Atom# -> a) -> a -runNoun# (# w | | #) c a = a (# w | #) -runNoun# (# | n | #) c a = a (# | n #) -runNoun# (# | | p #) c a = c p - -atom2Noun# :: Atom# -> Noun# -atom2Noun# (# w | #) = (# w | | #) -atom2Noun# (# | n #) = (# | n | #) - -word2Noun# :: Word# -> Noun# -word2Noun# w = (# w | | #) - -bigNat2Noun# :: BigNat -> Noun# -bigNat2Noun# bn = (# | bn | #) - -cell2Noun# :: Cell# -> Noun# -cell2Noun# c = (# | | C# c #) - - --- Boxed Operations ------------------------------------------------------------ - -plusAtom :: Atom -> Atom -> Atom -plusAtom (A# x) (A# y) = A# (plusAtom# x y) - -minusAtom :: Atom -> Atom -> Atom -minusAtom (A# x) (A# y) = A# (minusAtom# x y) - -negateAtom :: Atom -> Atom -negateAtom = undefined - -timesAtom :: Atom -> Atom -> Atom -timesAtom = undefined - -atomFromInteger :: Integer -> Atom -atomFromInteger (S# i) = A# (# int2Word# i | #) -atomFromInteger (Jp# n) = A# (# | n #) -atomFromInteger _ = underflowError - -signumAtom :: Atom -> Atom -signumAtom = undefined - -atom2Noun :: Atom -> Noun -atom2Noun (A# a) = N# (atom2Noun# a) - -cell2Noun :: Cell -> Noun -cell2Noun c = N# (# | | c #) - -cons :: Noun -> Noun -> Noun -cons (N# x) (N# y) = cell2Noun (C# (cellCons# x y)) - -runNoun :: Noun -> (Cell -> a) -> (Atom -> a) -> a -runNoun (N# n) f g = runNoun# n (\c -> f c) (\a -> g (A# a)) - -toAtom :: Noun -> Maybe Atom -toAtom (N# n) = runNoun# n (\_ -> Nothing) (\a -> Just (A# a)) - -plusNoun :: Noun -> Noun -> Maybe Noun -plusNoun x y = atom2Noun <$> (plusAtom <$> toAtom x <*> toAtom y) - - --- Random Bullshit ------------------------------------------------------------- - -cell2List :: Cell -> [Noun] -cell2List = go [] - where - go :: [Noun] -> Cell -> [Noun] - go acc (C# (# x, y #)) = runNoun# y (\c -> go (N# x : acc) c) - (\a -> reverse (N# y : N# x : acc)) - -list2Noun :: [Noun] -> Noun -list2Noun [] = atom2Noun 0 -list2Noun [x] = x -list2Noun (x:xs) = cons x (list2Noun xs) - -fmtCell :: [String] -> String -fmtCell xs = "[" <> intercalate " " xs <> "]" - -instance Num Atom where - (+) = plusAtom - (-) = minusAtom - (*) = timesAtom - negate = negateAtom - fromInteger = atomFromInteger - abs = id - signum = signumAtom - -instance Show Atom where - show (A# (# w | #)) = show (W# w) - show (A# (# | n #)) = show (Jp# n) - -instance Show Cell where - show c = fmtCell (fmap show (cell2List c)) - -instance Show Noun where - show (N# (# w | | #)) = show (W# w) - show (N# (# | n | #)) = show (Jp# n) - show (N# (# | | c #)) = show c - -example :: Noun -example = list2Noun [atom2Noun 1337, atom2Noun 1338, atom2Noun 0] - -exampleIO :: IO () -exampleIO = do - print example diff --git a/pkg/hs-urbit/lib/Noun.hs b/pkg/hs-urbit/lib/Noun.hs index 04c85d326..c13f36dbf 100644 --- a/pkg/hs-urbit/lib/Noun.hs +++ b/pkg/hs-urbit/lib/Noun.hs @@ -1,35 +1,51 @@ -module Noun where +{-# OPTIONS_GHC -funbox-strict-fields #-} -import Prelude hiding (all) +module Noun + ( Noun, pattern Cell, pattern Atom, nounSize + , ToNoun(toNoun), FromNoun(parseNoun), fromNoun, fromNounErr + , Cord(..), Knot(..), Term(..), Tank(..), Plum(..) + ) where +import ClassyPrelude hiding (hash) + +import Control.Lens import Control.Applicative import Control.Monad -import Data.Bits -import GHC.Generics -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen -import Data.Flat hiding (getSize) +import Atom +import Pill +import Data.Void +import Data.Word +import GHC.Natural +import GHC.Generics hiding (from) -import ClassyPrelude (Text, all, unpack) -import Data.Hashable (Hashable) -import Data.List (intercalate) -import Noun.Atom (Atom) -import Data.Typeable (Typeable) +import Data.Bits (xor) +import Data.Hashable (hash) +import Data.Typeable (Typeable) +import GHC.Integer.GMP.Internals (BigNat) +import GHC.Natural (Natural(NatS#, NatJ#)) +import GHC.Prim (reallyUnsafePtrEquality#) +import GHC.Word (Word(W#)) +import Atom (Atom(MkAtom)) +import RIO (decodeUtf8Lenient) +import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary)) +import Test.QuickCheck.Gen (scale, resize, getSize) -import qualified Control.Monad.Fail as Fail +import qualified GHC.Generics as GHC import qualified Data.Char as C +import qualified Control.Monad.Fail as Fail -- Types ----------------------------------------------------------------------- -data Cell = ACell !Noun !Noun - deriving (Eq, Ord) - data Noun - = Atom !Atom - | Cell !Noun !Noun - deriving stock (Eq, Ord, Generic) - deriving anyclass (Flat, Hashable) + = NCell !Int !Word !Noun !Noun + | NAtom !Int !Atom + +pattern Cell x y <- NCell _ _ x y where + Cell = mkCell + +pattern Atom a <- NAtom _ a where + Atom = mkAtom data CellIdx = L | R deriving (Eq, Ord, Show) @@ -37,15 +53,64 @@ data CellIdx = L | R type NounPath = [CellIdx] --- Instances ------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +instance Hashable Noun where + hash = \case NCell h _ _ _ -> h + NAtom h _ -> h + {-# INLINE hash #-} + hashWithSalt = defaultHashWithSalt + {-# INLINE hashWithSalt #-} + +instance Eq Noun where + (==) !x !y = + case reallyUnsafePtrEquality# x y of + 1# -> True + _ -> case (x, y) of + (NAtom x1 a1, NAtom x2 a2) -> + x1 == x2 && a1 == a2 + (NCell x1 s1 h1 t1, NCell x2 s2 h2 t2) -> + s1==s2 && x1==x2 && h1==h2 && t1==t2 + _ -> + False + {-# INLINE (==) #-} + +instance Ord Noun where + compare !x !y = + case reallyUnsafePtrEquality# x y of + 1# -> EQ + _ -> case (x, y) of + (Atom _, Cell _ _) -> LT + (Cell _ _, Atom _) -> GT + (Atom a1, Atom a2) -> compare a1 a2 + (Cell h1 t1, Cell h2 t2) -> compare h1 h2 <> compare t1 t2 + {-# INLINE compare #-} + instance Show Noun where - show (Atom a) = show a - show (Cell x y) = fmtCell (show <$> (x : toTuple y)) + show = \case Atom a -> showAtom a + Cell x y -> fmtCell (show <$> (x : toTuple y)) where fmtCell :: [String] -> String fmtCell xs = "[" <> intercalate " " xs <> "]" + toTuple :: Noun -> [Noun] + toTuple (Cell x xs) = x : toTuple xs + toTuple atom = [atom] + + showAtom :: Atom -> String + showAtom 0 = "0" + showAtom a = + let mTerm = do + t <- fromNoun (Atom a) + let ok = \x -> (x=='-' || C.isAlphaNum x) + guard (all ok (t :: Text)) + pure ("%" <> unpack t) + + in case mTerm of + Nothing -> show a + Just st -> st + instance Arbitrary Noun where arbitrary = resize 1000 go where @@ -60,43 +125,562 @@ instance Arbitrary Noun where ( _, True, _ ) -> scale (\x -> x-10) (Cell <$> go <*> go) --- Predicates ------------------------------------------------------------------ +-------------------------------------------------------------------------------- -isAtom :: Noun -> Bool -isAtom (Atom _) = True -isAtom (Cell _ _) = False +{-# INLINE nounSize #-} +nounSize :: Noun -> Word +nounSize = \case + NCell _ s _ _ -> s + NAtom _ _ -> 1 -isCell :: Noun -> Bool -isCell (Atom _) = False -isCell (Cell _ _) = True +{-# INLINE mkAtom #-} +mkAtom :: Atom -> Noun +mkAtom !a = NAtom (hash a) a + +{-# INLINE mkCell #-} +mkCell :: Noun -> Noun -> Noun +mkCell !h !t = NCell has siz h t + where + !siz = nounSize h + nounSize t + !has = hash h `combine` hash t --- Tuples ---------------------------------------------------------------------- +-- Stolen from Hashable Library ------------------------------------------------ -fromTuple :: [Noun] -> Noun -fromTuple [] = Atom 0 -fromTuple [x] = x -fromTuple (x:xs) = Cell x (fromTuple xs) +{-# INLINE combine #-} +combine :: Int -> Int -> Int +combine !h1 !h2 = (h1 * 16777619) `xor` h2 -toTuple :: Noun -> [Noun] -toTuple (Cell x xs) = x : toTuple xs -toTuple atom = [atom] +{-# INLINE defaultHashWithSalt #-} +defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt !salt !x = salt `combine` hash x --- Lists ----------------------------------------------------------------------- +-- Types For Hoon Constructs --------------------------------------------------- -fromList :: [Noun] -> Noun -fromList [] = Atom 0 -fromList (x:xs) = Cell x (fromList xs) +{-| + `Nullable a <-> ?@(~ a)` -toList :: Noun -> Maybe [Noun] -toList (Atom 0) = Just [] -toList (Atom _) = Nothing -toList (Cell x xs) = (x:) <$> toList xs + This is distinct from `unit`, since there is no tag on the non-atom + case, therefore `a` must always be cell type. +-} +data Nullable a = Nil | NotNil a + deriving (Eq, Ord, Show) -example :: Noun -example = fromTuple [Atom 1337, Atom 1338, Atom 0] +newtype Tour = Tour [Char] + deriving (Eq, Ord, Show) -exampleIO :: IO () -exampleIO = do - print example +newtype Tape = Tape ByteString + deriving newtype (Eq, Ord, Show, IsString) + +newtype Cord = Cord { unCord :: ByteString } + deriving newtype (Eq, Ord, Show, IsString, NFData) + + +-- Chars ----------------------------------------------------------------------- + +instance ToNoun Char where + toNoun = toNoun . (fromIntegral :: Int -> Word32) . C.ord + +instance FromNoun Char where + parseNoun n = do + w :: Word32 <- parseNoun n + pure $ C.chr $ fromIntegral w + + +-- Pretty Printing ------------------------------------------------------------- + +type Tang = [Tank] + +data Tank + = TLeaf Tape + | TPlum Plum + | TPalm (Tape, Tape, Tape, Tape) [Tank] + | TRose (Tape, Tape, Tape) [Tank] + deriving (Eq, Ord, Show) + +type Tile = Cord + +data WideFmt + = WideFmt { delimit :: Tile, enclose :: Maybe (Tile, Tile) } + deriving (Eq, Ord, Show) + +data TallFmt + = TallFmt { intro :: Tile, indef :: Maybe (Tile, Tile) } + deriving (Eq, Ord, Show) + +data PlumFmt + = PlumFmt (Maybe WideFmt) (Maybe TallFmt) + deriving (Eq, Ord, Show) + +data Plum + = PAtom Cord + | PPara Tile [Cord] + | PTree PlumFmt [Plum] + | PSbrk Plum + deriving (Eq, Ord, Show) + + +-- IResult --------------------------------------------------------------------- + +data IResult a = IError NounPath String | ISuccess a + deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) + +instance Applicative IResult where + pure = ISuccess + (<*>) = ap + +instance Fail.MonadFail IResult where + fail err = traceM ("!" <> err <> "!") >> IError [] err + +instance Monad IResult where + return = pure + fail = Fail.fail + ISuccess a >>= k = k a + IError path err >>= _ = IError path err + +instance MonadPlus IResult where + mzero = fail "mzero" + mplus a@(ISuccess _) _ = a + mplus _ b = b + +instance Alternative IResult where + empty = mzero + (<|>) = mplus + +instance Semigroup (IResult a) where + (<>) = mplus + +instance Monoid (IResult a) where + mempty = fail "mempty" + mappend = (<>) + + +-- Result ---------------------------------------------------------------------- + +data Result a = Error String | Success a + deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) + +instance Applicative Result where + pure = Success + (<*>) = ap + +instance Fail.MonadFail Result where + fail err = Error err + +instance Monad Result where + return = pure + fail = Fail.fail + + Success a >>= k = k a + Error err >>= _ = Error err + +instance MonadPlus Result where + mzero = fail "mzero" + mplus a@(Success _) _ = a + mplus _ b = b + +instance Alternative Result where + empty = mzero + (<|>) = mplus + +instance Semigroup (Result a) where + (<>) = mplus + {-# INLINE (<>) #-} + +instance Monoid (Result a) where + mempty = fail "mempty" + mappend = (<>) + + +-- "Parser" -------------------------------------------------------------------- + +type Failure f r = NounPath -> String -> f r +type Success a f r = a -> f r + +newtype Parser a = Parser { + runParser :: forall f r. NounPath -> Failure f r -> Success a f r -> f r +} + +instance Monad Parser where + m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks + in runParser m path kf ks' + return = pure + fail = Fail.fail + +instance Fail.MonadFail Parser where + fail msg = Parser $ \path kf _ks -> kf (reverse path) msg + +instance Functor Parser where + fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a) + in runParser m path kf ks' + +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + b <$> e + +instance Applicative Parser where + pure a = Parser $ \_path _kf ks -> ks a + (<*>) = apP + +instance Alternative Parser where + empty = fail "empty" + (<|>) = mplus + +instance MonadPlus Parser where + mzero = fail "mzero" + mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks + in runParser a path kf' ks + +instance Semigroup (Parser a) where + (<>) = mplus + +instance Monoid (Parser a) where + mempty = fail "mempty" + mappend = (<>) + + +-- Conversion ------------------------------------------------------------------ + +class FromNoun a where + parseNoun :: Noun -> Parser a + +class ToNoun a where + toNoun :: a -> Noun + +-------------------------------------------------------------------------------- + +int2Word :: Int -> Word +int2Word = fromIntegral + +word2Int :: Word -> Int +word2Int = fromIntegral + +instance ToNoun ByteString where + toNoun bs = toNoun (int2Word (length bs), bs ^. from (pill . pillBS)) + +instance ToNoun Text where -- XX TODO + toNoun t = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Text where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (decodeUtf8Lenient c) + +instance FromNoun ByteString where + parseNoun x = do + (word2Int -> len, atom) <- parseNoun x + let bs = atom ^. pill . pillBS + pure $ case compare (length bs) len of + EQ -> bs + LT -> bs <> replicate (len - length bs) 0 + GT -> take len bs + +-------------------------------------------------------------------------------- + +newtype Term = MkTerm Text + deriving newtype (Eq, Ord, Show) + +instance ToNoun Term where -- XX TODO + toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Term where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (MkTerm (decodeUtf8Lenient c)) + +-------------------------------------------------------------------------------- + +newtype Knot = MkKnot Text + deriving newtype (Eq, Ord, Show) + +instance ToNoun Knot where -- XX TODO + toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Knot where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (MkKnot (decodeUtf8Lenient c)) + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + +fromNoun :: FromNoun a => Noun -> Maybe a +fromNoun n = runParser (parseNoun n) [] onFail onSuccess + where + onFail p m = Nothing + onSuccess x = Just x + +fromNounErr :: FromNoun a => Noun -> Either Text a +fromNounErr n = runParser (parseNoun n) [] onFail onSuccess + where + onFail p m = Left (pack m) + onSuccess x = Right x + +_Poet :: (ToNoun a, FromNoun a) => Prism' Noun a +_Poet = prism' toNoun fromNoun + + +-- Trivial Conversion ---------------------------------------------------------- + +instance ToNoun Void where + toNoun = absurd + +instance FromNoun Void where + parseNoun = fail "Can't produce void" + +instance ToNoun Noun where + toNoun = id + +instance FromNoun Noun where + parseNoun = pure + + +-- Loobean Conversion ---------------------------------------------------------- + +instance ToNoun Bool where + toNoun True = Atom 0 + toNoun False = Atom 1 + +instance FromNoun Bool where + parseNoun (Atom 0) = pure True + parseNoun (Atom 1) = pure False + parseNoun (Cell _ _) = fail "expecting a bool, but got a cell" + parseNoun (Atom a) = fail ("expecting a bool, but got " <> show a) + + +-- Atom Conversion ------------------------------------------------------------- + +instance ToNoun Atom where + toNoun = Atom + +instance FromNoun Atom where + parseNoun (Cell _ _) = fail "Expecting an atom, but got a cell" + parseNoun (Atom a) = pure a + + +-- Natural Conversion----------------------------------------------------------- + +instance ToNoun Natural where toNoun = toNoun . MkAtom +instance FromNoun Natural where parseNoun = fmap unAtom . parseNoun + +instance ToNoun Integer where + toNoun = toNoun . (fromIntegral :: Integer -> Natural) + +instance FromNoun Integer where + parseNoun = fmap ((fromIntegral :: Natural -> Integer) . unAtom) . parseNoun + + +-- Word Conversion ------------------------------------------------------------- + +atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a +atomToWord atom = do + if atom > fromIntegral (maxBound :: a) + then fail "Atom doesn't fit in fixed-size word" + else pure (fromIntegral atom) + +wordToNoun :: Integral a => a -> Noun +wordToNoun = Atom . fromIntegral + +nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a +nounToWord = parseNoun >=> atomToWord + +instance ToNoun Word where toNoun = wordToNoun +instance ToNoun Word8 where toNoun = wordToNoun +instance ToNoun Word16 where toNoun = wordToNoun +instance ToNoun Word32 where toNoun = wordToNoun +instance ToNoun Word64 where toNoun = wordToNoun + +instance FromNoun Word where parseNoun = nounToWord +instance FromNoun Word8 where parseNoun = nounToWord +instance FromNoun Word16 where parseNoun = nounToWord +instance FromNoun Word32 where parseNoun = nounToWord +instance FromNoun Word64 where parseNoun = nounToWord + + +-- Nullable Conversion --------------------------------------------------------- + +-- TODO Consider enforcing that `a` must be a cell. +instance ToNoun a => ToNoun (Nullable a) where + toNoun Nil = Atom 0 + toNoun (NotNil x) = toNoun x + +instance FromNoun a => FromNoun (Nullable a) where + parseNoun (Atom 0) = pure Nil + parseNoun (Atom n) = fail ("Nullable: expected ?@(~ ^), but got " <> show n) + parseNoun n = NotNil <$> parseNoun n + + +-- Maybe is `unit` ------------------------------------------------------------- + +-- TODO Consider enforcing that `a` must be a cell. +instance ToNoun a => ToNoun (Maybe a) where + toNoun Nothing = Atom 0 + toNoun (Just x) = Cell (Atom 0) (toNoun x) + +instance FromNoun a => FromNoun (Maybe a) where + parseNoun = \case + Atom 0 -> pure Nothing + Atom n -> unexpected ("atom " <> show n) + Cell (Atom 0) t -> Just <$> parseNoun t + Cell n _ -> unexpected ("cell with head-atom " <> show n) + where + unexpected s = fail ("Expected unit value, but got " <> s) + + +-- List Conversion ------------------------------------------------------------- + +instance ToNoun a => ToNoun [a] where + toNoun xs = nounFromList (toNoun <$> xs) + where + nounFromList :: [Noun] -> Noun + nounFromList [] = Atom 0 + nounFromList (x:xs) = Cell x (nounFromList xs) + +instance FromNoun a => FromNoun [a] where + parseNoun (Atom 0) = pure [] + parseNoun (Atom _) = fail "list terminated with non-null atom" + parseNoun (Cell l r) = (:) <$> parseNoun l <*> parseNoun r + + +-- Cord Conversion ------------------------------------------------------------- + +instance ToNoun Cord where + toNoun (Cord bs) = Atom (bs ^. from (pill . pillBS)) + +instance FromNoun Cord where + parseNoun n = do + atom <- parseNoun n + pure $ Cord (atom ^. pill . pillBS) + + +-- Tank and Plum Conversion ---------------------------------------------------- + +instance ToNoun WideFmt where toNoun (WideFmt x xs) = toNoun (x, xs) +instance ToNoun TallFmt where toNoun (TallFmt x xs) = toNoun (x, xs) +instance ToNoun PlumFmt where toNoun (PlumFmt wide tall) = toNoun (wide, tall) + +instance FromNoun WideFmt where parseNoun = fmap (uncurry WideFmt) . parseNoun +instance FromNoun TallFmt where parseNoun = fmap (uncurry TallFmt) . parseNoun +instance FromNoun PlumFmt where parseNoun = fmap (uncurry PlumFmt) . parseNoun + +instance ToNoun Plum where + toNoun = \case + PAtom cord -> toNoun cord + PPara t cs -> toNoun (Cord "para", t, cs) + PTree f ps -> toNoun (Cord "tree", f, ps) + PSbrk p -> toNoun (Cord "sbrk", p) + +instance FromNoun Plum where + parseNoun = undefined + +instance ToNoun Tank where + toNoun = pure (Atom 0) + +instance FromNoun Tank where + parseNoun _ = pure (TLeaf (Tape "TODO: Tank Parsing")) + + +-- Tuple Conversions ----------------------------------------------------------- + +instance ToNoun () where + toNoun () = Atom 0 + +instance FromNoun () where + parseNoun (Atom 0) = pure () + parseNoun x = fail ("expecting `~`, but got " <> show x) + +instance (ToNoun a, ToNoun b) => ToNoun (a, b) where + toNoun (x, y) = Cell (toNoun x) (toNoun y) + +instance (FromNoun a, FromNoun b) => FromNoun (a, b) where + parseNoun (Atom n) = fail ("expected a cell, but got an atom: " <> show n) + parseNoun (Cell l r) = (,) <$> parseNoun l <*> parseNoun r + +instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where + toNoun (x, y, z) = toNoun (x, (y, z)) + +instance (FromNoun a, FromNoun b, FromNoun c) => FromNoun (a, b, c) where + parseNoun n = do + (x, t) <- parseNoun n + (y, z) <- parseNoun t + pure (x, y, z) + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where + toNoun (p, q, r, s) = toNoun (p, (q, r, s)) + +instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d) + => FromNoun (a, b, c, d) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s) <- parseNoun tail + pure (p, q, r, s) + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e) + => ToNoun (a, b, c, d, e) where + toNoun (p, q, r, s, t) = toNoun (p, (q, r, s, t)) + +instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e) + => FromNoun (a, b, c, d, e) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t) <- parseNoun tail + pure (p, q, r, s, t) + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f) + => ToNoun (a, b, c, d, e, f) where + toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u)) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f + ) + => FromNoun (a, b, c, d, e, f) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u) <- parseNoun tail + pure (p, q, r, s, t, u) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g + ) + => FromNoun (a, b, c, d, e, f, g) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v) <- parseNoun tail + pure (p, q, r, s, t, u, v) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h + ) + => FromNoun (a, b, c, d, e, f, g, h) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w) <- parseNoun tail + pure (p, q, r, s, t, u, v, w) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h, FromNoun i + ) + => FromNoun (a, b, c, d, e, f, g, h, i) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w, x) <- parseNoun tail + pure (p, q, r, s, t, u, v, w, x) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j + ) + => FromNoun (a, b, c, d, e, f, g, h, i, j) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w, x, y) <- parseNoun tail + pure (p, q, r, s, t, u, v, w, x, y) diff --git a/pkg/hs-urbit/lib/Noun/Fat.hs b/pkg/hs-urbit/lib/Noun/Fat.hs deleted file mode 100644 index 20096c5cd..000000000 --- a/pkg/hs-urbit/lib/Noun/Fat.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-| - Nouns with Pre-Computed Hash for each node. --} - -{-# LANGUAGE MagicHash, Strict #-} -{-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} - -module Noun.Fat ( FatNoun(..), FatAtom(..) - , fatSize - , fatCell, fatAtom - , toFatNoun, fromFatNoun - ) where - -import ClassyPrelude hiding (hash) - -import Data.Bits (xor) -import Data.Hashable (hash) -import GHC.Integer.GMP.Internals (BigNat) -import GHC.Natural (Natural(NatS#, NatJ#)) -import GHC.Prim (reallyUnsafePtrEquality#) -import GHC.Word (Word(W#)) -import Noun.Atom (Atom(MkAtom)) -import Noun (Noun(Atom, Cell)) - - --------------------------------------------------------------------------------- - -data FatAtom - = FatWord !Word - | FatBigN !Int !BigNat - -data FatNoun - = FatCell !Int !Word !FatNoun !FatNoun - | FatAtom !FatAtom - - --------------------------------------------------------------------------------- - -instance Hashable FatAtom where - hash = atomHash - {-# INLINE hash #-} - hashWithSalt = defaultHashWithSalt - {-# INLINE hashWithSalt #-} - -instance Hashable FatNoun where - hash = nounHash - {-# INLINE hash #-} - hashWithSalt = defaultHashWithSalt - {-# INLINE hashWithSalt #-} - -instance Eq FatAtom where - (==) x y = - case reallyUnsafePtrEquality# x y of - 1# -> True - _ -> case (x, y) of - (FatWord w1, FatWord w2 ) -> w1==w2 - (FatBigN x1 a1, FatBigN x2 a2 ) -> x1==x2 && a1==a2 - _ -> False - {-# INLINE (==) #-} - -instance Eq FatNoun where - (==) x y = - case reallyUnsafePtrEquality# x y of - 1# -> True - _ -> case (x, y) of - (FatAtom a1, FatAtom a2) -> - a1 == a2 - (FatCell x1 s1 h1 t1, FatCell x2 s2 h2 t2) -> - s1==s2 && x1==x2 && h1==h2 && t1==t2 - _ -> - False - {-# INLINE (==) #-} - - --------------------------------------------------------------------------------- - -{-# INLINE fatSize #-} -fatSize :: FatNoun -> Word -fatSize = \case - FatCell _ s _ _ -> s - _ -> 1 - -{-# INLINE atomHash #-} -atomHash :: FatAtom -> Int -atomHash = \case - FatBigN h _ -> h - FatWord w -> hash w - -{-# INLINE nounHash #-} -nounHash :: FatNoun -> Int -nounHash = \case - FatCell h _ _ _ -> h - FatAtom a -> hash a - -{-# INLINE fatAtom #-} -fatAtom :: Atom -> FatNoun -fatAtom = \case - MkAtom (NatS# wd) -> FatAtom $ FatWord (W# wd) - MkAtom n@(NatJ# bn) -> FatAtom $ FatBigN (hash bn) bn - -{-# INLINE fatCell #-} -fatCell :: FatNoun -> FatNoun -> FatNoun -fatCell h t = FatCell has siz h t - where - siz = fatSize h + fatSize t - has = nounHash h `combine` nounHash t - -{-# INLINE toFatNoun #-} -toFatNoun :: Noun -> FatNoun -toFatNoun = go - where - go (Atom a) = fatAtom a - go (Cell h t) = fatCell (go h) (go t) - -{-# INLINE fromFatNoun #-} -fromFatNoun :: FatNoun -> Noun -fromFatNoun = go - where go = \case - FatCell _ _ h t -> Cell (go h) (go t) - FatAtom (FatBigN _ a) -> Atom (MkAtom $ NatJ# a) - FatAtom (FatWord w) -> Atom (fromIntegral w) - - --- Stolen from Hashable Library ------------------------------------------------ - -{-# INLINE combine #-} -combine :: Int -> Int -> Int -combine h1 h2 = (h1 * 16777619) `xor` h2 - -{-# INLINE defaultHashWithSalt #-} -defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt salt x = salt `combine` hash x diff --git a/pkg/hs-urbit/lib/Noun/Jam.hs b/pkg/hs-urbit/lib/Noun/Jam.hs deleted file mode 100644 index 49f73c9c4..000000000 --- a/pkg/hs-urbit/lib/Noun/Jam.hs +++ /dev/null @@ -1,263 +0,0 @@ -module Noun.Jam where - -import ClassyPrelude -import Noun -import Noun.Atom -import Data.Bits -import Control.Lens -import Text.Printf - -import Control.Monad (guard) -import Data.Map (Map) -import Text.Printf (printf) - -import Test.Tasty -import Test.Tasty.TH -import Test.Tasty.QuickCheck as QC -import Test.QuickCheck - -import qualified Noun.Jam.Fast as Jam -import qualified Noun.Cue.Fast as Cue -import qualified Noun.Pill as Pill - - --- Length-Encoded Atoms -------------------------------------------------------- - -bex :: (Num a, Bits a) => Int -> a -bex = shiftL 1 - -mat' :: Atom -> Buf -mat' 0 = Buf 1 1 -mat' atm = Buf bufWid buffer - where - atmWid = bitWidth atm - preWid = bitWidth (toAtom atmWid) - bufWid = preWid + preWid + atmWid - 1 - prefix = bex preWid - extras = takeBits (preWid-1) (toAtom atmWid) - suffix = xor extras (shiftL (takeBits (atmWid-1) atm) (preWid-1)) - buffer = bitConcat prefix suffix - -rub' :: Cursor -> Maybe Buf -rub' slc@(Cursor idx buf) = - leadingZeros slc >>= \case - 0 -> pure (Buf 1 0) - prefix -> pure (Buf sz val) - where - widIdx = idx + 1 + prefix - width = fromSlice (Slice widIdx (prefix - 1) buf) - datIdx = widIdx + (prefix-1) - datWid = fromIntegral (2^(prefix-1) + width) - 1 - sz = datWid + (2*prefix) - val = bex datWid .|. fromSlice (Slice datIdx datWid buf) - -jam' :: Noun -> Atom -jam' = toAtom . fst . go 0 mempty - where - insertNoun :: Noun -> Int -> Map Noun Int -> Map Noun Int - insertNoun n i tbl = lookup n tbl - & maybe (insertMap n i tbl) (const tbl) - - go :: Int -> Map Noun Int -> Noun -> (Buf, Map Noun Int) - go off oldTbl noun = - let tbl = insertNoun noun off oldTbl in - case (lookup noun oldTbl, noun) of - (Just ref, Atom atm) | bitWidth atm <= bitWidth (toAtom ref) -> - (Buf (1+sz) (shiftL res 1), tbl) - where Buf sz res = mat' atm - (Just ref, _) -> - (Buf (2+sz) (xor 3 (shiftL res 2)), tbl) - where Buf sz res = mat' (toAtom ref) - (Nothing, Atom atm) -> - (Buf (1+sz) (shiftL res 1), tbl) - where Buf sz res = mat' atm - (Nothing, Cell lef rit) -> - (Buf (2+lSz+rSz) (xor 1 (shiftL (lRes .|. shiftL rRes lSz) 2)), rTbl) - where (Buf lSz lRes, lTbl) = go (off+2) tbl lef - (Buf rSz rRes, rTbl) = go (off+2+lSz) lTbl rit - -cue' :: Atom -> Maybe Noun -cue' buf = view _2 <$> go mempty 0 - where - go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun) - go tbl i = - case (bitIdx i buf, bitIdx (i+1) buf) of - (False, _ ) -> do Buf wid at <- rub' (Cursor (i+1) buf) - let r = Atom at - pure (wid+1, r, insertMap i r tbl) - (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) - (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) - let r = Cell lef rit - pure (2+lSz+rSz, r, insertMap i r tbl) - (True, True ) -> do Buf wid at <- rub' (Cursor (i+2) buf) - r <- lookup (fromIntegral at) tbl & \case - Nothing -> error ("bad-ref-" <> show at) - Just ix -> Just ix - pure (2+wid, r, tbl) - --------------------------------------------------------------------------------- - -mat :: Atom -> Buf -mat 0 = Buf 1 1 -mat atm = Buf bufWid buffer - where - atmWid = bitWidth atm - preWid = bitWidth (toAtom atmWid) - bufWid = 2*preWid + atmWid - prefix = shiftL 1 preWid - extras = takeBits (preWid-1) (toAtom atmWid) - suffix = xor extras (shiftL atm (preWid-1)) - buffer = bitConcat prefix suffix - -bufVal Nothing = "" -bufVal (Just (Buf sz v)) = show v <> " [" <> show sz <> "]" - -rub :: Cursor -> Maybe Buf -rub slc@(Cursor idx buf) = - leadingZeros slc >>= \case - 0 -> pure (Buf 1 0) - prefix -> pure (Buf sz val) - where - widIdx = idx + 1 + prefix - extra = fromSlice (Slice widIdx (prefix - 1) buf) - datIdx = widIdx + (prefix-1) - datWid = fromIntegral $ extra + 2^(prefix-1) - sz = datWid + (2*prefix) - val = fromSlice (Slice datIdx datWid buf) - --- Noun Serialization ---------------------------------------------------------- - --- bex can be implemented using --- `mpz_mul_2exp(a_mp, a_mp, a); - -jam :: Noun -> Atom -jam = toAtom . fst . go 0 mempty - where - insertNoun :: Noun -> Int -> Map Noun Int -> Map Noun Int - insertNoun n i tbl = lookup n tbl - & maybe (insertMap n i tbl) (const tbl) - - go :: Int -> Map Noun Int -> Noun -> (Buf, Map Noun Int) - go off oldTbl noun = - let tbl = insertNoun noun off oldTbl in - case (lookup noun oldTbl, noun) of - (Just ref, Atom atm) | bitWidth atm <= (1+bitWidth (toAtom ref)) -> - (Buf (1+sz) (shiftL res 1), tbl) - where Buf sz res = mat atm - (Just ref, _) -> - (Buf (2+sz) (xor 3 (shiftL res 2)), tbl) - where Buf sz res = mat (toAtom ref) - (Nothing, Atom atm) -> - (Buf (1+sz) (shiftL res 1), tbl) - where Buf sz res = mat atm - (Nothing, Cell lef rit) -> - (Buf (2+lSz+rSz) (xor 1 (shiftL (bitConcat lRes rRes) 2)), rTbl) - where (Buf lSz lRes, lTbl) = go (off+2) tbl lef - (Buf rSz rRes, rTbl) = go (off+2+lSz) lTbl rit - -leadingZeros :: Cursor -> Maybe Int -leadingZeros (Cursor idx buf) = go 0 - where wid = bitWidth buf - go n = do () <- if (n < wid) then pure () - else error "infinite-atom" - guard (n < wid) - if bitIdx (idx+n) buf then pure n else go (n+1) - -cue :: Atom -> Maybe Noun -cue buf = view _2 <$> go mempty 0 - where - go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun) - go tbl i = - case (bitIdx i buf, bitIdx (i+1) buf) of - (False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf) - let r = Atom at - pure (1+wid, r, insertMap i r tbl) - (True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2) - (rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz) - let r = Cell lef rit - pure (2+lSz+rSz, r, insertMap i r tbl) - (True, True ) -> do Buf wid at <- rub (Cursor (i+2) buf) - r <- lookup (fromIntegral at) tbl & \case - Nothing -> error ("bad-ref-" <> show at) - Just ix -> Just ix - pure (2+wid, r, tbl) - - --- Tests ----------------------------------------------------------------------- - -a12 = Atom 12 -a36 = Atom 36 -a9 = Atom 9 - -d12 = Cell a12 a12 -q12 = Cell d12 d12 - -midleEx = Cell a36 $ Cell a9 $ Cell q12 q12 - -smallEx = Cell (Cell (Atom 14) (Atom 8)) - $ Cell (Atom 15) (Atom 15) - -smallEx2 = Cell (Cell (Atom 0) (Atom 0)) - $ Cell (Atom 10) (Atom 10) - -pills :: [Atom] -pills = [ 0x2, 0xc, 0x48, 0x29, 0xc9, 0x299 - , 0x3170_c7c1, 0x93_c7c1, 0xa_72e0, 0x1bd5_b7dd_e080 - ] - --- cueTest :: Maybe [Noun] --- cueTest = traverse cue pills - --- jamTest :: Maybe [Atom] --- jamTest = fmap jam <$> cueTest - -prop_fastMatSlow :: Atom -> Bool -prop_fastMatSlow a = jam (Atom a) == Jam.jam (Atom a) - -prop_fastJamSlow :: Noun -> Bool -prop_fastJamSlow n = x == y || (bitWidth y <= bitWidth x && cue y == cue x) - where x = jam n - y = Jam.jam n - -prop_fastRub :: Atom -> Bool -prop_fastRub a = Right (Atom a) == Cue.cue (jam (Atom a)) - -prop_fastCue :: Noun -> Bool -prop_fastCue n = Right n == Cue.cue (jam n) - -prop_fastJam :: Noun -> Bool -prop_fastJam n = Just n == cue (Jam.jam n) - --- prop_jamCue :: Noun -> Bool --- prop_jamCue n = Just n == cue (jam n) - --- prop_matRub :: Atom -> Bool --- prop_matRub atm = matSz==rubSz && rubRes==atm - -- where - -- Buf matSz matBuf = mat atm - -- Buf rubSz rubRes = fromMaybe mempty (rub $ Cursor 0 matBuf) - --- prop_jamCue' :: Noun -> Bool --- prop_jamCue' n = Just n == cue' (jam' n) - --- prop_matRub' :: Atom -> Bool --- prop_matRub' atm = matSz==rubSz && rubRes==atm - -- where - -- Buf matSz matBuf = mat' atm - -- Buf rubSz rubRes = fromMaybe mempty (rub' $ Cursor 0 matBuf) - -main :: IO () -main = $(defaultMainGenerator) - -matSz' :: Atom -> Int -matSz' a = length s - 1 - where - s :: String - s = printf "%b" $ fromIntegral @Atom @Integer $ jam $ Atom a - -(a, c) = (Atom, Cell) - -printJam :: Noun -> IO () -printJam n = do - j <- evaluate (force (fromIntegral $ jam n)) - printf "0b%b\n" (j :: Integer) diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index ff58fe9f9..7bbc6ab34 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -1,27 +1,18 @@ -{-# LANGUAGE MagicHash #-} - module Noun.Lens where import ClassyPrelude -import Noun.Pill -import Noun.Fat +import Pill import Noun -import Noun.Atom +import Atom import Control.Lens -import Noun.Jam.Fast (jam, jamBS, jamFat, jamFatBS) -import Noun.Cue.Fast (cue, cueBS, cueFat, cueFatBS) +import Jam (jam, jamBS) +import Cue (cue, cueBS) -------------------------------------------------------------------------------- eitherToMaybe (Left _) = Nothing eitherToMaybe (Right x) = Just x -_CueFatBytes :: Prism' ByteString FatNoun -_CueFatBytes = prism' jamFatBS (eitherToMaybe . cueFatBS) - -_CueFat :: Prism' Atom FatNoun -_CueFat = prism' jamFat (eitherToMaybe . cueFat) - _CueBytes :: Prism' ByteString Noun _CueBytes = prism' jamBS (eitherToMaybe . cueBS) @@ -30,25 +21,25 @@ _Cue = prism' jam (eitherToMaybe . cue) -------------------------------------------------------------------------------- -loadNoun :: FilePath -> IO (Maybe FatNoun) -loadNoun = fmap (preview _CueFatBytes) . readFile +loadNoun :: FilePath -> IO (Maybe Noun) +loadNoun = fmap (preview _CueBytes) . readFile -dumpJam :: FilePath -> FatNoun -> IO () -dumpJam fp = writeFile fp . view (re _CueFatBytes) +dumpJam :: FilePath -> Noun -> IO () +dumpJam fp = writeFile fp . view (re _CueBytes) tryCuePill :: PillFile -> IO () tryCuePill pill = - loadNoun (show pill) >>= \case Nothing -> print "nil" - Just (FatAtom _) -> print "atom" - _ -> print "cell" + loadNoun (show pill) >>= \case Nothing -> print "nil" + Just (Atom _) -> print "atom" + Just (Cell _ _) -> print "cell" tryCueJamPill :: PillFile -> IO () tryCueJamPill pill = do n <- loadNoun (show pill) >>= \case - Nothing -> print "failure" >> pure (FatAtom $ FatWord 0) - Just n@(FatAtom _) -> print "atom" >> pure n - Just n@(FatCell _ _ _ _) -> print "cell" >> pure n + Nothing -> print "failure" >> pure (Atom 0) + Just n@(Atom _) -> print "atom" >> pure n + Just n@(Cell _ _) -> print "cell" >> pure n - bs <- evaluate (force (jamFatBS n)) + bs <- evaluate (force (jamBS n)) print ("jam size: " <> show (length bs)) diff --git a/pkg/hs-urbit/lib/Noun/Poet.hs b/pkg/hs-urbit/lib/Noun/Poet.hs deleted file mode 100644 index b3219a164..000000000 --- a/pkg/hs-urbit/lib/Noun/Poet.hs +++ /dev/null @@ -1,661 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DefaultSignatures #-} - -module Noun.Poet where - -import ClassyPrelude hiding (fromList) -import Control.Lens - -import Control.Applicative -import Control.Monad -import Noun -import Noun.Atom -import Noun.Pill -import Data.Void -import Data.Word -import GHC.Natural -import GHC.Generics hiding (from) - -import qualified GHC.Generics as GHC - -import Data.Typeable (Typeable) -import RIO (decodeUtf8Lenient) - -import qualified Data.Char as C -import qualified Control.Monad.Fail as Fail - - --- Types For Hoon Constructs --------------------------------------------------- - -{-| - `Nullable a <-> ?@(~ a)` - - This is distinct from `unit`, since there is no tag on the non-atom - case, therefore `a` must always be cell type. --} -data Nullable a = Nil | NotNil a - deriving (Eq, Ord, Show) - -newtype Tour = Tour [Char] - deriving (Eq, Ord, Show) - -newtype Tape = Tape ByteString - deriving newtype (Eq, Ord, Show, IsString) - -newtype Cord = Cord { unCord :: ByteString } - deriving newtype (Eq, Ord, Show, IsString, NFData) - --- Chars ----------------------------------------------------------------------- - -instance ToNoun Char where - toNoun = toNoun . (fromIntegral :: Int -> Word32) . C.ord - -instance FromNoun Char where - parseNoun n = do - w :: Word32 <- parseNoun n - pure $ C.chr $ fromIntegral w - --- Pretty Printing ------------------------------------------------------------- - -type Tang = [Tank] - -data Tank - = TLeaf Tape - | TPlum Plum - | TPalm (Tape, Tape, Tape, Tape) [Tank] - | TRose (Tape, Tape, Tape) [Tank] - deriving (Eq, Ord, Show) - -type Tile = Cord - -data WideFmt - = WideFmt { delimit :: Tile, enclose :: Maybe (Tile, Tile) } - deriving (Eq, Ord, Show) - -data TallFmt - = TallFmt { intro :: Tile, indef :: Maybe (Tile, Tile) } - deriving (Eq, Ord, Show) - -data PlumFmt - = PlumFmt (Maybe WideFmt) (Maybe TallFmt) - deriving (Eq, Ord, Show) - -data Plum - = PAtom Cord - | PPara Tile [Cord] - | PTree PlumFmt [Plum] - | PSbrk Plum - deriving (Eq, Ord, Show) - - --- IResult --------------------------------------------------------------------- - -data IResult a = IError NounPath String | ISuccess a - deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) - -instance Applicative IResult where - pure = ISuccess - (<*>) = ap - -instance Fail.MonadFail IResult where - fail err = traceM ("!" <> err <> "!") >> IError [] err - -instance Monad IResult where - return = pure - fail = Fail.fail - ISuccess a >>= k = k a - IError path err >>= _ = IError path err - -instance MonadPlus IResult where - mzero = fail "mzero" - mplus a@(ISuccess _) _ = a - mplus _ b = b - -instance Alternative IResult where - empty = mzero - (<|>) = mplus - -instance Semigroup (IResult a) where - (<>) = mplus - -instance Monoid (IResult a) where - mempty = fail "mempty" - mappend = (<>) - - --- Result ---------------------------------------------------------------------- - -data Result a = Error String | Success a - deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) - -instance Applicative Result where - pure = Success - (<*>) = ap - -instance Fail.MonadFail Result where - fail err = Error err - -instance Monad Result where - return = pure - fail = Fail.fail - - Success a >>= k = k a - Error err >>= _ = Error err - -instance MonadPlus Result where - mzero = fail "mzero" - mplus a@(Success _) _ = a - mplus _ b = b - -instance Alternative Result where - empty = mzero - (<|>) = mplus - -instance Semigroup (Result a) where - (<>) = mplus - {-# INLINE (<>) #-} - -instance Monoid (Result a) where - mempty = fail "mempty" - mappend = (<>) - - --- "Parser" -------------------------------------------------------------------- - -type Failure f r = NounPath -> String -> f r -type Success a f r = a -> f r - -newtype Parser a = Parser { - runParser :: forall f r. NounPath -> Failure f r -> Success a f r -> f r -} - -instance Monad Parser where - m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks - in runParser m path kf ks' - return = pure - fail = Fail.fail - -instance Fail.MonadFail Parser where - fail msg = Parser $ \path kf _ks -> kf (reverse path) msg - -instance Functor Parser where - fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a) - in runParser m path kf ks' - -apP :: Parser (a -> b) -> Parser a -> Parser b -apP d e = do - b <- d - b <$> e - -instance Applicative Parser where - pure a = Parser $ \_path _kf ks -> ks a - (<*>) = apP - -instance Alternative Parser where - empty = fail "empty" - (<|>) = mplus - -instance MonadPlus Parser where - mzero = fail "mzero" - mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks - in runParser a path kf' ks - -instance Semigroup (Parser a) where - (<>) = mplus - -instance Monoid (Parser a) where - mempty = fail "mempty" - mappend = (<>) - - --- Conversion ------------------------------------------------------------------ - -class FromNoun a where - parseNoun :: Noun -> Parser a - -class ToNoun a where - toNoun :: a -> Noun - - default toNoun :: (Generic a, GToNoun (Rep a)) => a -> Noun - toNoun = genericToNoun - - --- Generic Deriving ToNoun ----------------------------------------------------- - --- TODO Handle enums - -class GToNoun f where - gToNoun :: f a -> Noun - -genericToNoun :: (Generic a, GToNoun (Rep a)) => a -> Noun -genericToNoun = gToNoun . GHC.from - --------------------------------------------------------------------------------- - -instance GToNoun V1 where gToNoun _ = undefined -instance GToNoun U1 where gToNoun U1 = Atom 0 - -instance ToNoun a => GToNoun (K1 i a) where - gToNoun = toNoun . unK1 - -instance (GToNoun a, GToNoun b) => GToNoun (a :*: b) where - gToNoun (x :*: y) = Cell (gToNoun x) (gToNoun y) - -instance (GToNoun a, GToNoun b) => GToNoun (a :+: b) where - gToNoun (L1 x) = gToNoun x - gToNoun (R1 x) = gToNoun x - -instance GToNoun a => GToNoun (S1 c a) where - gToNoun x = gToNoun (unM1 x) - -instance GToNoun a => GToNoun (D1 c a) where - gToNoun x = gToNoun (unM1 x) - -instance (GToNoun f, Constructor c) => GToNoun (C1 c f) where - gToNoun x = Cell tag val - where tag = toNoun (hsToHoon $ conName x) - val = gToNoun (unM1 x) - --------------------------------------------------------------------------------- - -hsToHoon :: String -> Text -hsToHoon = go [] - where - go acc [] = pack $ intercalate "-" $ reverse acc - go acc (c:cs) = go (elem:acc) remain - where - head = C.toLower c - (tail, remain) = break C.isUpper cs - elem = head:tail - --- Copy-Pasta ------------------------------------------------------------------ - -class HasConstructor (f :: * -> *) where - gConsName :: f x -> String - -instance HasConstructor f => HasConstructor (D1 c f) where - gConsName (M1 x) = gConsName x - -instance (HasConstructor x, HasConstructor y) => HasConstructor (x :+: y) where - gConsName (L1 l) = gConsName l - gConsName (R1 r) = gConsName r - -instance Constructor c => HasConstructor (C1 c f) where - gConsName x = conName x - -consName :: (HasConstructor (Rep a), Generic a) => a -> String -consName = gConsName . GHC.from - --------------------------------------------------------------------------------- - -int2Word :: Int -> Word -int2Word = fromIntegral - -word2Int :: Word -> Int -word2Int = fromIntegral - -instance ToNoun ByteString where - toNoun bs = toNoun (int2Word (length bs), bs ^. from (pill . pillBS)) - -instance ToNoun Text where -- XX TODO - toNoun t = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Text where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (decodeUtf8Lenient c) - -instance FromNoun ByteString where - parseNoun x = do - (word2Int -> len, atom) <- parseNoun x - let bs = atom ^. pill . pillBS - pure $ case compare (length bs) len of - EQ -> bs - LT -> bs <> replicate (len - length bs) 0 - GT -> take len bs - --------------------------------------------------------------------------------- - -newtype Term = MkTerm Text - deriving newtype (Eq, Ord, Show) - -instance ToNoun Term where -- XX TODO - toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Term where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (MkTerm (decodeUtf8Lenient c)) - --------------------------------------------------------------------------------- - -newtype Knot = MkKnot Text - deriving newtype (Eq, Ord, Show) - -instance ToNoun Knot where -- XX TODO - toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Knot where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (MkKnot (decodeUtf8Lenient c)) - --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- - -fromNoun :: FromNoun a => Noun -> Maybe a -fromNoun n = runParser (parseNoun n) [] onFail onSuccess - where - onFail p m = Nothing - onSuccess x = Just x - -fromNounErr :: FromNoun a => Noun -> Either Text a -fromNounErr n = runParser (parseNoun n) [] onFail onSuccess - where - onFail p m = Left (pack m) - onSuccess x = Right x - -_Poet :: (ToNoun a, FromNoun a) => Prism' Noun a -_Poet = prism' toNoun fromNoun - - --- Trivial Conversion ---------------------------------------------------------- - -instance ToNoun Void where - toNoun = absurd - -instance FromNoun Void where - parseNoun = fail "Can't produce void" - -instance ToNoun Noun where - toNoun = id - -instance FromNoun Noun where - parseNoun = pure - - --- Loobean Conversion ---------------------------------------------------------- - -instance ToNoun Bool where - toNoun True = Atom 0 - toNoun False = Atom 1 - -instance FromNoun Bool where - parseNoun (Atom 0) = pure True - parseNoun (Atom 1) = pure False - parseNoun (Cell _ _) = fail "expecting a bool, but got a cell" - parseNoun (Atom a) = fail ("expecting a bool, but got " <> show a) - - --- Atom Conversion ------------------------------------------------------------- - -instance ToNoun Atom where - toNoun = Atom - -instance FromNoun Atom where - parseNoun (Cell _ _) = fail "Expecting an atom, but got a cell" - parseNoun (Atom a) = pure a - - --- Natural Conversion----------------------------------------------------------- - -instance ToNoun Natural where toNoun = toNoun . MkAtom -instance FromNoun Natural where parseNoun = fmap unAtom . parseNoun - -instance ToNoun Integer where - toNoun = toNoun . (fromIntegral :: Integer -> Natural) - -instance FromNoun Integer where - parseNoun = fmap ((fromIntegral :: Natural -> Integer) . unAtom) . parseNoun - - --- Word Conversion ------------------------------------------------------------- - -atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a -atomToWord atom = do - if atom > fromIntegral (maxBound :: a) - then fail "Atom doesn't fit in fixed-size word" - else pure (fromIntegral atom) - -wordToNoun :: Integral a => a -> Noun -wordToNoun = Atom . fromIntegral - -nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a -nounToWord = parseNoun >=> atomToWord - -instance ToNoun Word where toNoun = wordToNoun -instance ToNoun Word8 where toNoun = wordToNoun -instance ToNoun Word16 where toNoun = wordToNoun -instance ToNoun Word32 where toNoun = wordToNoun -instance ToNoun Word64 where toNoun = wordToNoun - -instance FromNoun Word where parseNoun = nounToWord -instance FromNoun Word8 where parseNoun = nounToWord -instance FromNoun Word16 where parseNoun = nounToWord -instance FromNoun Word32 where parseNoun = nounToWord -instance FromNoun Word64 where parseNoun = nounToWord - - --- Nullable Conversion --------------------------------------------------------- - --- TODO Consider enforcing that `a` must be a cell. -instance ToNoun a => ToNoun (Nullable a) where - toNoun Nil = Atom 0 - toNoun (NotNil x) = toNoun x - -instance FromNoun a => FromNoun (Nullable a) where - parseNoun (Atom 0) = pure Nil - parseNoun (Atom n) = fail ("Nullable: expected ?@(~ ^), but got " <> show n) - parseNoun n = NotNil <$> parseNoun n - - --- Maybe is `unit` ------------------------------------------------------------- - --- TODO Consider enforcing that `a` must be a cell. -instance ToNoun a => ToNoun (Maybe a) where - toNoun Nothing = Atom 0 - toNoun (Just x) = Cell (Atom 0) (toNoun x) - -instance FromNoun a => FromNoun (Maybe a) where - parseNoun = \case - Atom 0 -> pure Nothing - Atom n -> unexpected ("atom " <> show n) - Cell (Atom 0) t -> Just <$> parseNoun t - Cell n _ -> unexpected ("cell with head-atom " <> show n) - where - unexpected s = fail ("Expected unit value, but got " <> s) - - --- List Conversion ------------------------------------------------------------- - -instance ToNoun a => ToNoun [a] where - toNoun xs = fromList (toNoun <$> xs) - -instance FromNoun a => FromNoun [a] where - parseNoun (Atom 0) = pure [] - parseNoun (Atom _) = fail "list terminated with non-null atom" - parseNoun (Cell l r) = (:) <$> parseNoun l <*> parseNoun r - - --- Cord Conversion ------------------------------------------------------------- - -instance ToNoun Cord where - toNoun (Cord bs) = Atom (bs ^. from (pill . pillBS)) - -instance FromNoun Cord where - parseNoun n = do - atom <- parseNoun n - pure $ Cord (atom ^. pill . pillBS) - - --- Tank and Plum Conversion ---------------------------------------------------- - -instance ToNoun WideFmt where toNoun (WideFmt x xs) = toNoun (x, xs) -instance ToNoun TallFmt where toNoun (TallFmt x xs) = toNoun (x, xs) -instance ToNoun PlumFmt where toNoun (PlumFmt wide tall) = toNoun (wide, tall) - -instance FromNoun WideFmt where parseNoun = fmap (uncurry WideFmt) . parseNoun -instance FromNoun TallFmt where parseNoun = fmap (uncurry TallFmt) . parseNoun -instance FromNoun PlumFmt where parseNoun = fmap (uncurry PlumFmt) . parseNoun - -instance ToNoun Plum where - toNoun = \case - PAtom cord -> toNoun cord - PPara t cs -> toNoun (Cord "para", t, cs) - PTree f ps -> toNoun (Cord "tree", f, ps) - PSbrk p -> toNoun (Cord "sbrk", p) - -instance FromNoun Plum where - parseNoun = undefined - -instance ToNoun Tank where - toNoun = pure (Atom 0) - -instance FromNoun Tank where - parseNoun _ = pure (TLeaf (Tape "TODO: Tank Parsing")) - - --- Pair Conversion ------------------------------------------------------------- - -instance ToNoun () where - toNoun () = Atom 0 - -instance FromNoun () where - parseNoun (Atom 0) = pure () - parseNoun x = fail ("expecting `~`, but got " <> showNoun x) - -instance (ToNoun a, ToNoun b) => ToNoun (a, b) where - toNoun (x, y) = Cell (toNoun x) (toNoun y) - -instance (FromNoun a, FromNoun b) => FromNoun (a, b) where - parseNoun (Atom n) = fail ("expected a cell, but got an atom: " <> show n) - parseNoun (Cell l r) = (,) <$> parseNoun l <*> parseNoun r - - --- Trel Conversion ------------------------------------------------------------- - -instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where - toNoun (x, y, z) = toNoun (x, (y, z)) - -instance (FromNoun a, FromNoun b, FromNoun c) => FromNoun (a, b, c) where - parseNoun n = do - (x, t) <- parseNoun n - (y, z) <- parseNoun t - pure (x, y, z) - - --- Quad Conversion ------------------------------------------------------------- - -instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where - toNoun (p, q, r, s) = toNoun (p, (q, r, s)) - -instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d) - => FromNoun (a, b, c, d) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s) <- parseNoun tail - pure (p, q, r, s) - - --- Pent Conversion ------------------------------------------------------------ - -instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e) - => ToNoun (a, b, c, d, e) where - toNoun (p, q, r, s, t) = toNoun (p, (q, r, s, t)) - -instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e) - => FromNoun (a, b, c, d, e) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t) <- parseNoun tail - pure (p, q, r, s, t) - - --- Sext Conversion ------------------------------------------------------------ - -instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f) - => ToNoun (a, b, c, d, e, f) where - toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u)) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f - ) - => FromNoun (a, b, c, d, e, f) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u) <- parseNoun tail - pure (p, q, r, s, t, u) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f, FromNoun g - ) - => FromNoun (a, b, c, d, e, f, g) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u, v) <- parseNoun tail - pure (p, q, r, s, t, u, v) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f, FromNoun g, FromNoun h - ) - => FromNoun (a, b, c, d, e, f, g, h) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u, v, w) <- parseNoun tail - pure (p, q, r, s, t, u, v, w) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f, FromNoun g, FromNoun h, FromNoun i - ) - => FromNoun (a, b, c, d, e, f, g, h, i) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u, v, w, x) <- parseNoun tail - pure (p, q, r, s, t, u, v, w, x) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j - ) - => FromNoun (a, b, c, d, e, f, g, h, i, j) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u, v, w, x, y) <- parseNoun tail - pure (p, q, r, s, t, u, v, w, x, y) - - --- This Shouldn't Be Here ------------------------------------------------------ - -showAtom :: Atom -> String -showAtom 0 = "0" -showAtom a = - let mTerm = do - t <- fromNoun (Atom a) - let ok = \x -> (x=='-' || C.isAlphaNum x) - guard (all ok (t :: Text)) - pure ("%" <> unpack t) - - in case mTerm of - Nothing -> show a - Just st -> st - -showNoun :: Noun -> String -showNoun = \case - Atom a -> showAtom a - Cell x y -> fmtCell (showNoun <$> (x : toTuple y)) - where - fmtCell :: [String] -> String - fmtCell xs = "[" <> intercalate " " xs <> "]" - -pPrintAtom :: Atom -> IO () -pPrintAtom = putStrLn . pack . showAtom - -pPrintNoun :: Noun -> IO () -pPrintNoun = putStrLn . pack . showNoun diff --git a/pkg/hs-urbit/lib/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Noun/TH.hs similarity index 99% rename from pkg/hs-urbit/lib/Noun/Poet/TH.hs rename to pkg/hs-urbit/lib/Noun/TH.hs index 46bfc01a0..b7155fa6a 100644 --- a/pkg/hs-urbit/lib/Noun/Poet/TH.hs +++ b/pkg/hs-urbit/lib/Noun/TH.hs @@ -2,13 +2,13 @@ Generate FromNoun and ToNoun instances. -} -module Noun.Poet.TH where +module Noun.TH where import ClassyPrelude hiding (fromList) +import Noun import Control.Lens import Language.Haskell.TH import Language.Haskell.TH.Syntax -import Noun.Poet hiding (hsToHoon) import RIO (decodeUtf8Lenient) diff --git a/pkg/hs-urbit/lib/Noun/Zip.hs b/pkg/hs-urbit/lib/Noun/Zip.hs deleted file mode 100644 index 786251779..000000000 --- a/pkg/hs-urbit/lib/Noun/Zip.hs +++ /dev/null @@ -1,234 +0,0 @@ -{- - Can de-duplication be orthogonal to serialization? --} - -module Noun.Zip where - -import ClassyPrelude hiding (zip, unzip) - -import Control.Applicative -import Control.Lens -import Data.Bits -import Data.Either.Extra -import Data.Flat -import Data.Flat -import Data.Flat.Bits -import GHC.Generics -import GHC.Natural -import Noun -import Noun.Atom -import Noun.Jam -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen -import Text.Printf - -import Data.Maybe (fromJust) -import Data.List (intercalate) -import Data.Typeable (Typeable) - -import Control.Monad.State.Strict hiding (forM_, replicateM) -import Control.Monad.Trans.Maybe - -import qualified ClassyPrelude -import qualified Data.Vector as V -import qualified Data.List as L -import qualified Data.Vector.Unboxed as UV - -import Test.Tasty -import Test.Tasty.TH -import Test.Tasty.QuickCheck as QC -import Test.QuickCheck - --- Atoms Optimized For Small Values -------------------------------------------- - -data Unary = Z | O Unary - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass Flat - -instance IsAtom Unary where - toAtom Z = 0 - toAtom (O u) = 1+toAtom u - fromAtom 0 = Z - fromAtom n = O (fromAtom (pred n)) - -data ZipAtom - = ZATiny Unary - | ZAWide Natural - deriving stock (Eq, Ord, Generic) - deriving anyclass Flat - -instance Show ZipAtom where - show = show . toAtom - -instance IsAtom ZipAtom where - toAtom (ZATiny u) = toAtom u - toAtom (ZAWide n) = toAtom n + 8 - fromAtom a | a <= 7 = ZATiny (fromAtom a) - fromAtom (MkAtom n) = ZAWide (n-8) - - --- External Types -------------------------------------------------------------- - -data ZipNode - = ZipAtom !ZipAtom - | ZipCell !ZipRef !ZipRef - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass Flat - -data ZipRef - = ZRInline !ZipNode - | ZRIndex !ZipAtom - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass Flat - -type Zip = ([ZipNode], ZipNode) - --- Zip and UnZip --------------------------------------------------------------- - -refCount :: Noun -> Map Noun Word -refCount = go mempty - where - ins :: Noun -> Map Noun Word -> Map Noun Word - ins = alterMap (Just . maybe 1 (+1)) - - go :: Map Noun Word -> Noun -> Map Noun Word - go acc a@(Atom _) = ins a acc - go acc c@(Cell l r) = go (go (ins c acc) l) r - -zipTable :: Noun -> (Vector Noun, Map Noun Int) -zipTable top = (V.fromList tbl, keys) - where - keys = mapFromList (ClassyPrelude.zip tbl [0..]) - big = \case Atom a -> a >= 127+8 - _ -> True - tbl = fmap fst - $ sortBy (comparing snd) - $ filter (\(k,v) -> big k && v>1) - $ mapToList - $ refCount top - -zip :: Noun -> Zip -zip top = (V.toList dups, cvtNode top) - where - (tbl, keys) = zipTable top - dups = cvtNode <$> tbl - cvtRef n = lookup n keys & \case Nothing -> ZRInline (cvtNode n) - Just a -> ZRIndex (fromAtom $ toAtom a) - cvtNode = \case Atom a -> ZipAtom (fromAtom a) - Cell l r -> ZipCell (cvtRef l) (cvtRef r) - -unzip :: Zip -> Maybe Noun -unzip (V.fromList -> dups, top) = recover top - where - recover :: ZipNode -> Maybe Noun - recover (ZipAtom a) = pure (Atom $ toAtom a) - recover (ZipCell l r) = Cell <$> getRef l <*> getRef r - - getRef :: ZipRef -> Maybe Noun - getRef (ZRInline n) = recover n - getRef (ZRIndex ix) = dups V.!? fromAtom (toAtom ix) >>= recover - - --- Tests ----------------------------------------------------------------------- - -compareSize :: Noun -> Int -compareSize n = flatSz - jamSz - where - Buf jamSz _ = fromAtom (jam' n) - flatSz = length (bits (zip n)) - -compareZipCompression :: Noun -> Int -compareZipCompression n = zipSz - rawSz - where - rawSz = length (bits n) - zipSz = length (bits (zip n)) - -compareRawToJam :: Noun -> Int -compareRawToJam n = rawSz - jamSz - where - rawSz = length (bits n) - Buf jamSz _ = fromAtom (jam' n) - -prop_zipUnzip :: Noun -> Bool -prop_zipUnzip n = Just n == unzip (zip n) - -zipFlat :: Noun -> ByteString -zipFlat = flat . zip - -unZipFlat :: ByteString -> Maybe Noun -unZipFlat = (>>= unzip) . eitherToMaybe . unflat - -prop_zipFlatRoundTrip :: Noun -> Bool -prop_zipFlatRoundTrip n = Just n == (unZipFlat . zipFlat) n - -main :: IO () -main = $(defaultMainGenerator) - -dub :: Noun -> Noun -dub x = Cell x x - -allAtoms :: Int -> [Noun] -allAtoms n = Atom . (\n -> 2^n - 1) <$> [0..toAtom n] - -allCells :: Int -> [Noun] -allCells 0 = allAtoms 1 -allCells n = do - a <- Atom <$> [0, (2 ^ toAtom n) - 1] - c <- allCells (n-1) - [Cell c a, Cell a c, Cell c c] - -allNouns :: Int -> [Noun] -allNouns sz = ordNub (allCells sz) - -nounSizes :: (Noun -> Int) -> Int -> [(Int, Noun)] -nounSizes f sz = sort (allNouns sz <&> \n -> (f n, n)) - -jamSz :: Noun -> Int -jamSz = (\(Buf sz _) -> sz) . fromAtom . jam' - -showFlatZipSizes :: Int -> IO () -showFlatZipSizes dep = traverse_ print (nounSizes (length . bits . zip) dep) - -showJamSizes :: Int -> IO () -showJamSizes dep = traverse_ print (nounSizes jamSz dep) - --------------------------------------------------------------------------------- - -sumJamSizes :: Int -> Int -sumJamSizes dep = sum $ map fst (nounSizes jamSz dep) - -sumFlatSizes :: Int -> Int -sumFlatSizes dep = sum $ map fst (nounSizes (length . bits) dep) - -sumFlatZipSizes :: Int -> Int -sumFlatZipSizes dep = sum $ map fst (nounSizes (length . bits . zip) dep) - --------------------------------------------------------------------------------- - -compareSizes :: (Noun -> Int) -> IO () -compareSizes f = do - nouns <- join <$> (replicateM 100 (sample' (arbitrary :: Gen Noun)) :: IO [[Noun]]) - traverse_ print $ reverse - $ ordNub - $ sort - $ fmap ((`div` 64) . f) - $ nouns - -- traverse_ print $ filter ((> 1000) . abs . f) nouns - -testSizes :: IO () -testSizes = compareSizes compareSize - -testZipCompression :: IO () -testZipCompression = compareSizes compareZipCompression - -testRawToJamSizes :: IO () -testRawToJamSizes = compareSizes compareRawToJam - -allSizeTests :: IO () -allSizeTests = do - putStrLn "zipFlat - jam" - testSizes - putStrLn "\nzipFlat - flat" - testZipCompression - putStrLn "\nflat - jam" - testRawToJamSizes diff --git a/pkg/hs-urbit/lib/Noun/Pill.hs b/pkg/hs-urbit/lib/Pill.hs similarity index 98% rename from pkg/hs-urbit/lib/Noun/Pill.hs rename to pkg/hs-urbit/lib/Pill.hs index 501943a29..fe546e385 100644 --- a/pkg/hs-urbit/lib/Noun/Pill.hs +++ b/pkg/hs-urbit/lib/Pill.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE MagicHash #-} - {- TODO Handle 32-bit architectures TODO Handle big-endian. @@ -20,11 +18,12 @@ machines. -} -module Noun.Pill where +module Pill + ( pill, pillBS, atomBS, bigNatWords, atomWords, PillFile(..), Pill(..) + ) where import ClassyPrelude -import Noun hiding (toList, fromList) -import Noun.Atom +import Atom import Data.Flat hiding (from, to) import Control.Monad.Except import Control.Lens hiding (index, Index) diff --git a/pkg/hs-urbit/lib/Urbit/Ames.hs b/pkg/hs-urbit/lib/Urbit/Ames.hs index e97fcb067..3e9bc9219 100644 --- a/pkg/hs-urbit/lib/Urbit/Ames.hs +++ b/pkg/hs-urbit/lib/Urbit/Ames.hs @@ -4,7 +4,7 @@ import ClassyPrelude import Data.IP import Noun -import Noun.Atom +import Atom import Network.Socket diff --git a/pkg/hs-urbit/lib/Urbit/Time.hs b/pkg/hs-urbit/lib/Urbit/Time.hs index 8001ac822..ca835d8f2 100644 --- a/pkg/hs-urbit/lib/Urbit/Time.hs +++ b/pkg/hs-urbit/lib/Urbit/Time.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NumericUnderscores, GeneralizedNewtypeDeriving #-} - -- TODO This is slow. module Urbit.Time where @@ -7,12 +5,12 @@ module Urbit.Time where import Prelude import Control.Lens +import Noun (FromNoun, ToNoun) import Data.Bits (shiftL, shiftR) import Data.Time.Clock (DiffTime, UTCTime, picosecondsToDiffTime) import Data.Time.Clock (picosecondsToDiffTime, diffTimeToPicoseconds) import Data.Time.Clock.System (SystemTime(..), getSystemTime) import Data.Time.Clock.System (utcToSystemTime, systemToUTCTime) -import Noun.Poet (FromNoun, ToNoun) -- Types ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Ames.hs b/pkg/hs-urbit/lib/Vere/Ames.hs index b124106fc..443a85cd7 100644 --- a/pkg/hs-urbit/lib/Vere/Ames.hs +++ b/pkg/hs-urbit/lib/Vere/Ames.hs @@ -4,9 +4,8 @@ import ClassyPrelude import Data.IP import Data.Void import Noun -import Noun.Atom -import Noun.Poet -import Noun.Poet.TH +import Atom +import Noun.TH import Control.Lens import qualified Urbit.Time as Time diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index 08043131c..e003900f4 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -4,9 +4,8 @@ module Vere.Http where import ClassyPrelude import Noun -import Noun.Atom -import Noun.Poet -import Noun.Poet.TH +import Atom +import Noun.TH import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index d37d72e6f..e9795d022 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Client.hs @@ -7,8 +7,8 @@ module Vere.Http.Client where import ClassyPrelude import Vere.Http -import Noun.Poet -import Noun.Poet.TH +import Noun +import Noun.TH import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index 0e575db47..d26e7b4e8 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -4,13 +4,13 @@ module Vere.Http.Server where import ClassyPrelude import Vere.Http -import Noun.Atom -import Noun.Poet -import Noun.Poet.TH +import Atom +import Noun +import Noun.TH import Control.Lens import Control.Concurrent (ThreadId, killThread, forkIO) -import Noun.Pill (pill, pillBS, Pill(..)) +import Pill (pill, pillBS, Pill(..)) import qualified Data.ByteString as BS import qualified Network.HTTP.Types as H diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index ec95b665a..78804aa65 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -17,9 +17,9 @@ import ClassyPrelude hiding (init) import Control.Lens hiding ((<|)) import Noun -import Noun.Atom -import Noun.Jam -import Noun.Pill +import Atom +import Jam +import Pill import Noun.Lens import Data.Void import Database.LMDB.Raw @@ -181,7 +181,7 @@ mdbValToAtom (MDB_val sz ptr) = do mdbValToNoun :: MDB_val -> IO Noun mdbValToNoun (MDB_val sz ptr) = do bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) - let res = (bs ^? from pillBS . from pill . _Cue) + let res = bs ^? from pillBS . from pill . _Cue maybeErr res "mdb bad cue" putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO () diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 9daa0b913..a3e750506 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -3,7 +3,7 @@ module Vere.Pier where import ClassyPrelude import Noun -import Noun.Pill +import Pill import Vere.Pier.Types import qualified Vere.Log as Log diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index eb2597422..1c31d4a26 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -3,9 +3,8 @@ module Vere.Pier.Types where import ClassyPrelude import Data.Void import Noun -import Noun.Atom -import Noun.Poet -import Noun.Poet.TH +import Atom +import Noun.TH import Database.LMDB.Raw import Urbit.Time diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index abc4faeda..6b425d6e2 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -5,11 +5,10 @@ import Control.Lens import Data.Void import Noun -import Noun.Atom -import Noun.Jam hiding (jam) -import Noun.Jam.Fast (jam, jamBS) -import Noun.Poet -import Noun.Pill +import Atom +import Jam (jam, jamBS) +import Cue (cue, cueBS) +import Pill import Vere.Pier.Types import System.Process @@ -152,7 +151,7 @@ fromJustExn :: Exception e => Maybe a -> e -> IO a fromJustExn Nothing exn = throwIO exn fromJustExn (Just x) exn = pure x -fromRightExn :: Exception e => Either Text a -> (Text -> e) -> IO a +fromRightExn :: Exception e => Either a b -> (a -> e) -> IO b fromRightExn (Left m) exn = throwIO (exn m) fromRightExn (Right x) _ = pure x @@ -372,9 +371,9 @@ recvPlea w = do a <- recvAtom w traceM ("recvPlea.cue " <> show (length $ a ^. atomBytes)) - n <- fromJustExn (cue a) (BadPleaAtom a) + n <- fromRightExn (cue a) (const $ BadPleaAtom a) traceM "recvPlea.doneCue" - p <- fromRightExn (fromNounErr n) (BadPleaNoun (trace (showNoun n) n)) + p <- fromRightExn (fromNounErr n) (BadPleaNoun $ traceShowId n) traceM "recvPlea.done" diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 448b0e821..19b1b85a3 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -6,6 +6,8 @@ library: source-dirs: lib ghc-options: - -fwarn-incomplete-patterns + - -fwarn-unused-binds + - -fwarn-unused-imports - -O2 dependencies: @@ -79,12 +81,14 @@ default-extensions: - GADTs - GeneralizedNewtypeDeriving - LambdaCase + - MagicHash - MultiParamTypeClasses - NamedFieldPuns - NoImplicitPrelude - NumericUnderscores - OverloadedStrings - PartialTypeSignatures + - PatternSynonyms - QuasiQuotes - Rank2Types - RankNTypes @@ -96,5 +100,6 @@ default-extensions: - TypeApplications - TypeFamilies - TypeOperators + - UnboxedTuples - UnicodeSyntax - ViewPatterns diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index 4341c96f7..537f6e105 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/pkg/hs-vere/app/uterm/Main.hs @@ -2,7 +2,7 @@ module Main where import ClassyPrelude import Control.Lens -import Noun.Pill hiding (main) +import Pill hiding (main) import Noun.Lens -------------------------------------------------------------------------------- diff --git a/stack.yaml b/stack.yaml index 6d0fef18f..7527acff6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,9 +18,6 @@ nix: - SDL2_image - zlib -ghc-options: - urbit: '-fobject-code' - # build: # executable-profiling: true # executable-stripping: false From 31d8e217c235444f81933323f0db34a6e34389d5 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 11 Jul 2019 18:16:40 -0700 Subject: [PATCH 104/431] Massive cleanup. --- pkg/hs-urbit/lib/Atom.hs | 191 -------- pkg/hs-urbit/lib/Noun.hs | 699 +-------------------------- pkg/hs-urbit/lib/Noun/Atom.hs | 202 ++++++++ pkg/hs-urbit/lib/Noun/Conversions.hs | 401 +++++++++++++++ pkg/hs-urbit/lib/Noun/Convert.hs | 189 ++++++++ pkg/hs-urbit/lib/Noun/Core.hs | 115 +++++ pkg/hs-urbit/lib/{ => Noun}/Cue.hs | 16 +- pkg/hs-urbit/lib/{ => Noun}/Jam.hs | 17 +- pkg/hs-urbit/lib/Noun/Lens.hs | 44 -- pkg/hs-urbit/lib/Noun/TH.hs | 5 +- pkg/hs-urbit/lib/Pill.hs | 316 ------------ pkg/hs-urbit/lib/Urbit/Ames.hs | 9 +- pkg/hs-urbit/lib/Vere/Ames.hs | 1 - pkg/hs-urbit/lib/Vere/Http.hs | 1 - pkg/hs-urbit/lib/Vere/Http/Server.hs | 6 +- pkg/hs-urbit/lib/Vere/Log.hs | 12 +- pkg/hs-urbit/lib/Vere/Pier.hs | 4 +- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 1 - pkg/hs-urbit/lib/Vere/Serf.hs | 24 +- pkg/hs-urbit/package.yaml | 1 + pkg/hs-vere/app/uterm/Main.hs | 43 +- 21 files changed, 997 insertions(+), 1300 deletions(-) delete mode 100644 pkg/hs-urbit/lib/Atom.hs create mode 100644 pkg/hs-urbit/lib/Noun/Atom.hs create mode 100644 pkg/hs-urbit/lib/Noun/Conversions.hs create mode 100644 pkg/hs-urbit/lib/Noun/Convert.hs create mode 100644 pkg/hs-urbit/lib/Noun/Core.hs rename pkg/hs-urbit/lib/{ => Noun}/Cue.hs (97%) rename pkg/hs-urbit/lib/{ => Noun}/Jam.hs (95%) delete mode 100644 pkg/hs-urbit/lib/Pill.hs diff --git a/pkg/hs-urbit/lib/Atom.hs b/pkg/hs-urbit/lib/Atom.hs deleted file mode 100644 index c0e8979cb..000000000 --- a/pkg/hs-urbit/lib/Atom.hs +++ /dev/null @@ -1,191 +0,0 @@ -module Atom where - -import ClassyPrelude -import Control.Lens -import Data.Bits -import Data.Flat -import GHC.Int -import GHC.Integer.GMP.Internals -import GHC.Natural -import GHC.Prim -import GHC.Word -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen -import Text.Printf - -import Data.Hashable (Hashable) - --------------------------------------------------------------------------------- - -newtype Atom = MkAtom { unAtom :: Natural } - deriving newtype ( Eq, Ord, Num, Bits, Enum, Real, Integral, Flat, Hashable - , NFData - ) - -instance Show Atom where - show (MkAtom a) = show a - -{- - An Atom with a bit-offset. --} -data Cursor = Cursor - { _cOffset :: {-# UNPACK #-} !Int - , _cBuffer :: !Atom - } - deriving (Eq, Ord, Show) - -data Slice = Slice - { _sOffset :: {-# UNPACK #-} !Int - , _sWidth :: {-# UNPACK #-} !Int - , _sBuffer :: !Atom - } - deriving (Eq, Ord, Show) - -makeLenses ''Cursor -makeLenses ''Slice - - --- Instances ------------------------------------------------------------------- - -instance Arbitrary Natural where - arbitrary = fromInteger . abs <$> arbitrary - -instance Arbitrary Atom where - arbitrary = do - arbitrary >>= \case - False -> MkAtom <$> arbitrary - True -> arbitrary <&> ((`mod` 16) . MkAtom) - --- Conversion ------------------------------------------------------------------ - -class IsAtom a where - toAtom :: a -> Atom - fromAtom :: Atom -> a - -instance IsAtom Atom where - toAtom = id - fromAtom = id - -instance IsAtom Natural where - toAtom = MkAtom - fromAtom (MkAtom a) = a - -instance IsAtom Word8 where - toAtom = fromIntegral - fromAtom = fromIntegral - -instance IsAtom Word16 where - toAtom = fromIntegral - fromAtom = fromIntegral - -instance IsAtom Word32 where - toAtom = fromIntegral - fromAtom = fromIntegral - -instance IsAtom Word64 where - toAtom = fromIntegral - fromAtom = fromIntegral - -instance IsAtom Word where - toAtom = fromIntegral - fromAtom = fromIntegral - -instance IsAtom Int where - toAtom = fromIntegral - fromAtom = fromIntegral - -instance IsAtom Integer where - toAtom = fromIntegral - fromAtom = fromIntegral - - --------------------------------------------------------------------------------- - -{- - TODO Support 32-bit archetectures. --} - -wordBitWidth# :: Word# -> Word# -wordBitWidth# w = minusWord# 64## (clz# w) - -wordBitWidth :: Word -> Word -wordBitWidth (W# w) = W# (wordBitWidth# w) - -bigNatBitWidth# :: BigNat -> Word# -bigNatBitWidth# nat = - lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##) - where - (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1# - lswBits = wordBitWidth# (indexBigNat# nat lastIdx) - -atomBitWidth# :: Atom -> Word# -atomBitWidth# (MkAtom (NatS# gl)) = wordBitWidth# gl -atomBitWidth# (MkAtom (NatJ# bn)) = bigNatBitWidth# bn - -bitWidth :: Num a => Atom -> a -bitWidth a = fromIntegral (W# (atomBitWidth# a)) - --------------------------------------------------------------------------------- - -cursor :: Atom -> Atom -> Cursor -cursor offset buf = Cursor (fromIntegral offset) buf - -fromCursor :: Cursor -> Atom -fromCursor (Cursor off buf) = shiftR buf off - -bumpCursor :: Word -> Cursor -> Cursor -bumpCursor off = over cOffset (+ fromIntegral off) - -instance IsAtom Cursor where - toAtom (Cursor off bits) = shiftR bits off - fromAtom = Cursor 0 - - --------------------------------------------------------------------------------- - -{-# INLINE slice #-} -slice :: (Atom, Atom) -> Atom -> Atom -slice (offset, size) buf = - fromSlice (Slice (fromAtom offset) (fromAtom size) buf) - -{-# INLINE fromSlice #-} -fromSlice :: Slice -> Atom -fromSlice (Slice off wid buf) = takeBits wid (shiftR buf off) - --------------------------------------------------------------------------------- - -{-# INLINE takeBits #-} -takeBits :: Int -> Atom -> Atom -takeBits wid buf = buf .&. (shiftL (MkAtom 1) wid - 1) - -{-# INLINE takeBitsWord #-} -takeBitsWord :: Int -> Word -> Word -takeBitsWord wid wor = wor .&. (shiftL 1 wid - 1) - -{-# INLINE bitIdx #-} -bitIdx :: Int -> Atom -> Bool -bitIdx idx buf = testBit buf idx - -{-# INLINE bitConcat #-} -bitConcat :: Atom -> Atom -> Atom -bitConcat x y = x .|. shiftL y (bitWidth x) - - --- Bit Buffers ----------------------------------------------------------------- - -data Buf = Buf !Int !Atom - -instance Show Buf where - show (Buf sz bits) = "0b" - <> replicate (sz - bitWidth bits) '0' - <> printf "%b (%d bits)" (toInteger bits) sz - -instance Semigroup Buf where - Buf xSz xBuf <> Buf ySz yBuf = Buf (xSz+ySz) (xBuf .|. shiftL yBuf xSz) - -instance Monoid Buf where - mempty = Buf 0 0 - -instance IsAtom Buf where - toAtom (Buf _ bits) = bits - fromAtom bits = Buf (bitWidth bits) bits diff --git a/pkg/hs-urbit/lib/Noun.hs b/pkg/hs-urbit/lib/Noun.hs index c13f36dbf..dda9aa552 100644 --- a/pkg/hs-urbit/lib/Noun.hs +++ b/pkg/hs-urbit/lib/Noun.hs @@ -1,686 +1,29 @@ -{-# OPTIONS_GHC -funbox-strict-fields #-} - module Noun - ( Noun, pattern Cell, pattern Atom, nounSize - , ToNoun(toNoun), FromNoun(parseNoun), fromNoun, fromNounErr - , Cord(..), Knot(..), Term(..), Tank(..), Plum(..) - ) where - -import ClassyPrelude hiding (hash) + ( module Noun.Core + , module Noun.Convert + , module Noun.Conversions + , module Noun.Atom + , module Noun.Jam + , module Noun.Cue + , module Noun.TH + , _Cue + ) where +import ClassyPrelude import Control.Lens -import Control.Applicative -import Control.Monad -import Atom -import Pill -import Data.Void -import Data.Word -import GHC.Natural -import GHC.Generics hiding (from) - -import Data.Bits (xor) -import Data.Hashable (hash) -import Data.Typeable (Typeable) -import GHC.Integer.GMP.Internals (BigNat) -import GHC.Natural (Natural(NatS#, NatJ#)) -import GHC.Prim (reallyUnsafePtrEquality#) -import GHC.Word (Word(W#)) -import Atom (Atom(MkAtom)) -import RIO (decodeUtf8Lenient) -import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary)) -import Test.QuickCheck.Gen (scale, resize, getSize) - -import qualified GHC.Generics as GHC -import qualified Data.Char as C -import qualified Control.Monad.Fail as Fail - - --- Types ----------------------------------------------------------------------- - -data Noun - = NCell !Int !Word !Noun !Noun - | NAtom !Int !Atom - -pattern Cell x y <- NCell _ _ x y where - Cell = mkCell - -pattern Atom a <- NAtom _ a where - Atom = mkAtom - -data CellIdx = L | R - deriving (Eq, Ord, Show) - -type NounPath = [CellIdx] +import Noun.Core +import Noun.Convert +import Noun.Conversions +import Noun.Atom +import Noun.Jam +import Noun.Cue +import Noun.TH -------------------------------------------------------------------------------- -instance Hashable Noun where - hash = \case NCell h _ _ _ -> h - NAtom h _ -> h - {-# INLINE hash #-} - hashWithSalt = defaultHashWithSalt - {-# INLINE hashWithSalt #-} - -instance Eq Noun where - (==) !x !y = - case reallyUnsafePtrEquality# x y of - 1# -> True - _ -> case (x, y) of - (NAtom x1 a1, NAtom x2 a2) -> - x1 == x2 && a1 == a2 - (NCell x1 s1 h1 t1, NCell x2 s2 h2 t2) -> - s1==s2 && x1==x2 && h1==h2 && t1==t2 - _ -> - False - {-# INLINE (==) #-} - -instance Ord Noun where - compare !x !y = - case reallyUnsafePtrEquality# x y of - 1# -> EQ - _ -> case (x, y) of - (Atom _, Cell _ _) -> LT - (Cell _ _, Atom _) -> GT - (Atom a1, Atom a2) -> compare a1 a2 - (Cell h1 t1, Cell h2 t2) -> compare h1 h2 <> compare t1 t2 - {-# INLINE compare #-} - - -instance Show Noun where - show = \case Atom a -> showAtom a - Cell x y -> fmtCell (show <$> (x : toTuple y)) - where - fmtCell :: [String] -> String - fmtCell xs = "[" <> intercalate " " xs <> "]" - - toTuple :: Noun -> [Noun] - toTuple (Cell x xs) = x : toTuple xs - toTuple atom = [atom] - - showAtom :: Atom -> String - showAtom 0 = "0" - showAtom a = - let mTerm = do - t <- fromNoun (Atom a) - let ok = \x -> (x=='-' || C.isAlphaNum x) - guard (all ok (t :: Text)) - pure ("%" <> unpack t) - - in case mTerm of - Nothing -> show a - Just st -> st - -instance Arbitrary Noun where - arbitrary = resize 1000 go - where - dub x = Cell x x - go = do - sz <- getSize - (bit, bat :: Bool) <- arbitrary - case (sz, bit, bat) of - ( 0, _, _ ) -> Atom <$> arbitrary - ( _, False, _ ) -> Atom <$> arbitrary - ( _, True, True ) -> dub <$> arbitrary - ( _, True, _ ) -> scale (\x -> x-10) (Cell <$> go <*> go) - - --------------------------------------------------------------------------------- - -{-# INLINE nounSize #-} -nounSize :: Noun -> Word -nounSize = \case - NCell _ s _ _ -> s - NAtom _ _ -> 1 - -{-# INLINE mkAtom #-} -mkAtom :: Atom -> Noun -mkAtom !a = NAtom (hash a) a - -{-# INLINE mkCell #-} -mkCell :: Noun -> Noun -> Noun -mkCell !h !t = NCell has siz h t +_Cue :: Prism' ByteString Noun +_Cue = prism' jamBS (eitherToMaybe . cueBS) where - !siz = nounSize h + nounSize t - !has = hash h `combine` hash t - - --- Stolen from Hashable Library ------------------------------------------------ - -{-# INLINE combine #-} -combine :: Int -> Int -> Int -combine !h1 !h2 = (h1 * 16777619) `xor` h2 - -{-# INLINE defaultHashWithSalt #-} -defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt !salt !x = salt `combine` hash x - - --- Types For Hoon Constructs --------------------------------------------------- - -{-| - `Nullable a <-> ?@(~ a)` - - This is distinct from `unit`, since there is no tag on the non-atom - case, therefore `a` must always be cell type. --} -data Nullable a = Nil | NotNil a - deriving (Eq, Ord, Show) - -newtype Tour = Tour [Char] - deriving (Eq, Ord, Show) - -newtype Tape = Tape ByteString - deriving newtype (Eq, Ord, Show, IsString) - -newtype Cord = Cord { unCord :: ByteString } - deriving newtype (Eq, Ord, Show, IsString, NFData) - - --- Chars ----------------------------------------------------------------------- - -instance ToNoun Char where - toNoun = toNoun . (fromIntegral :: Int -> Word32) . C.ord - -instance FromNoun Char where - parseNoun n = do - w :: Word32 <- parseNoun n - pure $ C.chr $ fromIntegral w - - --- Pretty Printing ------------------------------------------------------------- - -type Tang = [Tank] - -data Tank - = TLeaf Tape - | TPlum Plum - | TPalm (Tape, Tape, Tape, Tape) [Tank] - | TRose (Tape, Tape, Tape) [Tank] - deriving (Eq, Ord, Show) - -type Tile = Cord - -data WideFmt - = WideFmt { delimit :: Tile, enclose :: Maybe (Tile, Tile) } - deriving (Eq, Ord, Show) - -data TallFmt - = TallFmt { intro :: Tile, indef :: Maybe (Tile, Tile) } - deriving (Eq, Ord, Show) - -data PlumFmt - = PlumFmt (Maybe WideFmt) (Maybe TallFmt) - deriving (Eq, Ord, Show) - -data Plum - = PAtom Cord - | PPara Tile [Cord] - | PTree PlumFmt [Plum] - | PSbrk Plum - deriving (Eq, Ord, Show) - - --- IResult --------------------------------------------------------------------- - -data IResult a = IError NounPath String | ISuccess a - deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) - -instance Applicative IResult where - pure = ISuccess - (<*>) = ap - -instance Fail.MonadFail IResult where - fail err = traceM ("!" <> err <> "!") >> IError [] err - -instance Monad IResult where - return = pure - fail = Fail.fail - ISuccess a >>= k = k a - IError path err >>= _ = IError path err - -instance MonadPlus IResult where - mzero = fail "mzero" - mplus a@(ISuccess _) _ = a - mplus _ b = b - -instance Alternative IResult where - empty = mzero - (<|>) = mplus - -instance Semigroup (IResult a) where - (<>) = mplus - -instance Monoid (IResult a) where - mempty = fail "mempty" - mappend = (<>) - - --- Result ---------------------------------------------------------------------- - -data Result a = Error String | Success a - deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) - -instance Applicative Result where - pure = Success - (<*>) = ap - -instance Fail.MonadFail Result where - fail err = Error err - -instance Monad Result where - return = pure - fail = Fail.fail - - Success a >>= k = k a - Error err >>= _ = Error err - -instance MonadPlus Result where - mzero = fail "mzero" - mplus a@(Success _) _ = a - mplus _ b = b - -instance Alternative Result where - empty = mzero - (<|>) = mplus - -instance Semigroup (Result a) where - (<>) = mplus - {-# INLINE (<>) #-} - -instance Monoid (Result a) where - mempty = fail "mempty" - mappend = (<>) - - --- "Parser" -------------------------------------------------------------------- - -type Failure f r = NounPath -> String -> f r -type Success a f r = a -> f r - -newtype Parser a = Parser { - runParser :: forall f r. NounPath -> Failure f r -> Success a f r -> f r -} - -instance Monad Parser where - m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks - in runParser m path kf ks' - return = pure - fail = Fail.fail - -instance Fail.MonadFail Parser where - fail msg = Parser $ \path kf _ks -> kf (reverse path) msg - -instance Functor Parser where - fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a) - in runParser m path kf ks' - -apP :: Parser (a -> b) -> Parser a -> Parser b -apP d e = do - b <- d - b <$> e - -instance Applicative Parser where - pure a = Parser $ \_path _kf ks -> ks a - (<*>) = apP - -instance Alternative Parser where - empty = fail "empty" - (<|>) = mplus - -instance MonadPlus Parser where - mzero = fail "mzero" - mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks - in runParser a path kf' ks - -instance Semigroup (Parser a) where - (<>) = mplus - -instance Monoid (Parser a) where - mempty = fail "mempty" - mappend = (<>) - - --- Conversion ------------------------------------------------------------------ - -class FromNoun a where - parseNoun :: Noun -> Parser a - -class ToNoun a where - toNoun :: a -> Noun - --------------------------------------------------------------------------------- - -int2Word :: Int -> Word -int2Word = fromIntegral - -word2Int :: Word -> Int -word2Int = fromIntegral - -instance ToNoun ByteString where - toNoun bs = toNoun (int2Word (length bs), bs ^. from (pill . pillBS)) - -instance ToNoun Text where -- XX TODO - toNoun t = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Text where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (decodeUtf8Lenient c) - -instance FromNoun ByteString where - parseNoun x = do - (word2Int -> len, atom) <- parseNoun x - let bs = atom ^. pill . pillBS - pure $ case compare (length bs) len of - EQ -> bs - LT -> bs <> replicate (len - length bs) 0 - GT -> take len bs - --------------------------------------------------------------------------------- - -newtype Term = MkTerm Text - deriving newtype (Eq, Ord, Show) - -instance ToNoun Term where -- XX TODO - toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Term where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (MkTerm (decodeUtf8Lenient c)) - --------------------------------------------------------------------------------- - -newtype Knot = MkKnot Text - deriving newtype (Eq, Ord, Show) - -instance ToNoun Knot where -- XX TODO - toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t)) - -instance FromNoun Knot where -- XX TODO - parseNoun n = do - Cord c <- parseNoun n - pure (MkKnot (decodeUtf8Lenient c)) - --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- - -fromNoun :: FromNoun a => Noun -> Maybe a -fromNoun n = runParser (parseNoun n) [] onFail onSuccess - where - onFail p m = Nothing - onSuccess x = Just x - -fromNounErr :: FromNoun a => Noun -> Either Text a -fromNounErr n = runParser (parseNoun n) [] onFail onSuccess - where - onFail p m = Left (pack m) - onSuccess x = Right x - -_Poet :: (ToNoun a, FromNoun a) => Prism' Noun a -_Poet = prism' toNoun fromNoun - - --- Trivial Conversion ---------------------------------------------------------- - -instance ToNoun Void where - toNoun = absurd - -instance FromNoun Void where - parseNoun = fail "Can't produce void" - -instance ToNoun Noun where - toNoun = id - -instance FromNoun Noun where - parseNoun = pure - - --- Loobean Conversion ---------------------------------------------------------- - -instance ToNoun Bool where - toNoun True = Atom 0 - toNoun False = Atom 1 - -instance FromNoun Bool where - parseNoun (Atom 0) = pure True - parseNoun (Atom 1) = pure False - parseNoun (Cell _ _) = fail "expecting a bool, but got a cell" - parseNoun (Atom a) = fail ("expecting a bool, but got " <> show a) - - --- Atom Conversion ------------------------------------------------------------- - -instance ToNoun Atom where - toNoun = Atom - -instance FromNoun Atom where - parseNoun (Cell _ _) = fail "Expecting an atom, but got a cell" - parseNoun (Atom a) = pure a - - --- Natural Conversion----------------------------------------------------------- - -instance ToNoun Natural where toNoun = toNoun . MkAtom -instance FromNoun Natural where parseNoun = fmap unAtom . parseNoun - -instance ToNoun Integer where - toNoun = toNoun . (fromIntegral :: Integer -> Natural) - -instance FromNoun Integer where - parseNoun = fmap ((fromIntegral :: Natural -> Integer) . unAtom) . parseNoun - - --- Word Conversion ------------------------------------------------------------- - -atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a -atomToWord atom = do - if atom > fromIntegral (maxBound :: a) - then fail "Atom doesn't fit in fixed-size word" - else pure (fromIntegral atom) - -wordToNoun :: Integral a => a -> Noun -wordToNoun = Atom . fromIntegral - -nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a -nounToWord = parseNoun >=> atomToWord - -instance ToNoun Word where toNoun = wordToNoun -instance ToNoun Word8 where toNoun = wordToNoun -instance ToNoun Word16 where toNoun = wordToNoun -instance ToNoun Word32 where toNoun = wordToNoun -instance ToNoun Word64 where toNoun = wordToNoun - -instance FromNoun Word where parseNoun = nounToWord -instance FromNoun Word8 where parseNoun = nounToWord -instance FromNoun Word16 where parseNoun = nounToWord -instance FromNoun Word32 where parseNoun = nounToWord -instance FromNoun Word64 where parseNoun = nounToWord - - --- Nullable Conversion --------------------------------------------------------- - --- TODO Consider enforcing that `a` must be a cell. -instance ToNoun a => ToNoun (Nullable a) where - toNoun Nil = Atom 0 - toNoun (NotNil x) = toNoun x - -instance FromNoun a => FromNoun (Nullable a) where - parseNoun (Atom 0) = pure Nil - parseNoun (Atom n) = fail ("Nullable: expected ?@(~ ^), but got " <> show n) - parseNoun n = NotNil <$> parseNoun n - - --- Maybe is `unit` ------------------------------------------------------------- - --- TODO Consider enforcing that `a` must be a cell. -instance ToNoun a => ToNoun (Maybe a) where - toNoun Nothing = Atom 0 - toNoun (Just x) = Cell (Atom 0) (toNoun x) - -instance FromNoun a => FromNoun (Maybe a) where - parseNoun = \case - Atom 0 -> pure Nothing - Atom n -> unexpected ("atom " <> show n) - Cell (Atom 0) t -> Just <$> parseNoun t - Cell n _ -> unexpected ("cell with head-atom " <> show n) - where - unexpected s = fail ("Expected unit value, but got " <> s) - - --- List Conversion ------------------------------------------------------------- - -instance ToNoun a => ToNoun [a] where - toNoun xs = nounFromList (toNoun <$> xs) - where - nounFromList :: [Noun] -> Noun - nounFromList [] = Atom 0 - nounFromList (x:xs) = Cell x (nounFromList xs) - -instance FromNoun a => FromNoun [a] where - parseNoun (Atom 0) = pure [] - parseNoun (Atom _) = fail "list terminated with non-null atom" - parseNoun (Cell l r) = (:) <$> parseNoun l <*> parseNoun r - - --- Cord Conversion ------------------------------------------------------------- - -instance ToNoun Cord where - toNoun (Cord bs) = Atom (bs ^. from (pill . pillBS)) - -instance FromNoun Cord where - parseNoun n = do - atom <- parseNoun n - pure $ Cord (atom ^. pill . pillBS) - - --- Tank and Plum Conversion ---------------------------------------------------- - -instance ToNoun WideFmt where toNoun (WideFmt x xs) = toNoun (x, xs) -instance ToNoun TallFmt where toNoun (TallFmt x xs) = toNoun (x, xs) -instance ToNoun PlumFmt where toNoun (PlumFmt wide tall) = toNoun (wide, tall) - -instance FromNoun WideFmt where parseNoun = fmap (uncurry WideFmt) . parseNoun -instance FromNoun TallFmt where parseNoun = fmap (uncurry TallFmt) . parseNoun -instance FromNoun PlumFmt where parseNoun = fmap (uncurry PlumFmt) . parseNoun - -instance ToNoun Plum where - toNoun = \case - PAtom cord -> toNoun cord - PPara t cs -> toNoun (Cord "para", t, cs) - PTree f ps -> toNoun (Cord "tree", f, ps) - PSbrk p -> toNoun (Cord "sbrk", p) - -instance FromNoun Plum where - parseNoun = undefined - -instance ToNoun Tank where - toNoun = pure (Atom 0) - -instance FromNoun Tank where - parseNoun _ = pure (TLeaf (Tape "TODO: Tank Parsing")) - - --- Tuple Conversions ----------------------------------------------------------- - -instance ToNoun () where - toNoun () = Atom 0 - -instance FromNoun () where - parseNoun (Atom 0) = pure () - parseNoun x = fail ("expecting `~`, but got " <> show x) - -instance (ToNoun a, ToNoun b) => ToNoun (a, b) where - toNoun (x, y) = Cell (toNoun x) (toNoun y) - -instance (FromNoun a, FromNoun b) => FromNoun (a, b) where - parseNoun (Atom n) = fail ("expected a cell, but got an atom: " <> show n) - parseNoun (Cell l r) = (,) <$> parseNoun l <*> parseNoun r - -instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where - toNoun (x, y, z) = toNoun (x, (y, z)) - -instance (FromNoun a, FromNoun b, FromNoun c) => FromNoun (a, b, c) where - parseNoun n = do - (x, t) <- parseNoun n - (y, z) <- parseNoun t - pure (x, y, z) - -instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where - toNoun (p, q, r, s) = toNoun (p, (q, r, s)) - -instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d) - => FromNoun (a, b, c, d) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s) <- parseNoun tail - pure (p, q, r, s) - -instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e) - => ToNoun (a, b, c, d, e) where - toNoun (p, q, r, s, t) = toNoun (p, (q, r, s, t)) - -instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e) - => FromNoun (a, b, c, d, e) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t) <- parseNoun tail - pure (p, q, r, s, t) - -instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f) - => ToNoun (a, b, c, d, e, f) where - toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u)) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f - ) - => FromNoun (a, b, c, d, e, f) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u) <- parseNoun tail - pure (p, q, r, s, t, u) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f, FromNoun g - ) - => FromNoun (a, b, c, d, e, f, g) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u, v) <- parseNoun tail - pure (p, q, r, s, t, u, v) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f, FromNoun g, FromNoun h - ) - => FromNoun (a, b, c, d, e, f, g, h) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u, v, w) <- parseNoun tail - pure (p, q, r, s, t, u, v, w) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f, FromNoun g, FromNoun h, FromNoun i - ) - => FromNoun (a, b, c, d, e, f, g, h, i) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u, v, w, x) <- parseNoun tail - pure (p, q, r, s, t, u, v, w, x) - -instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e - , FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j - ) - => FromNoun (a, b, c, d, e, f, g, h, i, j) - where - parseNoun n = do - (p, tail) <- parseNoun n - (q, r, s, t, u, v, w, x, y) <- parseNoun tail - pure (p, q, r, s, t, u, v, w, x, y) + eitherToMaybe (Left _) = Nothing + eitherToMaybe (Right x) = Just x diff --git a/pkg/hs-urbit/lib/Noun/Atom.hs b/pkg/hs-urbit/lib/Noun/Atom.hs new file mode 100644 index 000000000..88dd6807d --- /dev/null +++ b/pkg/hs-urbit/lib/Noun/Atom.hs @@ -0,0 +1,202 @@ +{- + TODO Support 32-bit archetectures. + TODO Support Big Endian. +-} + +{-# OPTIONS_GHC -Werror #-} + +module Noun.Atom + ( Atom(..) + , atomBitWidth#, wordBitWidth#, wordBitWidth + , takeBitsWord, bitWidth + , atomBytes, bigNatWords, atomWords + ) where + +import ClassyPrelude +import Control.Lens hiding (Index) + +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import GHC.Exts (sizeofByteArray#) +import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#) +import GHC.Integer.GMP.Internals (indexBigNat#) +import GHC.Integer.GMP.Internals (wordToBigNat, byteArrayToBigNat#, zeroBigNat) +import GHC.Int (Int(..)) +import GHC.Natural (Natural(..)) +import GHC.Prim (plusWord#, clz#, minusWord#) +import GHC.Prim (Word#, subIntC#, timesWord#, int2Word#) +import GHC.Word (Word(..)) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.Primitive.Types as Prim +import qualified Data.Primitive.ByteArray as Prim +import qualified Data.Vector.Primitive as VP +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BU + + +-- Types ----------------------------------------------------------------------- + +type Atom = Natural + + +-------------------------------------------------------------------------------- + +wordBitWidth# :: Word# -> Word# +wordBitWidth# w = minusWord# 64## (clz# w) + +wordBitWidth :: Word -> Word +wordBitWidth (W# w) = W# (wordBitWidth# w) + +bigNatBitWidth# :: BigNat -> Word# +bigNatBitWidth# nat = + lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##) + where + (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1# + lswBits = wordBitWidth# (indexBigNat# nat lastIdx) + +atomBitWidth# :: Atom -> Word# +atomBitWidth# (NatS# gl) = wordBitWidth# gl +atomBitWidth# (NatJ# bn) = bigNatBitWidth# bn + +bitWidth :: Num a => Atom -> a +bitWidth a = fromIntegral (W# (atomBitWidth# a)) + +-------------------------------------------------------------------------------- + +{-# INLINE takeBitsWord #-} +takeBitsWord :: Int -> Word -> Word +takeBitsWord wid wor = wor .&. (shiftL 1 wid - 1) + + +-------------------------------------------------------------------------------- + +{- + A `Pill` is a bytestring without trailing zeros. +-} +newtype Pill = Pill { unPill :: ByteString } + +instance Eq Pill where + (==) x y = (x ^. pillBS) == (y ^. pillBS) + +instance Show Pill where + show = show . view pillBS + +-------------------------------------------------------------------------------- + +strip :: (IsSequence seq, Int ~ Index seq, Eq (Element seq), Num (Element seq)) + => seq -> seq +strip buf = take (len - go 0 (len - 1)) buf + where + len = length buf + go n i | i < 0 = n + | 0 == unsafeIndex buf i = go (n+1) (i-1) + | otherwise = n + +pillBS :: Iso' Pill ByteString +pillBS = iso to from + where + to :: Pill -> ByteString + to = strip . unPill + + from :: ByteString -> Pill + from = Pill . strip + + +-------------------------------------------------------------------------------- + +bigNatWords :: Iso' BigNat (VP.Vector Word) +bigNatWords = iso to from + where + to (BN# bArr) = VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8) + (Prim.ByteArray bArr) + + from v@(VP.Vector off (I# len) (Prim.ByteArray buf)) = + case VP.length v of + 0 -> zeroBigNat + 1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w) + n -> if off /= 0 then error "words2Nat: bad-vec" else + byteArrayToBigNat# buf len + +-------------------------------------------------------------------------------- + +natWords :: Iso' Natural (VP.Vector Word) +natWords = naturalBigNat . bigNatWords + +naturalBigNat :: Iso' Natural BigNat +naturalBigNat = iso to from + where + to = \case NatS# w -> wordToBigNat w + NatJ# bn -> bn + + from bn = case sizeofBigNat# bn of 0# -> 0 + 1# -> NatS# (bigNatToWord bn) + _ -> NatJ# bn + +-------------------------------------------------------------------------------- + +-- TODO This assumes 64-bit words +packedWord :: Iso' ByteString Word +packedWord = iso to from + where + from wor = reverse $ fromList $ go 0 [] + where + go i acc | i >= 8 = acc + go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc) + + to buf = go 0 0 + where + top = min 8 (length buf) + i idx off = shiftL (fromIntegral $ BS.index buf idx) off + go acc idx = if idx >= top then acc else + go (acc .|. i idx (8*idx)) (idx+1) + +-------------------------------------------------------------------------------- + +wordsToBytes :: VP.Vector Word -> VP.Vector Word8 +wordsToBytes (VP.Vector off sz buf) = + VP.Vector (off*8) (sz*8) buf + +bsToWords :: ByteString -> VP.Vector Word +bsToWords bs = + VP.generate (1 + length bs `div` 8) $ \i -> + view packedWord (BS.drop (i*8) bs) + +{- + TODO Support Big-Endian + TODO This still has a (small) risk of segfaulting. The right thing to + do is to manually copy the data to the C heap, setup the + finalizers, and then manually construct a bytestring from + that pointer. -- finalizers, and make a bytestring from that. +-} +bytesBS :: Iso' (VP.Vector Word8) ByteString +bytesBS = iso to from + where + to :: VP.Vector Word8 -> ByteString + to (VP.Vector off sz buf) = + unsafePerformIO $ do + Prim.Addr ptr <- evaluate $ Prim.byteArrayContents buf + bs <- BU.unsafePackAddressLen sz ptr + evaluate $ force $ BS.copy $ BS.drop off bs + + from :: ByteString -> VP.Vector Word8 + from bs = VP.generate (length bs) (BS.index bs) + +pillWords :: Iso' Pill (VP.Vector Word) +pillWords = iso toVec fromVec + where + toVec = view (pillBS . to bsToWords) + fromVec = view (to wordsToBytes . bytesBS . from pillBS) + +-------------------------------------------------------------------------------- + +atomWords :: Iso' Atom (VP.Vector Word) +atomWords = natWords + +pill :: Iso' Atom Pill +pill = iso toAtom fromPill + where + toAtom = view (natWords . from pillWords) + fromPill = view (pillBS . to bsToWords . from natWords) + +atomBytes :: Iso' Atom ByteString +atomBytes = pill . pillBS diff --git a/pkg/hs-urbit/lib/Noun/Conversions.hs b/pkg/hs-urbit/lib/Noun/Conversions.hs new file mode 100644 index 000000000..06c8fb404 --- /dev/null +++ b/pkg/hs-urbit/lib/Noun/Conversions.hs @@ -0,0 +1,401 @@ +module Noun.Conversions + ( Cord(..), Knot(..), Term(..), Tank(..), Tang, Plum(..) + ) where + +import ClassyPrelude hiding (hash) + +import Control.Lens +import Data.Void +import Data.Word +import Noun.Atom +import Noun.Convert +import Noun.Core +import Noun.TH + +import GHC.Natural (Natural) +import RIO (decodeUtf8Lenient) + +import qualified Data.Char as C + + +-- TODO XX Hack! --------------------------------------------------------------- + +instance Show Noun where + show = \case Atom a -> showAtom a + Cell x y -> fmtCell (show <$> (x : toTuple y)) + where + fmtCell :: [String] -> String + fmtCell xs = "[" <> intercalate " " xs <> "]" + + toTuple :: Noun -> [Noun] + toTuple (Cell x xs) = x : toTuple xs + toTuple atom = [atom] + + showAtom :: Atom -> String + showAtom 0 = "0" + showAtom a = + let mTerm = do + t <- fromNoun (Atom a) + let ok = \x -> (x=='-' || C.isAlphaNum x) + guard (all ok (t :: Text)) + pure ("%" <> unpack t) + + in case mTerm of + Nothing -> show a + Just st -> st + + +-- Noun ------------------------------------------------------------------------ + +instance ToNoun Noun where + toNoun = id + +instance FromNoun Noun where + parseNoun = pure + + +-- Void ------------------------------------------------------------------------ + +instance ToNoun Void where + toNoun = absurd + +instance FromNoun Void where + parseNoun = fail "Can't produce void" + + +-- Tour ------------------------------------------------------------------------ + +newtype Tour = Tour [Char] + deriving (Eq, Ord, Show) + + +-- Atom or Cell ---------------------------------------------------------------- + +data AtomCell a c + = ACAtom a + | ACCell c + deriving (Eq, Ord, Show) + +instance (ToNoun a, ToNoun c) => ToNoun (AtomCell a c) where + toNoun (ACAtom a) = toNoun a + toNoun (ACCell c) = toNoun c + +instance (FromNoun a, FromNoun c) => FromNoun (AtomCell a c) where + parseNoun n = case n of + Atom _ -> ACAtom <$> parseNoun n + Cell _ _ -> ACCell <$> parseNoun n + + +-- Nullable -------------------------------------------------------------------- + +{-| + `Nullable a <-> ?@(~ a)` + + This is distinct from `unit`, since there is no tag on the non-atom + case, therefore `a` must always be cell type. +-} +type Nullable a = AtomCell () a + + +-- Char ------------------------------------------------------------------------ + +instance ToNoun Char where + toNoun = toNoun . (fromIntegral :: Int -> Word32) . C.ord + +instance FromNoun Char where + parseNoun n = do + w :: Word32 <- parseNoun n + pure $ C.chr $ fromIntegral w + + +-- List ------------------------------------------------------------------------ + +instance ToNoun a => ToNoun [a] where + toNoun xs = nounFromList (toNoun <$> xs) + where + nounFromList :: [Noun] -> Noun + nounFromList [] = Atom 0 + nounFromList (x:xs) = Cell x (nounFromList xs) + +instance FromNoun a => FromNoun [a] where + parseNoun (Atom 0) = pure [] + parseNoun (Atom _) = fail "list terminated with non-null atom" + parseNoun (Cell l r) = (:) <$> parseNoun l <*> parseNoun r + + +-- Tape ------------------------------------------------------------------------ + +newtype Tape = Tape [Char] + deriving newtype (Eq, Ord, Show) + +instance FromNoun Tape where + parseNoun = undefined + +instance ToNoun Tape where + toNoun = undefined + + +-- Pretty Printing ------------------------------------------------------------- + +type Tang = [Tank] + +type Tank = AtomCell Tape TankTree + +data TankTree + = Plum Plum + | Palm (Tape, Tape, Tape, Tape) [Tank] + | Rose (Tape, Tape, Tape) [Tank] + deriving (Eq, Ord, Show) + +data WideFmt = WideFmt { delimit :: Cord, enclose :: Maybe (Cord, Cord) } + deriving (Eq, Ord, Show) + +data TallFmt = TallFmt { intro :: Cord, indef :: Maybe (Cord, Cord) } + deriving (Eq, Ord, Show) + +data PlumFmt = PlumFmt (Maybe WideFmt) (Maybe TallFmt) + deriving (Eq, Ord, Show) + +type Plum = AtomCell Cord PlumTree + +data PlumTree + = Para Cord [Cord] + | Tree PlumFmt [Plum] + | Sbrk Plum + deriving (Eq, Ord, Show) + +deriveNoun ''WideFmt +deriveNoun ''TallFmt +deriveNoun ''PlumFmt +deriveNoun ''TankTree +deriveNoun ''PlumTree + + +-- ByteString ------------------------------------------------------------------ + +instance ToNoun ByteString where + toNoun bs = toNoun (int2Word (length bs), bs ^. from atomBytes) + where + int2Word :: Int -> Word + int2Word = fromIntegral + +instance FromNoun ByteString where + parseNoun x = do + (word2Int -> len, atom) <- parseNoun x + let bs = atom ^. atomBytes + pure $ case compare (length bs) len of + EQ -> bs + LT -> bs <> replicate (len - length bs) 0 + GT -> take len bs + where + word2Int :: Word -> Int + word2Int = fromIntegral + + +-- Text ------------------------------------------------------------------------ + +instance ToNoun Text where -- XX TODO + toNoun t = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Text where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (decodeUtf8Lenient c) + + +-- Term ------------------------------------------------------------------------ + +newtype Term = MkTerm Text + deriving newtype (Eq, Ord, Show) + +instance ToNoun Term where -- XX TODO + toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Term where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (MkTerm (decodeUtf8Lenient c)) + + +-- Knot ------------------------------------------------------------------------ + +newtype Knot = MkKnot Text + deriving newtype (Eq, Ord, Show) + +instance ToNoun Knot where -- XX TODO + toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t)) + +instance FromNoun Knot where -- XX TODO + parseNoun n = do + Cord c <- parseNoun n + pure (MkKnot (decodeUtf8Lenient c)) + + +-- Bool ------------------------------------------------------------------------ + +instance ToNoun Bool where + toNoun True = Atom 0 + toNoun False = Atom 1 + +instance FromNoun Bool where + parseNoun (Atom 0) = pure True + parseNoun (Atom 1) = pure False + parseNoun (Cell _ _) = fail "expecting a bool, but got a cell" + parseNoun (Atom a) = fail ("expecting a bool, but got " <> show a) + + +-- Integer --------------------------------------------------------------------- + +instance ToNoun Integer where + toNoun = toNoun . (fromIntegral :: Integer -> Natural) + +instance FromNoun Integer where + parseNoun = fmap (fromIntegral :: Natural -> Integer) . parseNoun + + +-- Words ----------------------------------------------------------------------- + +atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a +atomToWord atom = do + if atom > fromIntegral (maxBound :: a) + then fail "Atom doesn't fit in fixed-size word" + else pure (fromIntegral atom) + +wordToNoun :: Integral a => a -> Noun +wordToNoun = Atom . fromIntegral + +nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a +nounToWord = parseNoun >=> atomToWord + +instance ToNoun Word where toNoun = wordToNoun +instance ToNoun Word8 where toNoun = wordToNoun +instance ToNoun Word16 where toNoun = wordToNoun +instance ToNoun Word32 where toNoun = wordToNoun +instance ToNoun Word64 where toNoun = wordToNoun + +instance FromNoun Word where parseNoun = nounToWord +instance FromNoun Word8 where parseNoun = nounToWord +instance FromNoun Word16 where parseNoun = nounToWord +instance FromNoun Word32 where parseNoun = nounToWord +instance FromNoun Word64 where parseNoun = nounToWord + + +-- Maybe is `unit` ------------------------------------------------------------- + +-- TODO Consider enforcing that `a` must be a cell. +instance ToNoun a => ToNoun (Maybe a) where + toNoun Nothing = Atom 0 + toNoun (Just x) = Cell (Atom 0) (toNoun x) + +instance FromNoun a => FromNoun (Maybe a) where + parseNoun = \case + Atom 0 -> pure Nothing + Atom n -> unexpected ("atom " <> show n) + Cell (Atom 0) t -> Just <$> parseNoun t + Cell n _ -> unexpected ("cell with head-atom " <> show n) + where + unexpected s = fail ("Expected unit value, but got " <> s) + + +-- Tuple Conversions ----------------------------------------------------------- + +instance ToNoun () where + toNoun () = Atom 0 + +instance FromNoun () where + parseNoun (Atom 0) = pure () + parseNoun x = fail ("expecting `~`, but got " <> show x) + +instance (ToNoun a, ToNoun b) => ToNoun (a, b) where + toNoun (x, y) = Cell (toNoun x) (toNoun y) + +instance (FromNoun a, FromNoun b) => FromNoun (a, b) where + parseNoun (Atom n) = fail ("expected a cell, but got an atom: " <> show n) + parseNoun (Cell l r) = (,) <$> parseNoun l <*> parseNoun r + + +instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where + toNoun (x, y, z) = toNoun (x, (y, z)) + +instance (FromNoun a, FromNoun b, FromNoun c) => FromNoun (a, b, c) where + parseNoun n = do + (x, t) <- parseNoun n + (y, z) <- parseNoun t + pure (x, y, z) + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where + toNoun (p, q, r, s) = toNoun (p, (q, r, s)) + +instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d) + => FromNoun (a, b, c, d) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s) <- parseNoun tail + pure (p, q, r, s) + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e) + => ToNoun (a, b, c, d, e) where + toNoun (p, q, r, s, t) = toNoun (p, (q, r, s, t)) + +instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e) + => FromNoun (a, b, c, d, e) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t) <- parseNoun tail + pure (p, q, r, s, t) + +instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f) + => ToNoun (a, b, c, d, e, f) where + toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u)) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f + ) + => FromNoun (a, b, c, d, e, f) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u) <- parseNoun tail + pure (p, q, r, s, t, u) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g + ) + => FromNoun (a, b, c, d, e, f, g) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v) <- parseNoun tail + pure (p, q, r, s, t, u, v) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h + ) + => FromNoun (a, b, c, d, e, f, g, h) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w) <- parseNoun tail + pure (p, q, r, s, t, u, v, w) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h, FromNoun i + ) + => FromNoun (a, b, c, d, e, f, g, h, i) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w, x) <- parseNoun tail + pure (p, q, r, s, t, u, v, w, x) + +instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e + , FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j + ) + => FromNoun (a, b, c, d, e, f, g, h, i, j) + where + parseNoun n = do + (p, tail) <- parseNoun n + (q, r, s, t, u, v, w, x, y) <- parseNoun tail + pure (p, q, r, s, t, u, v, w, x, y) diff --git a/pkg/hs-urbit/lib/Noun/Convert.hs b/pkg/hs-urbit/lib/Noun/Convert.hs new file mode 100644 index 000000000..961448e74 --- /dev/null +++ b/pkg/hs-urbit/lib/Noun/Convert.hs @@ -0,0 +1,189 @@ +module Noun.Convert + ( ToNoun(toNoun) + , FromNoun(parseNoun), fromNoun, fromNounErr + , Parser(..) + , CellIdx, NounPath + , Cord(..) + ) where + +import ClassyPrelude hiding (hash) +import Noun.Core +import Noun.Atom +import Control.Lens + +import qualified Control.Monad.Fail as Fail + + +-- Types ----------------------------------------------------------------------- + +data CellIdx = L | R + deriving (Eq, Ord, Show) + +type NounPath = [CellIdx] + + +-- IResult --------------------------------------------------------------------- + +data IResult a = IError NounPath String | ISuccess a + deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) + +instance Applicative IResult where + pure = ISuccess + (<*>) = ap + +instance Fail.MonadFail IResult where + fail err = IError [] err + +instance Monad IResult where + return = pure + fail = Fail.fail + ISuccess a >>= k = k a + IError path err >>= _ = IError path err + +instance MonadPlus IResult where + mzero = fail "mzero" + mplus a@(ISuccess _) _ = a + mplus _ b = b + +instance Alternative IResult where + empty = mzero + (<|>) = mplus + +instance Semigroup (IResult a) where + (<>) = mplus + +instance Monoid (IResult a) where + mempty = fail "mempty" + mappend = (<>) + + +-- Result ---------------------------------------------------------------------- + +data Result a = Error String | Success a + deriving (Eq, Show, Typeable, Functor, Foldable, Traversable) + +instance Applicative Result where + pure = Success + (<*>) = ap + +instance Fail.MonadFail Result where + fail err = Error err + +instance Monad Result where + return = pure + fail = Fail.fail + + Success a >>= k = k a + Error err >>= _ = Error err + +instance MonadPlus Result where + mzero = fail "mzero" + mplus a@(Success _) _ = a + mplus _ b = b + +instance Alternative Result where + empty = mzero + (<|>) = mplus + +instance Semigroup (Result a) where + (<>) = mplus + {-# INLINE (<>) #-} + +instance Monoid (Result a) where + mempty = fail "mempty" + mappend = (<>) + + +-- "Parser" -------------------------------------------------------------------- + +type Failure f r = NounPath -> String -> f r +type Success a f r = a -> f r + +newtype Parser a = Parser { + runParser :: forall f r. NounPath -> Failure f r -> Success a f r -> f r +} + +instance Monad Parser where + m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks + in runParser m path kf ks' + return = pure + fail = Fail.fail + +instance Fail.MonadFail Parser where + fail msg = Parser $ \path kf _ks -> kf (reverse path) msg + +instance Functor Parser where + fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a) + in runParser m path kf ks' + +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + b <$> e + +instance Applicative Parser where + pure a = Parser $ \_path _kf ks -> ks a + (<*>) = apP + +instance Alternative Parser where + empty = fail "empty" + (<|>) = mplus + +instance MonadPlus Parser where + mzero = fail "mzero" + mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks + in runParser a path kf' ks + +instance Semigroup (Parser a) where + (<>) = mplus + +instance Monoid (Parser a) where + mempty = fail "mempty" + mappend = (<>) + + +-- Conversion ------------------------------------------------------------------ + +class FromNoun a where + parseNoun :: Noun -> Parser a + +class ToNoun a where + toNoun :: a -> Noun + +-------------------------------------------------------------------------------- + +fromNoun :: FromNoun a => Noun -> Maybe a +fromNoun n = runParser (parseNoun n) [] onFail onSuccess + where + onFail p m = Nothing + onSuccess x = Just x + +fromNounErr :: FromNoun a => Noun -> Either Text a +fromNounErr n = runParser (parseNoun n) [] onFail onSuccess + where + onFail p m = Left (pack m) + onSuccess x = Right x + + +-- Cord Conversions ------------------------------------------------------------ + +newtype Cord = Cord { unCord :: ByteString } + deriving newtype (Eq, Ord, Show, IsString, NFData) + +instance ToNoun Cord where + toNoun (Cord bs) = Atom (bs ^. from atomBytes) + +instance FromNoun Cord where + parseNoun n = do + atom <- parseNoun n + pure $ Cord (atom ^. atomBytes) + +--- Atom Conversion ------------------------------------------------------------ + +instance ToNoun Atom where + toNoun = Atom + +instance FromNoun Atom where + parseNoun = \case + Atom a -> pure a + Cell _ _ -> fail "Expecting an atom, but got a cell" diff --git a/pkg/hs-urbit/lib/Noun/Core.hs b/pkg/hs-urbit/lib/Noun/Core.hs new file mode 100644 index 000000000..00801a0d4 --- /dev/null +++ b/pkg/hs-urbit/lib/Noun/Core.hs @@ -0,0 +1,115 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE Strict, StrictData #-} + +module Noun.Core + ( Noun, pattern Cell, pattern Atom, nounSize + ) where + +import ClassyPrelude hiding (hash) + +import Noun.Atom + +import Data.Bits (xor) +import Data.Hashable (hash) +import GHC.Natural (Natural) +import GHC.Prim (reallyUnsafePtrEquality#) +import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary)) +import Test.QuickCheck.Gen (Gen, scale, resize, getSize) + + +-- Types ----------------------------------------------------------------------- + +data Noun + = NCell Int Word Noun Noun + | NAtom Int Atom + +{-# COMPLETE Cell, Atom #-} +pattern Cell x y <- NCell _ _ x y where Cell = mkCell +pattern Atom a <- NAtom _ a where Atom = mkAtom + + +-------------------------------------------------------------------------------- + +instance Hashable Noun where + hash = \case NCell h _ _ _ -> h + NAtom h _ -> h + {-# INLINE hash #-} + hashWithSalt = defaultHashWithSalt + {-# INLINE hashWithSalt #-} + +instance Eq Noun where + (==) x y = + case reallyUnsafePtrEquality# x y of + 1# -> True + _ -> case (x, y) of + (NAtom x1 a1, NAtom x2 a2) -> + x1 == x2 && a1 == a2 + (NCell x1 s1 h1 t1, NCell x2 s2 h2 t2) -> + s1==s2 && x1==x2 && h1==h2 && t1==t2 + _ -> + False + {-# INLINE (==) #-} + +instance Ord Noun where + compare x y = + case reallyUnsafePtrEquality# x y of + 1# -> EQ + _ -> case (x, y) of + (Atom _, Cell _ _) -> LT + (Cell _ _, Atom _) -> GT + (Atom a1, Atom a2) -> compare a1 a2 + (Cell h1 t1, Cell h2 t2) -> compare h1 h2 <> compare t1 t2 + {-# INLINE compare #-} + + +instance Arbitrary Noun where + arbitrary = resize 1000 go + where + dub x = Cell x x + go = do + sz <- getSize + (bit, bat :: Bool) <- arbitrary + case (sz, bit, bat) of + ( 0, _, _ ) -> Atom <$> genAtom + ( _, False, _ ) -> Atom <$> genAtom + ( _, True, True ) -> dub <$> arbitrary + ( _, True, _ ) -> scale (\x -> x-10) (Cell <$> go <*> go) + +genNatural :: Gen Natural +genNatural = fromInteger . abs <$> arbitrary + +genAtom :: Gen Atom +genAtom = do + arbitrary >>= \case + False -> genNatural + True -> (`mod` 16) <$> genNatural + +-------------------------------------------------------------------------------- + +{-# INLINE nounSize #-} +nounSize :: Noun -> Word +nounSize = \case + NCell _ s _ _ -> s + NAtom _ _ -> 1 + +{-# INLINE mkAtom #-} +mkAtom :: Atom -> Noun +mkAtom a = NAtom (hash a) a + +{-# INLINE mkCell #-} +mkCell :: Noun -> Noun -> Noun +mkCell h t = NCell has siz h t + where + siz = nounSize h + nounSize t + has = hash h `combine` hash t + + +-- Stolen from Hashable Library ------------------------------------------------ + +{-# INLINE combine #-} +combine :: Int -> Int -> Int +combine h1 h2 = (h1 * 16777619) `xor` h2 + +{-# INLINE defaultHashWithSalt #-} +defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt salt x = salt `combine` hash x diff --git a/pkg/hs-urbit/lib/Cue.hs b/pkg/hs-urbit/lib/Noun/Cue.hs similarity index 97% rename from pkg/hs-urbit/lib/Cue.hs rename to pkg/hs-urbit/lib/Noun/Cue.hs index b076225d9..89fd2ac49 100644 --- a/pkg/hs-urbit/lib/Cue.hs +++ b/pkg/hs-urbit/lib/Noun/Cue.hs @@ -1,16 +1,16 @@ -module Cue (cue, cueBS) where +module Noun.Cue (cue, cueBS) where import ClassyPrelude -import Noun -import Atom (Atom(..)) +import Noun.Core +import Noun.Atom + import Control.Lens (view, from) import Data.Bits (shiftL, shiftR, (.|.), (.&.)) import Foreign.Ptr (Ptr, plusPtr, castPtr, ptrToWordPtr) import Foreign.Storable (peek) import GHC.Prim (ctz#) import GHC.Word (Word(..)) -import Pill (atomBS, atomWords) import System.IO.Unsafe (unsafePerformIO) import Text.Printf (printf) @@ -25,7 +25,7 @@ cueBS :: ByteString -> Either DecodeExn Noun cueBS = doGet dNoun cue :: Atom -> Either DecodeExn Noun -cue = cueBS . view atomBS +cue = cueBS . view atomBytes -- Debugging ------------------------------------------------------------------- @@ -38,12 +38,6 @@ debugM _ = pure () debugMId :: (Monad m, Show a) => String -> m a -> m a debugMId _ a = a --- debugMId tag m = do - -- r <- m - -- debugM (tag <> ": " <> show r) - -- pure r - - -- Types ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Jam.hs b/pkg/hs-urbit/lib/Noun/Jam.hs similarity index 95% rename from pkg/hs-urbit/lib/Jam.hs rename to pkg/hs-urbit/lib/Noun/Jam.hs index 3f838c30c..5b9c94d7b 100644 --- a/pkg/hs-urbit/lib/Jam.hs +++ b/pkg/hs-urbit/lib/Noun/Jam.hs @@ -1,10 +1,10 @@ -module Jam (jam, jamBS) where +module Noun.Jam (jam, jamBS) where import ClassyPrelude hiding (hash) -import Noun -import Atom (Atom(MkAtom), toAtom, bitWidth, takeBitsWord) -import Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) +import Noun.Core +import Noun.Atom + import Control.Lens (view, from) import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.)) import Data.Vector.Primitive ((!)) @@ -16,7 +16,6 @@ import GHC.Int (Int(I#)) import GHC.Natural (Natural(NatS#, NatJ#)) import GHC.Prim (Word#, plusWord#, word2Int#) import GHC.Word (Word(W#)) -import Pill (bigNatWords, atomBS) import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Unsafe as BS @@ -32,7 +31,7 @@ jamBS n = doPut bt sz (writeNoun n) (sz, bt) = unsafePerformIO (compress n) jam :: Noun -> Atom -jam = view (from atomBS) . jamBS +jam = view (from atomBytes) . jamBS -- Types ----------------------------------------------------------------------- @@ -189,8 +188,8 @@ writeAtomBigNat !(view bigNatWords -> words) = do {-# INLINE writeAtomBits #-} writeAtomBits :: Atom -> Put () -writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd - MkAtom (NatJ# bn) -> writeAtomBigNat bn +writeAtomBits = \case NatS# wd -> writeAtomWord# wd + NatJ# bn -> writeAtomBigNat bn -- Put Instances --------------------------------------------------------------- @@ -292,7 +291,7 @@ writeBackRef !a = do p <- pos <$> getS writeBit True writeBit True - writeMat (toAtom a) + writeMat (fromIntegral a) -- Calculate Jam Size and Backrefs --------------------------------------------- diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 7bbc6ab34..e46024da3 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -1,45 +1 @@ module Noun.Lens where - -import ClassyPrelude -import Pill -import Noun -import Atom -import Control.Lens -import Jam (jam, jamBS) -import Cue (cue, cueBS) - --------------------------------------------------------------------------------- - -eitherToMaybe (Left _) = Nothing -eitherToMaybe (Right x) = Just x - -_CueBytes :: Prism' ByteString Noun -_CueBytes = prism' jamBS (eitherToMaybe . cueBS) - -_Cue :: Prism' Atom Noun -_Cue = prism' jam (eitherToMaybe . cue) - --------------------------------------------------------------------------------- - -loadNoun :: FilePath -> IO (Maybe Noun) -loadNoun = fmap (preview _CueBytes) . readFile - -dumpJam :: FilePath -> Noun -> IO () -dumpJam fp = writeFile fp . view (re _CueBytes) - -tryCuePill :: PillFile -> IO () -tryCuePill pill = - loadNoun (show pill) >>= \case Nothing -> print "nil" - Just (Atom _) -> print "atom" - Just (Cell _ _) -> print "cell" - -tryCueJamPill :: PillFile -> IO () -tryCueJamPill pill = do - n <- loadNoun (show pill) >>= \case - Nothing -> print "failure" >> pure (Atom 0) - Just n@(Atom _) -> print "atom" >> pure n - Just n@(Cell _ _) -> print "cell" >> pure n - - bs <- evaluate (force (jamBS n)) - - print ("jam size: " <> show (length bs)) diff --git a/pkg/hs-urbit/lib/Noun/TH.hs b/pkg/hs-urbit/lib/Noun/TH.hs index b7155fa6a..e09f62264 100644 --- a/pkg/hs-urbit/lib/Noun/TH.hs +++ b/pkg/hs-urbit/lib/Noun/TH.hs @@ -2,11 +2,10 @@ Generate FromNoun and ToNoun instances. -} -module Noun.TH where +module Noun.TH (deriveNoun) where import ClassyPrelude hiding (fromList) -import Noun -import Control.Lens +import Noun.Convert import Language.Haskell.TH import Language.Haskell.TH.Syntax diff --git a/pkg/hs-urbit/lib/Pill.hs b/pkg/hs-urbit/lib/Pill.hs deleted file mode 100644 index fe546e385..000000000 --- a/pkg/hs-urbit/lib/Pill.hs +++ /dev/null @@ -1,316 +0,0 @@ -{- - TODO Handle 32-bit architectures - TODO Handle big-endian. - TODO A faster version of this is possible: - - - Get the byte-length of a file. - - Round up to a multiple of 8 (or 4 if 32bit cpu) - - Allocate a mutable vector of Word8 with that size. - - Read the file into the array. - - Manually cast to an array of Word. - - On big endian, update each words with `System.Endian.fromLE64`. - - If there are trailing 0 words, adjust the vector size to delete them. - - unsafeFreeze the vector. - - Run `byteArrayToBigNat#` on the underlying byte array. - - Convert the BigNat to a Natural, to an Atom. - - The whole thing becomes zero-copy for little endian machines, with - one zero-copy transformation of the whole structure on big-endian - machines. --} - -module Pill - ( pill, pillBS, atomBS, bigNatWords, atomWords, PillFile(..), Pill(..) - ) where - -import ClassyPrelude -import Atom -import Data.Flat hiding (from, to) -import Control.Monad.Except -import Control.Lens hiding (index, Index) -import Data.Either.Extra (mapLeft) -import GHC.Natural -import Data.Bits -import GHC.Integer.GMP.Internals -import GHC.Int -import GHC.Word -import GHC.Exts (sizeofByteArray#) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Data.Vector as V -import qualified Data.Primitive.Types as Prim -import qualified Data.Primitive.ByteArray as Prim -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Unboxed as VU -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BU - -import Test.Tasty -import Test.Tasty.TH -import Test.Tasty.QuickCheck as QC -import Test.QuickCheck - --------------------------------------------------------------------------------- - -{- - A `Pill` is a bytestring without trailing zeros. --} -newtype Pill = Pill { unPill :: ByteString } - -instance Eq Pill where - (==) x y = (x ^. pillBS) == (y ^. pillBS) - -instance Show Pill where - show = show . view pillBS - --------------------------------------------------------------------------------- - -strip :: (IsSequence seq, Int ~ Index seq, Eq (Element seq), Num (Element seq)) - => seq -> seq -strip buf = take (len - go 0 (len - 1)) buf - where - len = length buf - go n i | i < 0 = n - | 0 == unsafeIndex buf i = go (n+1) (i-1) - | otherwise = n - -pillBS :: Iso' Pill ByteString -pillBS = iso to from - where - to :: Pill -> ByteString - to = strip . unPill - - from :: ByteString -> Pill - from = Pill . strip - --------------------------------------------------------------------------------- - -bigNatWords :: Iso' BigNat (VP.Vector Word) -bigNatWords = iso to from - where - to (BN# bArr) = VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8) - (Prim.ByteArray bArr) - - from v@(VP.Vector off (I# len) (Prim.ByteArray buf)) = - case VP.length v of - 0 -> zeroBigNat - 1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w) - n -> if off /= 0 then error "words2Nat: bad-vec" else - byteArrayToBigNat# buf len - --------------------------------------------------------------------------------- - -bigNatBits :: Iso' BigNat (VU.Vector Bool) -bigNatBits = undefined - -natWords :: Iso' Natural (VP.Vector Word) -natWords = naturalBigNat . bigNatWords - -naturalBigNat :: Iso' Natural BigNat -naturalBigNat = iso to from - where - to = \case NatS# w -> wordToBigNat w - NatJ# bn -> bn - - from bn = case sizeofBigNat# bn of 0# -> 0 - 1# -> NatS# (bigNatToWord bn) - _ -> NatJ# bn - --------------------------------------------------------------------------------- - -dumbPackWord :: ByteString -> Word -dumbPackWord bs = go 0 0 (toList bs) - where - go acc i [] = acc - go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs - --- TODO This assumes 64-bit words -packedWord :: Iso' ByteString Word -packedWord = iso to from - where - from wor = reverse $ fromList $ go 0 [] - where - go i acc | i >= 8 = acc - go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc) - - to buf = go 0 0 - where - top = min 8 (length buf) - i idx off = shiftL (fromIntegral $ BS.index buf idx) off - go acc idx = if idx >= top then acc else - go (acc .|. i idx (8*idx)) (idx+1) - --------------------------------------------------------------------------------- - -wordsToBytes :: VP.Vector Word -> VP.Vector Word8 -wordsToBytes (VP.Vector off sz buf) = - VP.Vector (off*8) (sz*8) buf - -bsToWords :: ByteString -> VP.Vector Word -bsToWords bs = - VP.generate (1 + length bs `div` 8) $ \i -> - view packedWord (BS.drop (i*8) bs) - -{- - TODO Support Big-Endian - TODO This still has a (small) risk of segfaulting. The right thing to - do is to manually copy the data to the C heap, setup the - finalizers, and then manually construct a bytestring from - that pointer. -- finalizers, and make a bytestring from that. --} -bytesBS :: Iso' (VP.Vector Word8) ByteString -bytesBS = iso to from - where - to :: VP.Vector Word8 -> ByteString - to (VP.Vector off sz buf) = - unsafePerformIO $ do - Prim.Addr ptr <- evaluate $ Prim.byteArrayContents buf - bs <- BU.unsafePackAddressLen sz ptr - evaluate $ force $ BS.copy $ BS.drop off bs - - from :: ByteString -> VP.Vector Word8 - from bs = VP.generate (length bs) (BS.index bs) - -pillWords :: Iso' Pill (VP.Vector Word) -pillWords = iso toVec fromVec - where - toVec = view (pillBS . to bsToWords) - fromVec = view (to wordsToBytes . bytesBS . from pillBS) - --------------------------------------------------------------------------------- - -{- - This is a stupid, but obviously correct version of `view (from pill)`. --} -dumbPackAtom :: Pill -> Atom -dumbPackAtom = go 0 0 . toList . view pillBS - where - go acc i [] = acc - go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs - -atomNat :: Iso' Atom Natural -atomNat = iso unAtom MkAtom - -atomWords :: Iso' Atom (VP.Vector Word) -atomWords = atomNat . natWords - -pill :: Iso' Atom Pill -pill = iso toAtom fromPill - where - toAtom = view (atomNat . natWords . from pillWords) - fromPill = view (pillBS . to bsToWords . from natWords . from atomNat) - -atomBS :: Iso' Atom ByteString -atomBS = pill . pillBS - --------------------------------------------------------------------------------- - -_Tall :: Flat a => Prism' ByteString a -_Tall = prism' flat (eitherToMaybe . unflat) - where - eitherToMaybe :: Either a b -> Maybe b - eitherToMaybe (Left x) = Nothing - eitherToMaybe (Right x) = Just x - --------------------------------------------------------------------------------- - -loadPill :: FilePath -> IO Pill -loadPill = fmap Pill . readFile - -loadAtom :: FilePath -> IO Atom -loadAtom = fmap (view $ from pillBS . from pill) . readFile - -loadFlat :: Flat a => FilePath -> IO (Either Text a) -loadFlat = fmap (mapLeft tshow . unflat) . readFile - --------------------------------------------------------------------------------- - -dumpPill :: FilePath -> Pill -> IO () -dumpPill fp = writeFile fp . view pillBS - -dumpAtom :: FilePath -> Atom -> IO () -dumpAtom fp = writeFile fp . view (pill . pillBS) - -dumpFlat :: Flat a => FilePath -> a -> IO () -dumpFlat fp = writeFile fp . flat - --------------------------------------------------------------------------------- - -data PillFile = Brass | Ivory | Solid - -instance Show PillFile where - show = \case - Brass -> "./bin/brass.pill" - Solid -> "./bin/solid.pill" - Ivory -> "./bin/ivory.pill" - -tryLoadPill :: PillFile -> IO Atom -tryLoadPill pill = do - a@(MkAtom nat) <- loadAtom (show pill) - putStrLn "loaded" - print (a > 0) - putStrLn "evaled" - print (take 10 $ VP.toList $ nat ^. natWords) - pure a - -tryPackPill :: PillFile -> IO () -tryPackPill pf = do - atm <- tryLoadPill pf - print $ length (atm ^. pill . pillBS) - --- Tests ----------------------------------------------------------------------- - -instance Arbitrary ByteString where - arbitrary = fromList <$> arbitrary - -instance Arbitrary Pill where - arbitrary = Pill <$> arbitrary - -instance Arbitrary BigNat where - arbitrary = view naturalBigNat <$> arbitrary - -instance Show BigNat where - show = show . NatJ# - --------------------------------------------------------------------------------- - -testIso :: Eq a => Iso' a b -> a -> Bool -testIso iso x = x == (x ^. iso . from iso) - -roundTrip :: Eq a => (a -> b) -> (b -> a) -> (a -> Bool) -roundTrip dump load x = x == load (dump x) - -equiv :: Eq b => (a -> b) -> (a -> b) -> (a -> Bool) -equiv f g x = f x == g x - -check :: Atom -> Atom -check = toAtom . (id :: Integer -> Integer) . fromAtom - --------------------------------------------------------------------------------- - -prop_packWordSane = equiv (view packedWord) dumbPackWord . fromList -prop_packWord = testIso (from packedWord) -prop_unpackWord = roundTrip (view packedWord) - (strip . view (from packedWord)) - . strip - . take 8 - -prop_unpackBigNat = testIso bigNatWords - -prop_packBigNat = roundTrip (view (from bigNatWords) . VP.fromList) - (strip . VP.toList . view bigNatWords) - . strip - -prop_implodeBytes = roundTrip (view pillWords) (view (from pillWords)) - -prop_explodeBytes = roundTrip (view (from pillWords) . VP.fromList) - (strip . VP.toList . view pillWords) - . strip - -prop_packAtomSane = equiv (view (from pill)) dumbPackAtom . Pill . fromList -prop_unpackAtom = roundTrip (view pill) (view (from pill)) -prop_packAtom = roundTrip (view (from pill)) (view pill) . Pill . strip - --------------------------------------------------------------------------------- - -main :: IO () -main = $(defaultMainGenerator) diff --git a/pkg/hs-urbit/lib/Urbit/Ames.hs b/pkg/hs-urbit/lib/Urbit/Ames.hs index 3e9bc9219..9bcf0991e 100644 --- a/pkg/hs-urbit/lib/Urbit/Ames.hs +++ b/pkg/hs-urbit/lib/Urbit/Ames.hs @@ -1,17 +1,16 @@ module Urbit.Ames where import ClassyPrelude + import Data.IP - import Noun -import Atom - import Network.Socket import qualified Data.Vector as V -import qualified Urbit.Time as Time +import qualified Urbit.Time as Time +import qualified Vere.Ames as VA -import qualified Vere.Ames as VA +-------------------------------------------------------------------------------- data GalaxyInfo = GalaxyInfo { ip :: IPv4, age :: Time.Unix } diff --git a/pkg/hs-urbit/lib/Vere/Ames.hs b/pkg/hs-urbit/lib/Vere/Ames.hs index 443a85cd7..f04f525f3 100644 --- a/pkg/hs-urbit/lib/Vere/Ames.hs +++ b/pkg/hs-urbit/lib/Vere/Ames.hs @@ -4,7 +4,6 @@ import ClassyPrelude import Data.IP import Data.Void import Noun -import Atom import Noun.TH import Control.Lens diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index e003900f4..665b3cd7f 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -4,7 +4,6 @@ module Vere.Http where import ClassyPrelude import Noun -import Atom import Noun.TH import qualified Data.CaseInsensitive as CI diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index d26e7b4e8..de70a6889 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -4,13 +4,11 @@ module Vere.Http.Server where import ClassyPrelude import Vere.Http -import Atom import Noun import Noun.TH import Control.Lens import Control.Concurrent (ThreadId, killThread, forkIO) -import Pill (pill, pillBS, Pill(..)) import qualified Data.ByteString as BS import qualified Network.HTTP.Types as H @@ -120,12 +118,12 @@ bsOcts = iso toOcts fromOcts where toOcts :: ByteString -> Octs toOcts bs = - Octs (fromIntegral (length bs)) (bs ^. from (pill . pillBS)) + Octs (fromIntegral (length bs)) (bs ^. from atomBytes) fromOcts :: Octs -> ByteString fromOcts (Octs (fromIntegral -> len) atm) = bs <> pad where - bs = atm ^. pill . pillBS + bs = atm ^. atomBytes pad = BS.replicate (max 0 (len - length bs)) 0 readEvents :: W.Request -> IO Request diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index 78804aa65..c0ddea467 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -17,10 +17,6 @@ import ClassyPrelude hiding (init) import Control.Lens hiding ((<|)) import Noun -import Atom -import Jam -import Pill -import Noun.Lens import Data.Void import Database.LMDB.Raw import Foreign.Ptr @@ -176,12 +172,12 @@ get txn db key = mdbValToAtom :: MDB_val -> IO Atom mdbValToAtom (MDB_val sz ptr) = do bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) - pure (bs ^. from (pill . pillBS)) + pure (bs ^. from atomBytes) mdbValToNoun :: MDB_val -> IO Noun mdbValToNoun (MDB_val sz ptr) = do bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz) - let res = bs ^? from pillBS . from pill . _Cue + let res = bs ^? _Cue maybeErr res "mdb bad cue" putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO () @@ -193,13 +189,13 @@ putRaw flags txn db key val = putNoun :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO () putNoun flags txn db key val = byteStringAsMdbVal key $ \mKey -> - byteStringAsMdbVal (val ^. re _CueBytes) $ \mVal -> + byteStringAsMdbVal (val ^. re _Cue) $ \mVal -> putRaw flags txn db mKey mVal putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO () putJam flags txn db id (Jam atom) = do withWord64AsMDBval id $ \idVal -> do - let !bs = atom ^. pill . pillBS + let !bs = atom ^. atomBytes byteStringAsMdbVal bs $ \mVal -> do putRaw flags txn db idVal mVal diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index a3e750506..6f91e7484 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -3,7 +3,6 @@ module Vere.Pier where import ClassyPrelude import Noun -import Pill import Vere.Pier.Types import qualified Vere.Log as Log @@ -22,7 +21,8 @@ ioDrivers = [] :: [IODriver] -- This is called to make a freshly booted pier. It assigns an identity to an -- event log and takes a chill pill. -boot :: Pill -> FilePath -> LogIdentity -> IO (Serf, EventLog, EventId, Mug) +boot :: ByteString -> FilePath -> LogIdentity + -> IO (Serf, EventLog, EventId, Mug) boot pill top id = do let logPath = top <> "/log" diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 1c31d4a26..07f08d34c 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -3,7 +3,6 @@ module Vere.Pier.Types where import ClassyPrelude import Data.Void import Noun -import Atom import Noun.TH import Database.LMDB.Raw import Urbit.Time diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 6b425d6e2..da426532c 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -2,22 +2,18 @@ module Vere.Serf where import ClassyPrelude import Control.Lens + import Data.Void - import Noun -import Atom -import Jam (jam, jamBS) -import Cue (cue, cueBS) -import Pill -import Vere.Pier.Types import System.Process +import Vere.Pier.Types -import Foreign.Marshal.Alloc (alloca) -import System.Exit (ExitCode) -import Data.ByteString (hGet) +import Data.ByteString (hGet) import Data.ByteString.Unsafe (unsafeUseAsCString) -import Foreign.Ptr (castPtr) -import Foreign.Storable (poke, peek) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (castPtr) +import Foreign.Storable (poke, peek) +import System.Exit (ExitCode) import qualified Data.ByteString.Unsafe as BS import qualified Urbit.Time as Time @@ -238,7 +234,7 @@ replayEvents w (wid, wmug) identity lastCommitedId getEvents = do loop vLast (curEvent + toRead) -bootSerf :: Serf -> LogIdentity -> Pill -> IO (EventId, Mug) +bootSerf :: Serf -> LogIdentity -> ByteString -> IO (EventId, Mug) bootSerf w ident pill = do recvPlea w >>= \case @@ -332,9 +328,7 @@ sendAtom s a = do hFlush (sendHandle s) traceM "sendAtom.return ()" -atomBytes :: Iso' Atom ByteString -atomBytes = pill . pillBS - +packAtom :: ByteString -> Atom packAtom = view (from atomBytes) unpackAtom :: Atom -> ByteString diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 19b1b85a3..ca60ee373 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -8,6 +8,7 @@ library: - -fwarn-incomplete-patterns - -fwarn-unused-binds - -fwarn-unused-imports + # -Werror - -O2 dependencies: diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index 537f6e105..ec12f6ed1 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/pkg/hs-vere/app/uterm/Main.hs @@ -2,22 +2,12 @@ module Main where import ClassyPrelude import Control.Lens -import Pill hiding (main) -import Noun.Lens +import Noun -------------------------------------------------------------------------------- main :: IO () main = do - -- print "load brass" -- void getLine - -- tryLoadPill Brass - - -- print "load ivory" -- void getLine - -- tryLoadPill Ivory - - -- print "load solid" -- void getLine - -- tryLoadPill Solid - print "cue brass" -- void getLine tryCueJamPill Brass @@ -26,3 +16,34 @@ main = do print "cue solid" -- void getLine tryCueJamPill Solid + +loadNoun :: FilePath -> IO (Maybe Noun) +loadNoun = fmap (preview _Cue) . readFile + +dumpJam :: FilePath -> Noun -> IO () +dumpJam fp = writeFile fp . view (re _Cue) + +tryCuePill :: PillFile -> IO () +tryCuePill pill = + loadNoun (show pill) >>= \case Nothing -> print "nil" + Just (Atom _) -> print "atom" + Just (Cell _ _) -> print "cell" + +tryCueJamPill :: PillFile -> IO () +tryCueJamPill pill = do + n <- loadNoun (show pill) >>= \case + Nothing -> print "failure" >> pure (Atom 0) + Just n@(Atom _) -> print "atom" >> pure n + Just n@(Cell _ _) -> print "cell" >> pure n + + bs <- evaluate (force (jamBS n)) + + print ("jam size: " <> show (length bs)) + +data PillFile = Brass | Ivory | Solid + +instance Show PillFile where + show = \case + Brass -> "./bin/brass.pill" + Solid -> "./bin/solid.pill" + Ivory -> "./bin/ivory.pill" From 2d2029106b110b6a188bd1ec558c6bd1546f9008 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 12 Jul 2019 12:18:14 -0700 Subject: [PATCH 105/431] -Werror --- pkg/hs-urbit/lib/Noun/Conversions.hs | 11 +++-------- pkg/hs-urbit/lib/Noun/Core.hs | 3 ++- pkg/hs-urbit/lib/Urbit/Ames.hs | 10 ++++++---- pkg/hs-urbit/lib/Urbit/Time.hs | 2 +- pkg/hs-urbit/lib/Vere/Ames.hs | 2 -- pkg/hs-urbit/lib/Vere/Http.hs | 1 - pkg/hs-urbit/lib/Vere/Http/Client.hs | 8 ++++---- pkg/hs-urbit/lib/Vere/Http/Server.hs | 12 +++++++----- pkg/hs-urbit/lib/Vere/Log.hs | 7 ++----- pkg/hs-urbit/lib/Vere/Pier.hs | 8 +++----- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 25 +++++++++++-------------- pkg/hs-urbit/lib/Vere/Serf.hs | 5 +++-- pkg/hs-urbit/package.yaml | 2 +- 13 files changed, 43 insertions(+), 53 deletions(-) diff --git a/pkg/hs-urbit/lib/Noun/Conversions.hs b/pkg/hs-urbit/lib/Noun/Conversions.hs index 06c8fb404..41fc3ff15 100644 --- a/pkg/hs-urbit/lib/Noun/Conversions.hs +++ b/pkg/hs-urbit/lib/Noun/Conversions.hs @@ -1,5 +1,5 @@ module Noun.Conversions - ( Cord(..), Knot(..), Term(..), Tank(..), Tang, Plum(..) + ( Cord(..), Knot(..), Term(..), Tank(..), Tang, Plum(..), Nullable ) where import ClassyPrelude hiding (hash) @@ -125,14 +125,9 @@ instance FromNoun a => FromNoun [a] where -- Tape ------------------------------------------------------------------------ +-- TODO XX are these instances correct? newtype Tape = Tape [Char] - deriving newtype (Eq, Ord, Show) - -instance FromNoun Tape where - parseNoun = undefined - -instance ToNoun Tape where - toNoun = undefined + deriving newtype (Eq, Ord, Show, FromNoun, ToNoun) -- Pretty Printing ------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Noun/Core.hs b/pkg/hs-urbit/lib/Noun/Core.hs index 00801a0d4..5928835ab 100644 --- a/pkg/hs-urbit/lib/Noun/Core.hs +++ b/pkg/hs-urbit/lib/Noun/Core.hs @@ -23,10 +23,11 @@ data Noun = NCell Int Word Noun Noun | NAtom Int Atom -{-# COMPLETE Cell, Atom #-} pattern Cell x y <- NCell _ _ x y where Cell = mkCell pattern Atom a <- NAtom _ a where Atom = mkAtom +{-# COMPLETE Cell, Atom #-} + -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Urbit/Ames.hs b/pkg/hs-urbit/lib/Urbit/Ames.hs index 9bcf0991e..6de89654a 100644 --- a/pkg/hs-urbit/lib/Urbit/Ames.hs +++ b/pkg/hs-urbit/lib/Urbit/Ames.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + module Urbit.Ames where import ClassyPrelude @@ -41,12 +43,12 @@ data NetworkMode = LocalOnlyNetworking | GlobalNetworking --- ioStart :: Ames -> NetworkMode -> Int -> Noun -> IO Ames +ioStart ames isLocal defaultPort (Cell _ _) = undefined ioStart ames isLocal defaultPort (Atom who) = do - let port = if who < 256 - then computePort isLocal who - else defaultPort + let _port = if who < 256 + then computePort isLocal who + else defaultPort -- TODO: set up another thread to own the recv socket, which makes the Ovums -- which get put into the computeQueue, like in _ames_recv_cb. diff --git a/pkg/hs-urbit/lib/Urbit/Time.hs b/pkg/hs-urbit/lib/Urbit/Time.hs index ca835d8f2..a743f4c48 100644 --- a/pkg/hs-urbit/lib/Urbit/Time.hs +++ b/pkg/hs-urbit/lib/Urbit/Time.hs @@ -7,7 +7,7 @@ import Control.Lens import Noun (FromNoun, ToNoun) import Data.Bits (shiftL, shiftR) -import Data.Time.Clock (DiffTime, UTCTime, picosecondsToDiffTime) +import Data.Time.Clock (DiffTime, UTCTime) import Data.Time.Clock (picosecondsToDiffTime, diffTimeToPicoseconds) import Data.Time.Clock.System (SystemTime(..), getSystemTime) import Data.Time.Clock.System (utcToSystemTime, systemToUTCTime) diff --git a/pkg/hs-urbit/lib/Vere/Ames.hs b/pkg/hs-urbit/lib/Vere/Ames.hs index f04f525f3..5dc781445 100644 --- a/pkg/hs-urbit/lib/Vere/Ames.hs +++ b/pkg/hs-urbit/lib/Vere/Ames.hs @@ -4,8 +4,6 @@ import ClassyPrelude import Data.IP import Data.Void import Noun -import Noun.TH -import Control.Lens import qualified Urbit.Time as Time diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index 665b3cd7f..235748e29 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -4,7 +4,6 @@ module Vere.Http where import ClassyPrelude import Noun -import Noun.TH import qualified Data.CaseInsensitive as CI import qualified Network.HTTP.Types as HT diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index e9795d022..768f7b6e4 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Client.hs @@ -6,13 +6,13 @@ module Vere.Http.Client where import ClassyPrelude -import Vere.Http + import Noun -import Noun.TH +import Vere.Http import qualified Data.CaseInsensitive as CI -import qualified Network.HTTP.Types as HT -import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Types as HT -- Types ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index de70a6889..e49050f69 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -3,10 +3,10 @@ module Vere.Http.Server where import ClassyPrelude -import Vere.Http -import Noun -import Noun.TH + import Control.Lens +import Noun +import Vere.Http import Control.Concurrent (ThreadId, killThread, forkIO) @@ -16,6 +16,8 @@ import qualified Network.Wai as W import qualified Network.Wai.Handler.Warp as W import qualified Network.Wai.Handler.WarpTLS as W +-- Types ----------------------------------------------------------------------- + type ServerId = Word type ConnectionId = Word type RequestId = Word @@ -60,8 +62,6 @@ data ClientResponse data MimeData = MimeData Text ByteString --- - data Ev data State = State @@ -69,6 +69,8 @@ data State = State , sChan :: MVar Ev } +-------------------------------------------------------------------------------- + init :: IO State init = -- When we initialize things, we send an event into arvo diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index c0ddea467..8fda8daf8 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -16,11 +16,10 @@ module Vere.Log ( open import ClassyPrelude hiding (init) import Control.Lens hiding ((<|)) -import Noun -import Data.Void import Database.LMDB.Raw -import Foreign.Ptr import Foreign.Marshal.Alloc +import Foreign.Ptr +import Noun import Vere.Pier.Types import Control.Concurrent (runInBoundThread) @@ -28,9 +27,7 @@ import Control.Lens ((^.)) import Foreign.Storable (peek, poke, sizeOf) import qualified Data.ByteString.Unsafe as BU -import qualified Data.ByteString as B import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV -- Open/Close an Event Log ----------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 6f91e7484..0d5a3c029 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -2,14 +2,12 @@ module Vere.Pier where import ClassyPrelude -import Noun import Vere.Pier.Types -import qualified Vere.Log as Log -import qualified Vere.Persist as Persist -import qualified Vere.Serf as Serf +import qualified Vere.Log as Log +import qualified Vere.Serf as Serf -import Vere.Serf (Serf, EventId) +import Vere.Serf (EventId, Serf) -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 07f08d34c..a0084fa0b 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -1,14 +1,10 @@ module Vere.Pier.Types where import ClassyPrelude -import Data.Void import Noun -import Noun.TH import Database.LMDB.Raw import Urbit.Time -import RIO (decodeUtf8Lenient) - import qualified Vere.Ames as Ames import qualified Vere.Http.Client as Client import qualified Vere.Http.Server as Server @@ -81,6 +77,16 @@ data Blit | Url Text deriving (Eq, Ord, Show) +data Varience = Gold | Iron | Lead + +type Perform = Eff -> IO () + +data Ovum = Ovum Path Event + deriving (Eq, Ord, Show) + +newtype Mug = Mug Word32 + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) + deriveNoun ''Blit deriveNoun ''Eff deriveNoun ''Event @@ -88,16 +94,7 @@ deriveNoun ''PutDel deriveNoun ''EffBs deriveNoun ''RecEx deriveNoun ''NewtEx - -data Varience = Gold | Iron | Lead - -type Perform = Eff -> IO () - -data Ovum = Ovum Path Event - deriving (Eq, Ord, Show, Generic, ToNoun) - -newtype Mug = Mug Word32 - deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) +deriveNoun ''Ovum newtype Jam = Jam Atom diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index da426532c..80d34e495 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + module Vere.Serf where import ClassyPrelude @@ -17,7 +19,6 @@ import System.Exit (ExitCode) import qualified Data.ByteString.Unsafe as BS import qualified Urbit.Time as Time -import qualified Vere.Log as Log -------------------------------------------------------------------------------- @@ -268,7 +269,7 @@ workerThread w getEvent (evendId, mug) = async $ forever do currentDate <- Time.now - let mat = jam (undefined (mug, currentDate, ovum)) + let _mat = jam (undefined (mug, currentDate, ovum)) undefined diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index ca60ee373..0309f97e9 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -8,7 +8,7 @@ library: - -fwarn-incomplete-patterns - -fwarn-unused-binds - -fwarn-unused-imports - # -Werror + - -Werror - -O2 dependencies: From c474a94d13b38aac158db9926adebc3cd10d13b1 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Fri, 12 Jul 2019 12:24:44 -0700 Subject: [PATCH 106/431] stylish-haskell --- .stylish-haskell.yaml | 84 ++++++++++++++++++++++++++++ pkg/hs-urbit/lib/Noun.hs | 8 +-- pkg/hs-urbit/lib/Noun/Atom.hs | 16 +++--- pkg/hs-urbit/lib/Noun/Convert.hs | 4 +- pkg/hs-urbit/lib/Noun/Core.hs | 5 +- pkg/hs-urbit/lib/Noun/Cue.hs | 24 ++++---- pkg/hs-urbit/lib/Noun/Jam.hs | 26 ++++----- pkg/hs-urbit/lib/Noun/TH.hs | 4 +- pkg/hs-urbit/lib/Urbit/Ames.hs | 10 ++-- pkg/hs-urbit/lib/Urbit/Behn.hs | 11 ++-- pkg/hs-urbit/lib/Urbit/Time.hs | 8 +-- pkg/hs-urbit/lib/Urbit/Timer.hs | 10 +--- pkg/hs-urbit/lib/Vere/Ames.hs | 2 +- pkg/hs-urbit/lib/Vere/Http.hs | 6 +- pkg/hs-urbit/lib/Vere/Http/Client.hs | 2 +- pkg/hs-urbit/lib/Vere/Http/Server.hs | 4 +- pkg/hs-urbit/lib/Vere/Isle.hs | 7 ++- pkg/hs-urbit/lib/Vere/Isle/Util.hs | 4 +- pkg/hs-urbit/lib/Vere/Log.hs | 8 +-- pkg/hs-urbit/lib/Vere/Persist.hs | 4 +- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 4 +- pkg/hs-urbit/lib/Vere/Serf.hs | 6 +- 22 files changed, 168 insertions(+), 89 deletions(-) create mode 100644 .stylish-haskell.yaml diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 000000000..87cb1a4bb --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,84 @@ +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + - simple_align: + cases: true + top_level_patterns: true + records: true + + # Import cleanup + - imports: + align: group + list_align: after_alias + pad_module_names: true + long_list_align: inline + empty_list_align: inherit + list_padding: 4 + separate_lists: false + space_surround: false + + - language_pragmas: + style: vertical + align: true + remove_redundant: true + + - tabs: + spaces: 4 + + - trailing_whitespace: {} + + # squash: {} + +columns: 80 + +newline: lf + +language_extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DataKinds + - DefaultSignatures + - DeriveAnyClass + - DeriveDataTypeable + - DeriveFoldable + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - EmptyDataDecls + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MagicHash + - MultiParamTypeClasses + - NamedFieldPuns + - NoImplicitPrelude + - NumericUnderscores + - OverloadedStrings + - PartialTypeSignatures + - PatternSynonyms + - QuasiQuotes + - Rank2Types + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - TypeOperators + - UnboxedTuples + - UnicodeSyntax + - ViewPatterns diff --git a/pkg/hs-urbit/lib/Noun.hs b/pkg/hs-urbit/lib/Noun.hs index dda9aa552..d6408bfaa 100644 --- a/pkg/hs-urbit/lib/Noun.hs +++ b/pkg/hs-urbit/lib/Noun.hs @@ -12,12 +12,12 @@ module Noun import ClassyPrelude import Control.Lens -import Noun.Core -import Noun.Convert -import Noun.Conversions import Noun.Atom -import Noun.Jam +import Noun.Conversions +import Noun.Convert +import Noun.Core import Noun.Cue +import Noun.Jam import Noun.TH -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Noun/Atom.hs b/pkg/hs-urbit/lib/Noun/Atom.hs index 88dd6807d..d4f98dbe4 100644 --- a/pkg/hs-urbit/lib/Noun/Atom.hs +++ b/pkg/hs-urbit/lib/Noun/Atom.hs @@ -13,25 +13,25 @@ module Noun.Atom ) where import ClassyPrelude -import Control.Lens hiding (Index) +import Control.Lens hiding (Index) import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import GHC.Exts (sizeofByteArray#) +import GHC.Int (Int(..)) import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#) import GHC.Integer.GMP.Internals (indexBigNat#) -import GHC.Integer.GMP.Internals (wordToBigNat, byteArrayToBigNat#, zeroBigNat) -import GHC.Int (Int(..)) +import GHC.Integer.GMP.Internals (byteArrayToBigNat#, wordToBigNat, zeroBigNat) import GHC.Natural (Natural(..)) -import GHC.Prim (plusWord#, clz#, minusWord#) -import GHC.Prim (Word#, subIntC#, timesWord#, int2Word#) +import GHC.Prim (clz#, minusWord#, plusWord#) +import GHC.Prim (Word#, int2Word#, subIntC#, timesWord#) import GHC.Word (Word(..)) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Primitive.Types as Prim -import qualified Data.Primitive.ByteArray as Prim -import qualified Data.Vector.Primitive as VP import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BU +import qualified Data.Primitive.ByteArray as Prim +import qualified Data.Primitive.Types as Prim +import qualified Data.Vector.Primitive as VP -- Types ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Noun/Convert.hs b/pkg/hs-urbit/lib/Noun/Convert.hs index 961448e74..f988d20e9 100644 --- a/pkg/hs-urbit/lib/Noun/Convert.hs +++ b/pkg/hs-urbit/lib/Noun/Convert.hs @@ -7,9 +7,9 @@ module Noun.Convert ) where import ClassyPrelude hiding (hash) -import Noun.Core -import Noun.Atom import Control.Lens +import Noun.Atom +import Noun.Core import qualified Control.Monad.Fail as Fail diff --git a/pkg/hs-urbit/lib/Noun/Core.hs b/pkg/hs-urbit/lib/Noun/Core.hs index 5928835ab..85a668f07 100644 --- a/pkg/hs-urbit/lib/Noun/Core.hs +++ b/pkg/hs-urbit/lib/Noun/Core.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} -{-# LANGUAGE Strict, StrictData #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE StrictData #-} module Noun.Core ( Noun, pattern Cell, pattern Atom, nounSize @@ -14,7 +15,7 @@ import Data.Hashable (hash) import GHC.Natural (Natural) import GHC.Prim (reallyUnsafePtrEquality#) import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary)) -import Test.QuickCheck.Gen (Gen, scale, resize, getSize) +import Test.QuickCheck.Gen (Gen, getSize, resize, scale) -- Types ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Noun/Cue.hs b/pkg/hs-urbit/lib/Noun/Cue.hs index 89fd2ac49..e74cc8de9 100644 --- a/pkg/hs-urbit/lib/Noun/Cue.hs +++ b/pkg/hs-urbit/lib/Noun/Cue.hs @@ -2,12 +2,12 @@ module Noun.Cue (cue, cueBS) where import ClassyPrelude -import Noun.Core import Noun.Atom +import Noun.Core -import Control.Lens (view, from) -import Data.Bits (shiftL, shiftR, (.|.), (.&.)) -import Foreign.Ptr (Ptr, plusPtr, castPtr, ptrToWordPtr) +import Control.Lens (from, view) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Foreign.Ptr (Ptr, castPtr, plusPtr, ptrToWordPtr) import Foreign.Storable (peek) import GHC.Prim (ctz#) import GHC.Word (Word(..)) @@ -75,7 +75,7 @@ newtype Get a = Get doGet :: Get a -> ByteString -> Either DecodeExn a doGet m bs = - unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do + unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do let endPtr = ptr `plusPtr` len let sz = max 50 $ min 10_000_000 @@ -137,19 +137,19 @@ getPos = Get $ \_ _ s -> pure (GetResult s (pos s)) insRef :: Word -> Noun -> Get () -insRef !pos !now = Get \_ tbl s -> do +insRef !pos !now = Get $ \_ tbl s -> do H.insert tbl pos now pure $ GetResult s () getRef :: Word -> Get Noun -getRef !ref = Get \x tbl s -> do +getRef !ref = Get $ \x tbl s -> do H.lookup tbl ref >>= \case Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s Just no -> pure (GetResult s no) advance :: Word -> Get () advance 0 = debugM "advance: 0" >> pure () -advance !n = Get \_ _ s -> do +advance !n = Get $ \_ _ s -> do debugM ("advance: " <> show n) let newUsed = n + usedBits s newS = s { pos = pos s + n @@ -164,7 +164,7 @@ advance !n = Get \_ _ s -> do -- TODO Should this be (>= end) or (> end)? peekCurWord :: Get Word -peekCurWord = Get \end _ s -> do +peekCurWord = Get $ \end _ s -> do debugMId "peekCurWord" $ do if ptrToWordPtr (currPtr s) >= ptrToWordPtr end then pure (GetResult s 0) @@ -172,7 +172,7 @@ peekCurWord = Get \end _ s -> do -- TODO Same question as above. peekNextWord :: Get Word -peekNextWord = Get \end _ s -> do +peekNextWord = Get $ \end _ s -> do debugMId "peekNextWord" $ do let pTarget = currPtr s `plusPtr` 8 if ptrToWordPtr pTarget >= ptrToWordPtr end @@ -182,7 +182,7 @@ peekNextWord = Get \end _ s -> do peekUsedBits :: Get Word peekUsedBits = debugMId "peekUsedBits" $ do - Get \_ _ s -> pure (GetResult s (usedBits s)) + Get $ \_ _ s -> pure (GetResult s (usedBits s)) {-| Get a bit. @@ -219,7 +219,7 @@ dAtomBits :: Word -> Get Atom dAtomBits !(fromIntegral -> bits) = do debugMId ("dAtomBits(" <> show bits <> ")") $ do fmap (view $ from atomWords) $ - VP.generateM bufSize \i -> do + VP.generateM bufSize $ \i -> do debugM (show i) if (i == lastIdx && numExtraBits /= 0) then dWordBits (fromIntegral numExtraBits) diff --git a/pkg/hs-urbit/lib/Noun/Jam.hs b/pkg/hs-urbit/lib/Noun/Jam.hs index 5b9c94d7b..6e58a3bd5 100644 --- a/pkg/hs-urbit/lib/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Noun/Jam.hs @@ -2,18 +2,18 @@ module Noun.Jam (jam, jamBS) where import ClassyPrelude hiding (hash) -import Noun.Core import Noun.Atom +import Noun.Core -import Control.Lens (view, from) -import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.)) +import Control.Lens (from, view) +import Data.Bits (clearBit, setBit, shiftL, shiftR, (.|.)) import Data.Vector.Primitive ((!)) import Foreign.Marshal.Alloc (callocBytes, free) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (poke) -import GHC.Integer.GMP.Internals (BigNat) import GHC.Int (Int(I#)) -import GHC.Natural (Natural(NatS#, NatJ#)) +import GHC.Integer.GMP.Internals (BigNat) +import GHC.Natural (Natural(NatJ#, NatS#)) import GHC.Prim (Word#, plusWord#, word2Int#) import GHC.Word (Word(W#)) import System.IO.Unsafe (unsafePerformIO) @@ -64,7 +64,7 @@ newtype Put a = Put {-# INLINE getRef #-} getRef :: Put (Maybe Word) -getRef = Put \tbl s -> PutResult s <$> H.lookup tbl (pos s) +getRef = Put $ \tbl s -> PutResult s <$> H.lookup tbl (pos s) {- 1. Write the register to the output, and increment the output pointer. @@ -77,15 +77,15 @@ flush = Put $ \tbl s@S{..} -> do {-# INLINE update #-} update :: (S -> S) -> Put () -update f = Put \tbl s@S{..} -> pure (PutResult (f s) ()) +update f = Put $ \tbl s@S{..} -> pure (PutResult (f s) ()) {-# INLINE setRegOff #-} setRegOff :: Word -> Int -> Put () -setRegOff r o = update \s@S{..} -> (s {reg=r, off=o}) +setRegOff r o = update $ \s@S{..} -> (s {reg=r, off=o}) {-# INLINE setReg #-} setReg :: Word -> Put () -setReg r = update \s@S{..} -> (s { reg=r }) +setReg r = update $ \s@S{..} -> (s { reg=r }) {-# INLINE getS #-} getS :: Put S @@ -129,9 +129,9 @@ writeWord wor = do S{..} <- getS setReg (reg .|. shiftL wor off) flush - update \s -> s { pos = 64 + pos - , reg = shiftR wor (64 - off) - } + update $ \s -> s { pos = 64 + pos + , reg = shiftR wor (64 - off) + } {- To write some bits (< 64) from a word: @@ -182,7 +182,7 @@ writeAtomWord (W# w) = writeAtomWord# w writeAtomBigNat :: BigNat -> Put () writeAtomBigNat !(view bigNatWords -> words) = do let lastIdx = VP.length words - 1 - for_ [0..(lastIdx-1)] \i -> + for_ [0..(lastIdx-1)] $ \i -> writeWord (words ! i) writeAtomWord (words ! lastIdx) diff --git a/pkg/hs-urbit/lib/Noun/TH.hs b/pkg/hs-urbit/lib/Noun/TH.hs index e09f62264..652feaa62 100644 --- a/pkg/hs-urbit/lib/Noun/TH.hs +++ b/pkg/hs-urbit/lib/Noun/TH.hs @@ -4,10 +4,10 @@ module Noun.TH (deriveNoun) where -import ClassyPrelude hiding (fromList) -import Noun.Convert +import ClassyPrelude hiding (fromList) import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Noun.Convert import RIO (decodeUtf8Lenient) diff --git a/pkg/hs-urbit/lib/Urbit/Ames.hs b/pkg/hs-urbit/lib/Urbit/Ames.hs index 6de89654a..5a82288ae 100644 --- a/pkg/hs-urbit/lib/Urbit/Ames.hs +++ b/pkg/hs-urbit/lib/Urbit/Ames.hs @@ -5,8 +5,8 @@ module Urbit.Ames where import ClassyPrelude import Data.IP -import Noun import Network.Socket +import Noun import qualified Data.Vector as V import qualified Urbit.Time as Time @@ -17,11 +17,11 @@ import qualified Vere.Ames as VA data GalaxyInfo = GalaxyInfo { ip :: IPv4, age :: Time.Unix } data Ames = Ames - { live :: Bool -- ^ whether the listener is on - , ourPort :: Maybe Int + { live :: Bool -- ^ whether the listener is on + , ourPort :: Maybe Int -- , threadId :: Thread , globalDomain :: Maybe Text -- ^ something like "urbit.org" - , imperial :: V.Vector (Maybe GalaxyInfo) + , imperial :: V.Vector (Maybe GalaxyInfo) } init :: Ames @@ -52,7 +52,7 @@ ioStart ames isLocal defaultPort (Atom who) = do -- TODO: set up another thread to own the recv socket, which makes the Ovums -- which get put into the computeQueue, like in _ames_recv_cb. - withSocketsDo do + withSocketsDo $ do s <- socket AF_INET Datagram 17 -- bind s (SockAddrInet port ) pure () diff --git a/pkg/hs-urbit/lib/Urbit/Behn.hs b/pkg/hs-urbit/lib/Urbit/Behn.hs index a2555ddb8..c9a6c882f 100644 --- a/pkg/hs-urbit/lib/Urbit/Behn.hs +++ b/pkg/hs-urbit/lib/Urbit/Behn.hs @@ -16,18 +16,15 @@ until a new time has been set. -} -module Urbit.Behn (Behn, init, wait, doze) where +module Urbit.Behn (Behn(..), init, wait, doze) where -import Prelude hiding (init) import Control.Lens +import Prelude hiding (init) -import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar, putMVar) -import Control.Monad (void, when) -import Data.IORef (IORef, writeIORef, readIORef, newIORef) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) -import qualified Urbit.Timer as Timer import qualified Urbit.Time as Time -import qualified GHC.Event as Ev +import qualified Urbit.Timer as Timer -- Behn Stuff ------------------------------------------------------------------ diff --git a/pkg/hs-urbit/lib/Urbit/Time.hs b/pkg/hs-urbit/lib/Urbit/Time.hs index a743f4c48..39fa18c3b 100644 --- a/pkg/hs-urbit/lib/Urbit/Time.hs +++ b/pkg/hs-urbit/lib/Urbit/Time.hs @@ -2,15 +2,15 @@ module Urbit.Time where -import Prelude import Control.Lens +import Prelude -import Noun (FromNoun, ToNoun) import Data.Bits (shiftL, shiftR) import Data.Time.Clock (DiffTime, UTCTime) -import Data.Time.Clock (picosecondsToDiffTime, diffTimeToPicoseconds) +import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime) import Data.Time.Clock.System (SystemTime(..), getSystemTime) -import Data.Time.Clock.System (utcToSystemTime, systemToUTCTime) +import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime) +import Noun (FromNoun, ToNoun) -- Types ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Urbit/Timer.hs b/pkg/hs-urbit/lib/Urbit/Timer.hs index 1559feb8d..5a9c3eb68 100644 --- a/pkg/hs-urbit/lib/Urbit/Timer.hs +++ b/pkg/hs-urbit/lib/Urbit/Timer.hs @@ -1,16 +1,12 @@ -module Urbit.Timer ( Timer, init, stop, start +module Urbit.Timer ( Timer(..), init, stop, start , Sys.getSystemTime, sysTimeGapMicroSecs ) where -import Prelude hiding (init) -import Control.Lens import Data.IORef +import Prelude hiding (init) -import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar, putMVar) -import Control.Monad (void, when) - -import qualified GHC.Event as Ev import qualified Data.Time.Clock.System as Sys +import qualified GHC.Event as Ev -- Timer Stuff ----------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Ames.hs b/pkg/hs-urbit/lib/Vere/Ames.hs index 5dc781445..d24c68eb4 100644 --- a/pkg/hs-urbit/lib/Vere/Ames.hs +++ b/pkg/hs-urbit/lib/Vere/Ames.hs @@ -5,7 +5,7 @@ import Data.IP import Data.Void import Noun -import qualified Urbit.Time as Time +import qualified Urbit.Time as Time type Packet = ByteString diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index 235748e29..d3d68c657 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/pkg/hs-urbit/lib/Vere/Http.hs @@ -5,8 +5,8 @@ module Vere.Http where import ClassyPrelude import Noun -import qualified Data.CaseInsensitive as CI -import qualified Network.HTTP.Types as HT +import qualified Data.CaseInsensitive as CI +import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Method as H -------------------------------------------------------------------------------- @@ -26,7 +26,7 @@ data Request = Request data ResponseHeader = ResponseHeader { statusCode :: Word - , headers :: [Header] + , headers :: [Header] } deriving (Eq, Ord, Show) diff --git a/pkg/hs-urbit/lib/Vere/Http/Client.hs b/pkg/hs-urbit/lib/Vere/Http/Client.hs index 768f7b6e4..f5fa5d37b 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Client.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Client.hs @@ -50,7 +50,7 @@ cvtReq r = H.requestBody = H.RequestBodyBS $ case body r of Nothing -> "" - Just b -> b + Just b -> b } cvtRespHeaders :: H.Response a -> ResponseHeader diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index e49050f69..04060d3ad 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -8,7 +8,7 @@ import Control.Lens import Noun import Vere.Http -import Control.Concurrent (ThreadId, killThread, forkIO) +import Control.Concurrent (ThreadId, forkIO, killThread) import qualified Data.ByteString as BS import qualified Network.HTTP.Types as H @@ -110,7 +110,7 @@ app s req respond = bracket_ cookMeth :: W.Request -> Maybe Method cookMeth re = case H.parseMethod (W.requestMethod re) of - Left _ -> Nothing + Left _ -> Nothing Right m -> Just m data Octs = Octs Atom Atom diff --git a/pkg/hs-urbit/lib/Vere/Isle.hs b/pkg/hs-urbit/lib/Vere/Isle.hs index f18d90af6..bb23d63d7 100644 --- a/pkg/hs-urbit/lib/Vere/Isle.hs +++ b/pkg/hs-urbit/lib/Vere/Isle.hs @@ -1,15 +1,16 @@ +{-# OPTIONS_GHC -Wwarn #-} + module Vere.Isle where import ClassyPrelude import Data.Word -import qualified Vere.Isle.Util as C -import qualified SDL as SDL import qualified Data.Vector as V +import qualified SDL as SDL +import qualified Vere.Isle.Util as C import Data.Bits (testBit) import Data.Vector ((!)) -import Data.Flat (Flat) -------------------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Isle/Util.hs b/pkg/hs-urbit/lib/Vere/Isle/Util.hs index b99334e4c..f76d439e2 100644 --- a/pkg/hs-urbit/lib/Vere/Isle/Util.hs +++ b/pkg/hs-urbit/lib/Vere/Isle/Util.hs @@ -63,13 +63,13 @@ isContinue = maybe True (not . isQuitEvent) conditionallyRun :: (Monad m) => m a -> Bool -> m Bool -conditionallyRun f True = True <$ f +conditionallyRun f True = True <$ f conditionallyRun _ False = pure False isQuitEvent :: SDL.Event -> Bool isQuitEvent (SDL.Event _t SDL.QuitEvent) = True -isQuitEvent _ = False +isQuitEvent _ = False setHintQuality :: (MonadIO m) => m () diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index 8fda8daf8..c822d4694 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -106,7 +106,7 @@ readEvents (EventLog env) first len = found <- mdb_cursor_get MDB_SET_KEY cur pKey pVal assertErr found "mdb could not read initial event of sequence" - vec <- V.generateM (int len) \i -> do + vec <- V.generateM (int len) $ \i -> do key <- peek pKey >>= mdbValToWord64 val <- peek pVal >>= mdbValToAtom @@ -114,7 +114,7 @@ readEvents (EventLog env) first len = assertErr (key == idx) ("missing event in database " <> (show idx)) - when (i + 1 /= (int len)) do + when (i + 1 /= (int len)) $ do found <- mdb_cursor_get MDB_NEXT cur pKey pVal assertErr found "lmdb: next event not found" @@ -141,7 +141,7 @@ maybeErr Nothing msg = error msg byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a byteStringAsMdbVal bs k = - BU.unsafeUseAsCStringLen bs \(ptr,sz) -> + BU.unsafeUseAsCStringLen bs $ \(ptr,sz) -> k (MDB_val (fromIntegral sz) (castPtr ptr)) mdbValToWord64 :: MDB_val -> IO Word64 @@ -163,7 +163,7 @@ withWordPtr w cb = do get :: MDB_txn -> MDB_dbi -> ByteString -> IO Noun get txn db key = - byteStringAsMdbVal key \mKey -> + byteStringAsMdbVal key $ \mKey -> mdb_get txn db mKey >>= maybe (error "mdb bad get") mdbValToNoun mdbValToAtom :: MDB_val -> IO Atom diff --git a/pkg/hs-urbit/lib/Vere/Persist.hs b/pkg/hs-urbit/lib/Vere/Persist.hs index 8a6678f59..940235818 100644 --- a/pkg/hs-urbit/lib/Vere/Persist.hs +++ b/pkg/hs-urbit/lib/Vere/Persist.hs @@ -8,9 +8,9 @@ module Vere.Persist (start, stop) where import ClassyPrelude hiding (init) +import Database.LMDB.Raw import Vere.Log import Vere.Pier.Types -import Database.LMDB.Raw -- Types ----------------------------------------------------------------------- @@ -45,7 +45,7 @@ persistThread :: EventLog -> (Writ [Eff] -> STM ()) -> IO () persistThread (EventLog env) inputQueue onPersist = - forever do + forever $ do writs <- atomically $ readQueue inputQueue writeEvents writs atomically $ traverse_ onPersist writs diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index a0084fa0b..bd1b08aaf 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -1,11 +1,11 @@ module Vere.Pier.Types where import ClassyPrelude -import Noun import Database.LMDB.Raw +import Noun import Urbit.Time -import qualified Vere.Ames as Ames +import qualified Vere.Ames as Ames import qualified Vere.Http.Client as Client import qualified Vere.Http.Server as Server diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 80d34e495..73f9fe78a 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -14,7 +14,7 @@ import Data.ByteString (hGet) import Data.ByteString.Unsafe (unsafeUseAsCString) import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (castPtr) -import Foreign.Storable (poke, peek) +import Foreign.Storable (peek, poke) import System.Exit (ExitCode) import qualified Data.ByteString.Unsafe as BS @@ -220,7 +220,7 @@ replayEvents w (wid, wmug) identity lastCommitedId getEvents = do loop vLast curEvent = do traceM ("replayEvents.loop: " <> show curEvent) let toRead = min 1000 (1 + lastCommitedId - curEvent) - when (toRead > 0) do + when (toRead > 0) $ do traceM ("replayEvents.loop.getEvents " <> show toRead) events <- getEvents curEvent toRead @@ -264,7 +264,7 @@ replay w ident lastEv getEvents = do replayEvents w ws ident lastEv getEvents workerThread :: Serf -> STM Ovum -> (EventId, Mug) -> IO (Async ()) -workerThread w getEvent (evendId, mug) = async $ forever do +workerThread w getEvent (evendId, mug) = async $ forever $ do ovum <- atomically $ getEvent currentDate <- Time.now From 9872ea6e926c1ff26ac25b6b9d7022140ae5aed4 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 15 Jul 2019 17:01:45 -0700 Subject: [PATCH 107/431] Boot from a pill! --- pkg/hs-urbit/lib/Noun.hs | 14 +++ pkg/hs-urbit/lib/Noun/Conversions.hs | 43 +++++++-- pkg/hs-urbit/lib/Noun/Convert.hs | 13 ++- pkg/hs-urbit/lib/Noun/Cue.hs | 12 +-- pkg/hs-urbit/lib/UrbitPrelude.hs | 10 ++ pkg/hs-urbit/lib/Vere/Log.hs | 18 ++-- pkg/hs-urbit/lib/Vere/Pier.hs | 27 +++++- pkg/hs-urbit/lib/Vere/Pier/Types.hs | 114 +++++++++++++++-------- pkg/hs-urbit/lib/Vere/Serf.hs | 132 +++++++++++++++++---------- pkg/hs-urbit/package.yaml | 2 +- pkg/hs-vere/app/test/Main.hs | 24 ++++- 11 files changed, 294 insertions(+), 115 deletions(-) create mode 100644 pkg/hs-urbit/lib/UrbitPrelude.hs diff --git a/pkg/hs-urbit/lib/Noun.hs b/pkg/hs-urbit/lib/Noun.hs index d6408bfaa..4a559a361 100644 --- a/pkg/hs-urbit/lib/Noun.hs +++ b/pkg/hs-urbit/lib/Noun.hs @@ -7,6 +7,7 @@ module Noun , module Noun.Cue , module Noun.TH , _Cue + , loadFile ) where import ClassyPrelude @@ -27,3 +28,16 @@ _Cue = prism' jamBS (eitherToMaybe . cueBS) where eitherToMaybe (Left _) = Nothing eitherToMaybe (Right x) = Just x + +data LoadErr = CueErr DecodeErr + | ParseErr Text + deriving (Eq, Ord, Show) + +loadFile :: ∀a. FromNoun a => FilePath -> IO (Either LoadErr a) +loadFile pax = do + bs <- readFile pax + case cueBS bs of + Left e -> pure $ Left (CueErr e) + Right n -> case fromNounErr n of + Left e -> pure $ Left (ParseErr e) + Right x -> pure $ Right x diff --git a/pkg/hs-urbit/lib/Noun/Conversions.hs b/pkg/hs-urbit/lib/Noun/Conversions.hs index 41fc3ff15..925e13d9e 100644 --- a/pkg/hs-urbit/lib/Noun/Conversions.hs +++ b/pkg/hs-urbit/lib/Noun/Conversions.hs @@ -1,5 +1,6 @@ module Noun.Conversions ( Cord(..), Knot(..), Term(..), Tank(..), Tang, Plum(..), Nullable + , Mug(..), Path(..), Word512 ) where import ClassyPrelude hiding (hash) @@ -11,6 +12,7 @@ import Noun.Atom import Noun.Convert import Noun.Core import Noun.TH +import Data.LargeWord (Word128, Word256, LargeKey) import GHC.Natural (Natural) import RIO (decodeUtf8Lenient) @@ -25,20 +27,21 @@ instance Show Noun where Cell x y -> fmtCell (show <$> (x : toTuple y)) where fmtCell :: [String] -> String - fmtCell xs = "[" <> intercalate " " xs <> "]" + fmtCell xs = "(" <> intercalate ", " xs <> ")" toTuple :: Noun -> [Noun] toTuple (Cell x xs) = x : toTuple xs toTuple atom = [atom] showAtom :: Atom -> String - showAtom 0 = "0" + showAtom 0 = "()" + showAtom a | a >= 2^1024 = "\"...\"" showAtom a = let mTerm = do t <- fromNoun (Atom a) let ok = \x -> (x=='-' || C.isAlphaNum x) guard (all ok (t :: Text)) - pure ("%" <> unpack t) + pure ("\"" <> unpack t <> "\"") in case mTerm of Nothing -> show a @@ -71,6 +74,8 @@ newtype Tour = Tour [Char] -- Atom or Cell ---------------------------------------------------------------- +type Word512 = LargeKey Word256 Word256 + data AtomCell a c = ACAtom a | ACCell c @@ -134,10 +139,9 @@ newtype Tape = Tape [Char] type Tang = [Tank] -type Tank = AtomCell Tape TankTree - -data TankTree - = Plum Plum +data Tank + = Leaf Tape + | Plum Plum | Palm (Tape, Tape, Tape, Tape) [Tank] | Rose (Tape, Tape, Tape) [Tank] deriving (Eq, Ord, Show) @@ -162,7 +166,7 @@ data PlumTree deriveNoun ''WideFmt deriveNoun ''TallFmt deriveNoun ''PlumFmt -deriveNoun ''TankTree +deriveNoun ''Tank deriveNoun ''PlumTree @@ -215,7 +219,7 @@ instance FromNoun Term where -- XX TODO -- Knot ------------------------------------------------------------------------ newtype Knot = MkKnot Text - deriving newtype (Eq, Ord, Show) + deriving newtype (Eq, Ord, Show, Semigroup, Monoid, IsString) instance ToNoun Knot where -- XX TODO toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t)) @@ -226,6 +230,21 @@ instance FromNoun Knot where -- XX TODO pure (MkKnot (decodeUtf8Lenient c)) +-- Path ------------------------------------------------------------------------ + +newtype Path = Path [Knot] + deriving newtype (Eq, Ord, Semigroup, Monoid, ToNoun, FromNoun) + +instance Show Path where + show (Path ks) = show $ intercalate "/" ("" : ks) + + +-- Mug ------------------------------------------------------------------------- + +newtype Mug = Mug Word32 + deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun) + + -- Bool ------------------------------------------------------------------------ instance ToNoun Bool where @@ -267,12 +286,18 @@ instance ToNoun Word8 where toNoun = wordToNoun instance ToNoun Word16 where toNoun = wordToNoun instance ToNoun Word32 where toNoun = wordToNoun instance ToNoun Word64 where toNoun = wordToNoun +instance ToNoun Word128 where toNoun = wordToNoun +instance ToNoun Word256 where toNoun = wordToNoun +instance ToNoun Word512 where toNoun = wordToNoun instance FromNoun Word where parseNoun = nounToWord instance FromNoun Word8 where parseNoun = nounToWord instance FromNoun Word16 where parseNoun = nounToWord instance FromNoun Word32 where parseNoun = nounToWord instance FromNoun Word64 where parseNoun = nounToWord +instance FromNoun Word128 where parseNoun = nounToWord +instance FromNoun Word256 where parseNoun = nounToWord +instance FromNoun Word512 where parseNoun = nounToWord -- Maybe is `unit` ------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Noun/Convert.hs b/pkg/hs-urbit/lib/Noun/Convert.hs index f988d20e9..d0106ed5a 100644 --- a/pkg/hs-urbit/lib/Noun/Convert.hs +++ b/pkg/hs-urbit/lib/Noun/Convert.hs @@ -1,6 +1,6 @@ module Noun.Convert ( ToNoun(toNoun) - , FromNoun(parseNoun), fromNoun, fromNounErr + , FromNoun(parseNoun), fromNoun, fromNounErr, fromNounExn , Parser(..) , CellIdx, NounPath , Cord(..) @@ -164,6 +164,17 @@ fromNounErr n = runParser (parseNoun n) [] onFail onSuccess onFail p m = Left (pack m) onSuccess x = Right x +data BadNoun = BadNoun String + deriving (Eq, Ord, Show) + +instance Exception BadNoun where + +fromNounExn :: FromNoun a => Noun -> IO a +fromNounExn n = runParser (parseNoun n) [] onFail onSuccess + where + onFail p m = throwIO (BadNoun m) + onSuccess x = pure x + -- Cord Conversions ------------------------------------------------------------ diff --git a/pkg/hs-urbit/lib/Noun/Cue.hs b/pkg/hs-urbit/lib/Noun/Cue.hs index e74cc8de9..bb09356b8 100644 --- a/pkg/hs-urbit/lib/Noun/Cue.hs +++ b/pkg/hs-urbit/lib/Noun/Cue.hs @@ -1,4 +1,4 @@ -module Noun.Cue (cue, cueBS) where +module Noun.Cue (cue, cueBS, DecodeErr) where import ClassyPrelude @@ -21,10 +21,10 @@ import qualified Data.Vector.Primitive as VP -------------------------------------------------------------------------------- -cueBS :: ByteString -> Either DecodeExn Noun +cueBS :: ByteString -> Either DecodeErr Noun cueBS = doGet dNoun -cue :: Atom -> Either DecodeExn Noun +cue :: Atom -> Either DecodeErr Noun cue = cueBS . view atomBytes @@ -57,7 +57,7 @@ data S = S type Env = (Ptr Word, S) -data DecodeExn +data DecodeErr = NotEnoughSpace Env | TooMuchSpace Env | BadEncoding Env String @@ -73,7 +73,7 @@ newtype Get a = Get -> IO (GetResult a) } -doGet :: Get a -> ByteString -> Either DecodeExn a +doGet :: Get a -> ByteString -> Either DecodeErr a doGet m bs = unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do let endPtr = ptr `plusPtr` len @@ -86,7 +86,7 @@ doGet m bs = -------------------------------------------------------------------------------- -instance Exception DecodeExn +instance Exception DecodeErr instance Functor Get where fmap f g = Get $ \end tbl s -> do diff --git a/pkg/hs-urbit/lib/UrbitPrelude.hs b/pkg/hs-urbit/lib/UrbitPrelude.hs new file mode 100644 index 000000000..59344b52e --- /dev/null +++ b/pkg/hs-urbit/lib/UrbitPrelude.hs @@ -0,0 +1,10 @@ +module UrbitPrelude + ( module ClassyPrelude + , module Control.Lens + , module Noun + ) where + +import ClassyPrelude +import Control.Lens hiding (Index, cons, index, snoc, uncons, unsnoc, (<.>), + (<|)) +import Noun diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index c822d4694..573edf432 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -48,22 +48,22 @@ close (EventLog env) = mdb_env_close env readIdent :: EventLog -> IO LogIdentity readIdent (EventLog env) = do - txn <- mdb_txn_begin env Nothing True - db <- mdb_dbi_open txn (Just "META") [] - who <- get txn db "who" - is_fake <- get txn db "is-fake" - life <- get txn db "life" + txn <- mdb_txn_begin env Nothing True + db <- mdb_dbi_open txn (Just "META") [] + who <- get txn db "who" + fake <- get txn db "is-fake" + life <- get txn db "life" mdb_txn_abort txn - pure (LogIdentity who is_fake life) + fromNounExn $ toNoun (who, fake, life) writeIdent :: EventLog -> LogIdentity -> IO () writeIdent (EventLog env) LogIdentity{..} = do txn <- mdb_txn_begin env Nothing False db <- mdb_dbi_open txn (Just "META") [MDB_CREATE] let flags = compileWriteFlags [] - putNoun flags txn db "who" who - putNoun flags txn db "is-fake" is_fake - putNoun flags txn db "life" life + putNoun flags txn db "who" $ toNoun who + putNoun flags txn db "is-fake" $ toNoun isFake + putNoun flags txn db "life" $ toNoun lifecycleLen mdb_txn_commit txn pure () diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 0d5a3c029..17b200cc3 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -1,11 +1,14 @@ +{-# OPTIONS_GHC -Wwarn #-} + module Vere.Pier where -import ClassyPrelude +import UrbitPrelude import Vere.Pier.Types -import qualified Vere.Log as Log -import qualified Vere.Serf as Serf +import qualified System.Entropy as Ent +import qualified Vere.Log as Log +import qualified Vere.Serf as Serf import Vere.Serf (EventId, Serf) @@ -15,6 +18,24 @@ import Vere.Serf (EventId, Serf) ioDrivers = [] :: [IODriver] +-------------------------------------------------------------------------------- + +genEntropy :: IO Word512 +genEntropy = fromIntegral . view (from atomBytes) <$> Ent.getEntropy 64 + +generateBootSeq :: Ship -> Pill -> IO BootSeq +generateBootSeq ship Pill{..} = do + ent <- genEntropy + let ovums = preKern ent <> pKernelOvums <> pUserspaceOvums + pure $ BootSeq ident pBootFormulas ovums + where + ident = LogIdentity ship True (fromIntegral $ length pBootFormulas) + preKern ent = [ Ovum (Path ["", "term", "1"]) (Boot $ Fake $ who ident) + , Ovum (Path ["", "arvo"]) (Whom ship) + , Ovum (Path ["", "arvo"]) (Wack ent) + ] + + -------------------------------------------------------------------------------- -- This is called to make a freshly booted pier. It assigns an identity to an diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index bd1b08aaf..59a2caa68 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs @@ -1,30 +1,74 @@ +{-# LANGUAGE UndecidableInstances #-} + module Vere.Pier.Types where -import ClassyPrelude +import UrbitPrelude + import Database.LMDB.Raw -import Noun import Urbit.Time +import Data.LargeWord (Word128) +import Data.Void (Void) + import qualified Vere.Ames as Ames import qualified Vere.Http.Client as Client import qualified Vere.Http.Server as Server -------------------------------------------------------------------------------- +newtype Ship = Ship Word128 -- @p + deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun) + +newtype ShipId = ShipId (Ship, Bool) + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) + +newtype FileOcts = FileOcts ByteString + deriving newtype (Eq, Ord, ToNoun, FromNoun) + +newtype BigTape = BigTape Text + deriving newtype (Eq, Ord, ToNoun, FromNoun) + +data LegacyBootEvent + = Fake Ship + | Dawn Void + deriving (Eq, Ord, Show) + +newtype Nock = Nock Noun + deriving newtype (Eq, Ord, FromNoun, ToNoun) + +data Pill = Pill + { pBootFormulas :: [Nock] + , pKernelOvums :: [Ovum] + , pUserspaceOvums :: [Ovum] + } + deriving (Eq, Ord) + +data BootSeq = BootSeq LogIdentity [Nock] [Ovum] + deriving (Eq, Ord, Show) + +newtype Desk = Desk Text + deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) + +data LogIdentity = LogIdentity + { who :: Ship + , isFake :: Bool + , lifecycleLen :: Atom + } deriving (Eq, Ord, Show) + +data Mime = Mime Path FileOcts + deriving (Eq, Ord, Show) + data Event - = BehnBorn - | HttpBorn - | CttpBorn + = Veer Cord Path BigTape + | Into Desk Bool [(Path, Maybe Mime)] + | Whom Ship + | Boot LegacyBootEvent + | Wack Word512 deriving (Eq, Ord, Show) data PutDel = Put | Del deriving (Eq, Ord, Show) -data EffBs - = EBAsdf Word - | EBLolr Word Word - deriving (Eq, Ord, Show) - data RecEx = RE Word Word deriving (Eq, Ord, Show) @@ -63,9 +107,6 @@ data Eff | Woot Noun deriving (Eq, Ord, Show) -newtype Path = Path [Knot] - deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) - data Blit = Bel | Clr @@ -84,18 +125,6 @@ type Perform = Eff -> IO () data Ovum = Ovum Path Event deriving (Eq, Ord, Show) -newtype Mug = Mug Word32 - deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) - -deriveNoun ''Blit -deriveNoun ''Eff -deriveNoun ''Event -deriveNoun ''PutDel -deriveNoun ''EffBs -deriveNoun ''RecEx -deriveNoun ''NewtEx -deriveNoun ''Ovum - newtype Jam = Jam Atom data IODriver = IODriver @@ -121,16 +150,29 @@ data Pier = Pier newtype EventLog = EventLog MDB_env -data LogIdentity = LogIdentity - { who :: Noun - , is_fake :: Noun - , life :: Noun - } deriving (Show) -instance ToNoun LogIdentity where - toNoun LogIdentity{..} = toNoun (who, is_fake, life) +-- Instances ------------------------------------------------------------------- -instance FromNoun LogIdentity where - parseNoun n = do - (who, is_fake, life) <- parseNoun n - pure (LogIdentity{..}) +instance Show FileOcts where + show (FileOcts bs) = show (take 32 bs <> "...") + +instance Show BigTape where + show (BigTape t) = show (take 32 t <> "...") + +instance Show Nock where + show _ = "Nock" + +instance Show Pill where + show (Pill x y z) = show (length x, length y, length z) + +deriveNoun ''Mime +deriveNoun ''Pill +deriveNoun ''LegacyBootEvent +deriveNoun ''Blit +deriveNoun ''Eff +deriveNoun ''Event +deriveNoun ''NewtEx +deriveNoun ''Ovum +deriveNoun ''PutDel +deriveNoun ''RecEx +deriveNoun ''LogIdentity diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 73f9fe78a..ad0774d9a 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -73,14 +73,22 @@ newtype Job = Job Void type EventId = Word64 -newtype Ship = Ship Word64 -- @p - deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) - -newtype ShipId = ShipId (Ship, Bool) - deriving newtype (Eq, Ord, Show, ToNoun, FromNoun) - -------------------------------------------------------------------------------- +data Order + = OBoot LogIdentity + | OExit Word8 + | OSave EventId + | OWork EventId Atom + deriving (Eq, Ord, Show) + +-- XX TODO Support prefixes in deriveNoun +instance ToNoun Order where + toNoun (OBoot id) = toNoun (Cord "boot", id) + toNoun (OExit cod) = toNoun (Cord "exit", cod) + toNoun (OSave id) = toNoun (Cord "save", id) + toNoun (OWork w a) = toNoun (Cord "work", w, a) + type Play = Maybe (EventId, Mug, ShipId) data Plea @@ -91,34 +99,16 @@ data Plea | Slog EventId Word32 Tank deriving (Eq, Show) -instance ToNoun Plea where - toNoun = \case - Play p -> toNoun (Cord "play", p) - Work i m j -> toNoun (Cord "work", i, m, j) - Done i m o -> toNoun (Cord "done", i, m, o) - Stdr i msg -> toNoun (Cord "stdr", i, msg) - Slog i p t -> toNoun (Cord "slog", i, p, t) - -instance FromNoun Plea where - parseNoun n = - parseNoun n >>= \case - (Cord "play", p) -> parseNoun p <&> \p -> Play p - (Cord "work", w) -> parseNoun w <&> \(i, m, j) -> Work i m j - (Cord "done", d) -> parseNoun d <&> \(i, m, o) -> Done i m o - (Cord "stdr", r) -> parseNoun r <&> \(i, msg) -> Stdr i msg - (Cord "slog", s) -> parseNoun s <&> \(i, p, t) -> Slog i p t - (Cord tag , s) -> fail ("Invalid plea tag: " <> unpack (decodeUtf8 tag)) +deriveNoun ''Plea -------------------------------------------------------------------------------- type CompletedEventId = Word64 -type NextEventId = Word64 - -type SerfState = (EventId, Mug) - -type ReplacementEv = (EventId, Mug, Job) -type WorkResult = (EventId, Mug, [(Path, Eff)]) -type SerfResp = (Either ReplacementEv WorkResult) +type NextEventId = Word64 +type SerfState = (EventId, Mug) +type ReplacementEv = (EventId, Mug, Job) +type WorkResult = (EventId, Mug, [(Path, Eff)]) +type SerfResp = (Either ReplacementEv WorkResult) -- Exceptions ------------------------------------------------------------------ @@ -129,6 +119,8 @@ data SerfExn | BadPleaAtom Atom | BadPleaNoun Noun Text | ReplacedEventDuringReplay EventId ReplacementEv + | ReplacedEventDuringBoot EventId ReplacementEv + | EffectsDuringBoot EventId [(Path, Eff)] | SerfConnectionClosed | UnexpectedPleaOnNewShip Plea | InvalidInitialPlea Plea @@ -158,16 +150,7 @@ sendAndRecv :: Serf -> EventId -> Atom -> IO SerfResp sendAndRecv w eventId event = do traceM ("sendAndRecv: " <> show eventId) - - -- traceM ("") - -- traceM (maybe "bad cue" showNoun $ cue event) - -- traceM ("") - - traceM ("") - wEv <- evaluate $ force $ work eventId (Jam event) - traceM ("") - - sendAtom w wEv + sendOrder w (OWork eventId event) res <- loop traceM ("sendAndRecv.done " <> show res) pure res @@ -190,10 +173,67 @@ sendAndRecv w eventId event = Stdr _ cord -> putStrLn (pack ("[SERF] " <> cordString cord)) >> loop Slog _ pri t -> printTank pri t >> loop -sendBootEvent :: LogIdentity -> Serf -> IO () -sendBootEvent id w = do - sendAtom w $ jam $ toNoun (Cord "boot", id) +sendAndRecvOrder :: Serf -> EventId -> Order -> IO SerfResp +sendAndRecvOrder w eventId order = + do + traceM ("sendAndRecvOrder: " <> show eventId) + sendOrder w order + res <- loop + traceM ("sendAndRecvOrder.done " <> show res) + pure res + where + produce :: WorkResult -> IO SerfResp + produce (i, m, o) = do + guardExn (i == eventId) (BadComputeId eventId (i, m, o)) + pure $ Right (i, m, o) + + replace :: ReplacementEv -> IO SerfResp + replace (i, m, j) = do + guardExn (i == eventId) (BadReplacementId eventId (i, m, j)) + pure (Left (i, m, j)) + + loop :: IO SerfResp + loop = recvPlea w >>= \case + Play p -> throwIO (UnexpectedPlay eventId p) + Done i m o -> produce (i, m, o) + Work i m j -> replace (i, m, j) + Stdr _ cord -> putStrLn (pack ("[SERF] " <> cordString cord)) >> loop + Slog _ pri t -> printTank pri t >> loop + +sendOrder :: Serf -> Order -> IO () +sendOrder w o = sendAtom w $ jam $ toNoun o + +muckBootSeq :: BootSeq -> [EventId -> Mug -> Time.Wen -> Order] +muckBootSeq (BootSeq _ nocks ovums) = + (muckNock <$> nocks) <> (muckOvum <$> ovums) + where + muckNock nok eId mug _ = OWork eId $ jam $ toNoun (mug, nok) + muckOvum ov eId mug wen = OWork eId $ jam $ toNoun (mug, wen, ov) + +bootFromSeq :: Serf -> LogIdentity -> [EventId -> Mug -> Time.Wen -> Order] + -> IO [Order] +bootFromSeq w ident seq = do + ws@(eventId, mug) <- recvPlea w >>= \case + Play Nothing -> pure (1, Mug 0) + Play (Just (e, m, _)) -> error "ship already booted" + x -> throwIO (InvalidInitialPlea x) + + traceM ("got plea! " <> show eventId <> " " <> show mug) + + sendOrder w (OBoot ident) + loop [] 1 (Mug 0) seq + + where + loop acc eId lastMug [] = pure $ reverse acc + loop acc eId lastMug (x:xs) = do + wen <- Time.now + let order = x eId lastMug wen + sendAndRecvOrder w eId order >>= \case + Left badEv -> throwIO (ReplacedEventDuringBoot eId badEv) + Right (id, newMug, f:fs) -> throwIO (EffectsDuringBoot eId (f:fs)) + Right (id, newMug, []) -> do + loop (order : acc) (eId+1) newMug xs -- the ship is booted, but it is behind. shove events to the worker until it is -- caught up. @@ -203,10 +243,10 @@ replayEvents :: Serf -> EventId -> (EventId -> Word64 -> IO (Vector (EventId, Atom))) -> IO (EventId, Mug) -replayEvents w (wid, wmug) identity lastCommitedId getEvents = do +replayEvents w (wid, wmug) ident lastCommitedId getEvents = do traceM ("replayEvents: " <> show wid <> " " <> show wmug) - when (wid == 1) (sendBootEvent identity w) + when (wid == 1) (sendOrder w $ OBoot ident) vLast <- newIORef (wid, wmug) loop vLast wid @@ -229,7 +269,7 @@ replayEvents w (wid, wmug) identity lastCommitedId getEvents = do for_ events $ \(eventId, event) -> do sendAndRecv w eventId event >>= \case - Left ev -> throwIO (ReplacedEventDuringReplay eventId ev) + Left ev -> throwIO (ReplacedEventDuringReplay eventId ev) Right (id, mug, _) -> writeIORef vLast (id, mug) loop vLast (curEvent + toRead) diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 0309f97e9..d035ae451 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -19,12 +19,12 @@ dependencies: - classy-prelude - containers - data-fix + - entropy - extra - fixed-vector - flat - ghc-prim - hashable - - hashable - hashtables - http-client - http-types diff --git a/pkg/hs-vere/app/test/Main.hs b/pkg/hs-vere/app/test/Main.hs index e879466db..cf728485a 100644 --- a/pkg/hs-vere/app/test/Main.hs +++ b/pkg/hs-vere/app/test/Main.hs @@ -1,22 +1,38 @@ module Main where import ClassyPrelude + +import Noun import Vere.Pier.Types +import Vere.Pier +import Vere.Serf + +import Text.Show.Pretty (pPrint) import qualified Vere.Log as Log import qualified Vere.Persist as Persist import qualified Vere.Pier as Pier - -------------------------------------------------------------------------------- main :: IO () main = do - (s,l,e,m) <- Pier.resume "/home/benjamin/r/urbit/zod/" + p <- loadFile @Pill "/home/benjamin/r/urbit/bin/brass.pill" >>= \case + Left l -> error (show l) + Right p -> pure p - putStrLn "Resumed!" + pPrint p - pure () + seq@(BootSeq ident _ _) <- generateBootSeq 0 p + pPrint seq + + serf <- startSerfProcess "/home/benjamin/r/urbit/zod/" + bootFromSeq serf ident (muckBootSeq seq) >>= pPrint + + -- (s,l,e,m) <- Pier.resume "/home/benjamin/r/urbit/zod/" + -- putStrLn "Resumed!" + + pure () -------------------------------------------------------------------------------- From 430b180f0cb493f9b28dac5f8f760fc6962c3d97 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 15 Jul 2019 17:05:42 -0700 Subject: [PATCH 108/431] Minor cleanup --- pkg/hs-urbit/lib/Vere/Serf.hs | 77 ++++++++++++++--------------------- 1 file changed, 31 insertions(+), 46 deletions(-) diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index ad0774d9a..386d28e7b 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -146,41 +146,13 @@ fromRightExn (Right x) _ = pure x -------------------------------------------------------------------------------- -sendAndRecv :: Serf -> EventId -> Atom -> IO SerfResp -sendAndRecv w eventId event = +sendAndRecv :: Serf -> EventId -> Order -> IO SerfResp +sendAndRecv w eventId order = do traceM ("sendAndRecv: " <> show eventId) - sendOrder w (OWork eventId event) - res <- loop - traceM ("sendAndRecv.done " <> show res) - pure res - where - produce :: WorkResult -> IO SerfResp - produce (i, m, o) = do - guardExn (i == eventId) (BadComputeId eventId (i, m, o)) - pure $ Right (i, m, o) - - replace :: ReplacementEv -> IO SerfResp - replace (i, m, j) = do - guardExn (i == eventId) (BadReplacementId eventId (i, m, j)) - pure (Left (i, m, j)) - - loop :: IO SerfResp - loop = recvPlea w >>= \case - Play p -> throwIO (UnexpectedPlay eventId p) - Done i m o -> produce (i, m, o) - Work i m j -> replace (i, m, j) - Stdr _ cord -> putStrLn (pack ("[SERF] " <> cordString cord)) >> loop - Slog _ pri t -> printTank pri t >> loop - -sendAndRecvOrder :: Serf -> EventId -> Order -> IO SerfResp -sendAndRecvOrder w eventId order = - do - traceM ("sendAndRecvOrder: " <> show eventId) - sendOrder w order res <- loop - traceM ("sendAndRecvOrder.done " <> show res) + traceM ("sendAndRecv.done " <> show res) pure res where produce :: WorkResult -> IO SerfResp @@ -211,29 +183,42 @@ muckBootSeq (BootSeq _ nocks ovums) = muckNock nok eId mug _ = OWork eId $ jam $ toNoun (mug, nok) muckOvum ov eId mug wen = OWork eId $ jam $ toNoun (mug, wen, ov) -bootFromSeq :: Serf -> LogIdentity -> [EventId -> Mug -> Time.Wen -> Order] - -> IO [Order] -bootFromSeq w ident seq = do - ws@(eventId, mug) <- recvPlea w >>= \case +{- + Waits for initial plea, and then sends boot IPC if necessary. +-} +handshake :: Serf -> LogIdentity -> IO (EventId, Mug) +handshake serf ident = do + (eventId, mug) <- recvPlea serf >>= \case Play Nothing -> pure (1, Mug 0) - Play (Just (e, m, _)) -> error "ship already booted" + Play (Just (e, m, _)) -> pure (e, m) x -> throwIO (InvalidInitialPlea x) - traceM ("got plea! " <> show eventId <> " " <> show mug) + traceM ("handshake: got plea! " <> show eventId <> " " <> show mug) + + when (eventId == 1) $ do + sendOrder serf (OBoot ident) + traceM ("handshake: Sent %boot IPC") + + pure (eventId, mug) + +bootFromSeq :: Serf -> LogIdentity -> [EventId -> Mug -> Time.Wen -> Order] + -> IO [Order] +bootFromSeq serf ident seq = do + handshake serf ident >>= \case + (1, Mug 0) -> pure () + _ -> error "ship already booted" - sendOrder w (OBoot ident) loop [] 1 (Mug 0) seq where loop acc eId lastMug [] = pure $ reverse acc loop acc eId lastMug (x:xs) = do - wen <- Time.now - let order = x eId lastMug wen - sendAndRecvOrder w eId order >>= \case - Left badEv -> throwIO (ReplacedEventDuringBoot eId badEv) - Right (id, newMug, f:fs) -> throwIO (EffectsDuringBoot eId (f:fs)) - Right (id, newMug, []) -> do - loop (order : acc) (eId+1) newMug xs + wen <- Time.now + let order = x eId lastMug wen + sendAndRecv serf eId order >>= \case + Left badEv -> throwIO (ReplacedEventDuringBoot eId badEv) + Right (id, mug, []) -> loop (order : acc) (eId+1) mug xs + Right (id, mug, fx) -> throwIO (EffectsDuringBoot eId fx) -- the ship is booted, but it is behind. shove events to the worker until it is -- caught up. @@ -268,7 +253,7 @@ replayEvents w (wid, wmug) ident lastCommitedId getEvents = do traceM ("got events " <> show (length events)) for_ events $ \(eventId, event) -> do - sendAndRecv w eventId event >>= \case + sendAndRecv w eventId (OWork eventId event) >>= \case Left ev -> throwIO (ReplacedEventDuringReplay eventId ev) Right (id, mug, _) -> writeIORef vLast (id, mug) From 8781e7e64855bbbbd8ce7621c3eea2bea6742366 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 15 Jul 2019 17:23:48 -0700 Subject: [PATCH 109/431] More cleanup. --- pkg/hs-urbit/lib/Vere/Serf.hs | 68 ++++++++++++++++++++--------------- pkg/hs-vere/app/test/Main.hs | 2 +- 2 files changed, 40 insertions(+), 30 deletions(-) diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 386d28e7b..4dad443ff 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -176,41 +176,27 @@ sendAndRecv w eventId order = sendOrder :: Serf -> Order -> IO () sendOrder w o = sendAtom w $ jam $ toNoun o -muckBootSeq :: BootSeq -> [EventId -> Mug -> Time.Wen -> Order] -muckBootSeq (BootSeq _ nocks ovums) = - (muckNock <$> nocks) <> (muckOvum <$> ovums) - where - muckNock nok eId mug _ = OWork eId $ jam $ toNoun (mug, nok) - muckOvum ov eId mug wen = OWork eId $ jam $ toNoun (mug, wen, ov) - -{- - Waits for initial plea, and then sends boot IPC if necessary. --} -handshake :: Serf -> LogIdentity -> IO (EventId, Mug) -handshake serf ident = do - (eventId, mug) <- recvPlea serf >>= \case - Play Nothing -> pure (1, Mug 0) - Play (Just (e, m, _)) -> pure (e, m) - x -> throwIO (InvalidInitialPlea x) - - traceM ("handshake: got plea! " <> show eventId <> " " <> show mug) - - when (eventId == 1) $ do - sendOrder serf (OBoot ident) - traceM ("handshake: Sent %boot IPC") - - pure (eventId, mug) - -bootFromSeq :: Serf -> LogIdentity -> [EventId -> Mug -> Time.Wen -> Order] - -> IO [Order] -bootFromSeq serf ident seq = do +bootFromSeq :: Serf -> BootSeq -> IO [Order] +bootFromSeq serf (BootSeq ident nocks ovums) = do handshake serf ident >>= \case (1, Mug 0) -> pure () _ -> error "ship already booted" - loop [] 1 (Mug 0) seq + res <- loop [] 1 (Mug 0) seq + + OWork lastEv _ : _ <- evaluate (reverse res) + + traceM "Requesting snapshot" + sendOrder serf (OSave lastEv) + + traceM "Requesting shutdown" + sendOrder serf (OExit 0) + + pure res where + loop :: [Order] -> EventId -> Mug -> [EventId -> Mug -> Time.Wen -> Order] + -> IO [Order] loop acc eId lastMug [] = pure $ reverse acc loop acc eId lastMug (x:xs) = do wen <- Time.now @@ -220,6 +206,12 @@ bootFromSeq serf ident seq = do Right (id, mug, []) -> loop (order : acc) (eId+1) mug xs Right (id, mug, fx) -> throwIO (EffectsDuringBoot eId fx) + seq :: [EventId -> Mug -> Time.Wen -> Order] + seq = fmap muckNock nocks <> fmap muckOvum ovums + where + muckNock nok eId mug _ = OWork eId $ jam $ toNoun (mug, nok) + muckOvum ov eId mug wen = OWork eId $ jam $ toNoun (mug, wen, ov) + -- the ship is booted, but it is behind. shove events to the worker until it is -- caught up. replayEvents :: Serf @@ -277,6 +269,24 @@ bootSerf w ident pill = type GetEvents = EventId -> Word64 -> IO (Vector (EventId, Atom)) +{- + Waits for initial plea, and then sends boot IPC if necessary. +-} +handshake :: Serf -> LogIdentity -> IO (EventId, Mug) +handshake serf ident = do + (eventId, mug) <- recvPlea serf >>= \case + Play Nothing -> pure (1, Mug 0) + Play (Just (e, m, _)) -> pure (e, m) + x -> throwIO (InvalidInitialPlea x) + + traceM ("handshake: got plea! " <> show eventId <> " " <> show mug) + + when (eventId == 1) $ do + sendOrder serf (OBoot ident) + traceM ("handshake: Sent %boot IPC") + + pure (eventId, mug) + replay :: Serf -> LogIdentity -> EventId -> GetEvents -> IO (EventId, Mug) replay w ident lastEv getEvents = do ws@(eventId, mug) <- recvPlea w >>= \case diff --git a/pkg/hs-vere/app/test/Main.hs b/pkg/hs-vere/app/test/Main.hs index cf728485a..e2ca534fc 100644 --- a/pkg/hs-vere/app/test/Main.hs +++ b/pkg/hs-vere/app/test/Main.hs @@ -27,7 +27,7 @@ main = do pPrint seq serf <- startSerfProcess "/home/benjamin/r/urbit/zod/" - bootFromSeq serf ident (muckBootSeq seq) >>= pPrint + bootFromSeq serf seq >>= pPrint -- (s,l,e,m) <- Pier.resume "/home/benjamin/r/urbit/zod/" -- putStrLn "Resumed!" From 4f698bce8f5e22ff70d2b23eaf0d0681f2cba37a Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Mon, 15 Jul 2019 19:20:23 -0700 Subject: [PATCH 110/431] Fill in event log on boot + cleanup. --- pkg/hs-urbit/lib/Vere/Log.hs | 4 ++ pkg/hs-urbit/lib/Vere/Persist.hs | 15 +++++++- pkg/hs-urbit/lib/Vere/Pier.hs | 35 +++++++++++++---- pkg/hs-urbit/lib/Vere/Serf.hs | 65 ++++++++------------------------ pkg/hs-urbit/package.yaml | 1 + pkg/hs-vere/app/test/Main.hs | 27 +++++++++---- pkg/hs-vere/package.yaml | 1 + 7 files changed, 84 insertions(+), 64 deletions(-) diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index 573edf432..708812174 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/pkg/hs-urbit/lib/Vere/Log.hs @@ -10,6 +10,7 @@ module Vere.Log ( open , readIdent , writeIdent , putJam + , wipeEvents , deleteEventAndEverythingAfterIt ) where @@ -199,6 +200,9 @@ putJam flags txn db id (Jam atom) = do -- Event Pruning --------------------------------------------------------------- +wipeEvents :: FilePath -> IO () +wipeEvents pax = deleteEventAndEverythingAfterIt pax 1 + deleteEventAndEverythingAfterIt :: FilePath -> Word64 -> IO () deleteEventAndEverythingAfterIt dir first = runInBoundThread $ do diff --git a/pkg/hs-urbit/lib/Vere/Persist.hs b/pkg/hs-urbit/lib/Vere/Persist.hs index 940235818..571570831 100644 --- a/pkg/hs-urbit/lib/Vere/Persist.hs +++ b/pkg/hs-urbit/lib/Vere/Persist.hs @@ -4,11 +4,12 @@ the thread should close the database when it is killed. -} -module Vere.Persist (start, stop) where +module Vere.Persist (start, stop, writeEvents) where import ClassyPrelude hiding (init) import Database.LMDB.Raw +import Noun import Vere.Log import Vere.Pier.Types @@ -61,6 +62,18 @@ persistThread (EventLog env) inputQueue onPersist = mdb_txn_commit txn +writeEvents :: EventLog -> [(Word64, Atom)] -> IO () +writeEvents (EventLog env) writs = do + txn <- mdb_txn_begin env Nothing False + db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY] + + let flags = compileWriteFlags [MDB_NOOVERWRITE] + + for_ writs $ \(id,at) -> do + putJam flags txn db id (Jam at) + + mdb_txn_commit txn + -- Get eventhing from the input queue. ----------------------------------------- diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index 17b200cc3..c5c47a319 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/pkg/hs-urbit/lib/Vere/Pier.hs @@ -8,6 +8,7 @@ import Vere.Pier.Types import qualified System.Entropy as Ent import qualified Vere.Log as Log +import qualified Vere.Persist as Persist import qualified Vere.Serf as Serf import Vere.Serf (EventId, Serf) @@ -40,20 +41,40 @@ generateBootSeq ship Pill{..} = do -- This is called to make a freshly booted pier. It assigns an identity to an -- event log and takes a chill pill. -boot :: ByteString -> FilePath -> LogIdentity - -> IO (Serf, EventLog, EventId, Mug) -boot pill top id = do - let logPath = top <> "/log" +boot :: FilePath -> FilePath -> Ship -> IO (Serf, EventLog, EventId, Mug) +boot pillPath top ship = do + let logPath = top <> "/.urb/log" + pill <- loadFile @Pill pillPath >>= \case + Left l -> error (show l) + Right p -> pure p + + + seq@(BootSeq ident _ _) <- generateBootSeq ship pill + + Log.wipeEvents logPath log <- Log.open logPath - Log.writeIdent log id + Log.writeIdent log ident serf <- Serf.startSerfProcess top - (e, m) <- Serf.bootSerf serf id pill + events <- Serf.bootFromSeq serf seq - pure (serf, log, e, m) + -- traceM "Requesting snapshot" + -- Serf.sendOrder serf (OSave lastEv) + -- traceM "Requesting shutdown" + -- Serf.sendOrder serf (OExit 0) + + Persist.writeEvents log events + + (eId, atom) : _ <- evaluate (reverse events) + Just (mug, _::Noun) <- evaluate (atom ^? atomBytes . _Cue >>= fromNoun) + + pure (serf, log, eId, mug) + +-- snapshot :: Serf -> IO () +-- snapshot serf = Serf.sendOrder serf (OSave lastEv) {- What we really want to do is write the log identity and then do diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 4dad443ff..068c0c590 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/pkg/hs-urbit/lib/Vere/Serf.hs @@ -173,44 +173,32 @@ sendAndRecv w eventId order = Stdr _ cord -> putStrLn (pack ("[SERF] " <> cordString cord)) >> loop Slog _ pri t -> printTank pri t >> loop -sendOrder :: Serf -> Order -> IO () -sendOrder w o = sendAtom w $ jam $ toNoun o - -bootFromSeq :: Serf -> BootSeq -> IO [Order] +bootFromSeq :: Serf -> BootSeq -> IO [(EventId, Atom)] bootFromSeq serf (BootSeq ident nocks ovums) = do handshake serf ident >>= \case (1, Mug 0) -> pure () _ -> error "ship already booted" - res <- loop [] 1 (Mug 0) seq - - OWork lastEv _ : _ <- evaluate (reverse res) - - traceM "Requesting snapshot" - sendOrder serf (OSave lastEv) - - traceM "Requesting shutdown" - sendOrder serf (OExit 0) - - pure res + loop [] 1 (Mug 0) seq where - loop :: [Order] -> EventId -> Mug -> [EventId -> Mug -> Time.Wen -> Order] - -> IO [Order] + loop :: [(EventId, Atom)] -> EventId -> Mug -> [Mug -> Time.Wen -> Atom] + -> IO [(EventId, Atom)] loop acc eId lastMug [] = pure $ reverse acc loop acc eId lastMug (x:xs) = do wen <- Time.now - let order = x eId lastMug wen + let atom = x lastMug wen + let order = OWork eId atom sendAndRecv serf eId order >>= \case + Right (id, mug, []) -> loop ((eId, atom) : acc) (eId+1) mug xs Left badEv -> throwIO (ReplacedEventDuringBoot eId badEv) - Right (id, mug, []) -> loop (order : acc) (eId+1) mug xs Right (id, mug, fx) -> throwIO (EffectsDuringBoot eId fx) - seq :: [EventId -> Mug -> Time.Wen -> Order] + seq :: [Mug -> Time.Wen -> Atom] seq = fmap muckNock nocks <> fmap muckOvum ovums where - muckNock nok eId mug _ = OWork eId $ jam $ toNoun (mug, nok) - muckOvum ov eId mug wen = OWork eId $ jam $ toNoun (mug, wen, ov) + muckNock nok mug _ = jam $ toNoun (mug, nok) + muckOvum ov mug wen = jam $ toNoun (mug, wen, ov) -- the ship is booted, but it is behind. shove events to the worker until it is -- caught up. @@ -223,8 +211,6 @@ replayEvents :: Serf replayEvents w (wid, wmug) ident lastCommitedId getEvents = do traceM ("replayEvents: " <> show wid <> " " <> show wmug) - when (wid == 1) (sendOrder w $ OBoot ident) - vLast <- newIORef (wid, wmug) loop vLast wid @@ -251,22 +237,6 @@ replayEvents w (wid, wmug) ident lastCommitedId getEvents = do loop vLast (curEvent + toRead) - -bootSerf :: Serf -> LogIdentity -> ByteString -> IO (EventId, Mug) -bootSerf w ident pill = - do - recvPlea w >>= \case - Play Nothing -> pure () - x@(Play _) -> throwIO (UnexpectedPleaOnNewShip x) - x -> throwIO (InvalidInitialPlea x) - - -- TODO: actually boot the pill - undefined - - -- Maybe return the current event id ? But we'll have to figure that out - -- later. - pure undefined - type GetEvents = EventId -> Word64 -> IO (Vector (EventId, Atom)) {- @@ -288,15 +258,9 @@ handshake serf ident = do pure (eventId, mug) replay :: Serf -> LogIdentity -> EventId -> GetEvents -> IO (EventId, Mug) -replay w ident lastEv getEvents = do - ws@(eventId, mug) <- recvPlea w >>= \case - Play Nothing -> pure (1, Mug 0) - Play (Just (e, m, _)) -> pure (e, m) - x -> throwIO (InvalidInitialPlea x) - - traceM ("got plea! " <> show eventId <> " " <> show mug) - - replayEvents w ws ident lastEv getEvents +replay serf ident lastEv getEvents = do + ws <- handshake serf ident + replayEvents serf ws ident lastEv getEvents workerThread :: Serf -> STM Ovum -> (EventId, Mug) -> IO (Async ()) workerThread w getEvent (evendId, mug) = async $ forever $ do @@ -355,6 +319,9 @@ sendLen s i = do withWord64AsByteString (fromIntegral i) (hPut (sendHandle s)) traceM "sendLen.done" +sendOrder :: Serf -> Order -> IO () +sendOrder w o = sendAtom w $ jam $ toNoun o + sendAtom :: Serf -> Atom -> IO () sendAtom s a = do traceM "sendAtom" diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index d035ae451..ab011d14a 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -19,6 +19,7 @@ dependencies: - classy-prelude - containers - data-fix + - directory - entropy - extra - fixed-vector diff --git a/pkg/hs-vere/app/test/Main.hs b/pkg/hs-vere/app/test/Main.hs index e2ca534fc..180479a4e 100644 --- a/pkg/hs-vere/app/test/Main.hs +++ b/pkg/hs-vere/app/test/Main.hs @@ -7,7 +7,9 @@ import Vere.Pier.Types import Vere.Pier import Vere.Serf -import Text.Show.Pretty (pPrint) +import Control.Concurrent (threadDelay) +import System.Directory (removeFile) +import Text.Show.Pretty (pPrint) import qualified Vere.Log as Log import qualified Vere.Persist as Persist @@ -23,14 +25,25 @@ main = do pPrint p - seq@(BootSeq ident _ _) <- generateBootSeq 0 p - pPrint seq + let pillPath = "/home/benjamin/r/urbit/bin/brass.pill" + shipPath = "/home/benjamin/r/urbit/zod/" + ship = 0 -- zod - serf <- startSerfProcess "/home/benjamin/r/urbit/zod/" - bootFromSeq serf seq >>= pPrint + removeFile (shipPath <> ".urb/chk/north.bin") + removeFile (shipPath <> ".urb/chk/south.bin") - -- (s,l,e,m) <- Pier.resume "/home/benjamin/r/urbit/zod/" - -- putStrLn "Resumed!" + (s,l,e,m) <- Pier.boot pillPath shipPath ship + print (e,m) + threadDelay 500000 + kill s + putStrLn "Booted!" + + removeFile (shipPath <> ".urb/chk/north.bin") + removeFile (shipPath <> ".urb/chk/south.bin") + + (s,l,e,m) <- Pier.resume shipPath + print (e,m) + putStrLn "Resumed!" pure () diff --git a/pkg/hs-vere/package.yaml b/pkg/hs-vere/package.yaml index ba610bbb7..a1d3990e7 100644 --- a/pkg/hs-vere/package.yaml +++ b/pkg/hs-vere/package.yaml @@ -45,6 +45,7 @@ dependencies: - classy-prelude - containers - data-fix + - directory - extra - flat - ghc-prim From 34de4f3adaa46cd388b704d0d6a42a30c37f67d6 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 16 Jul 2019 15:59:39 -0700 Subject: [PATCH 111/431] Pull in latest v0.8.0.rc changes --- bin/brass.pill | 4 +- bin/ivory.pill | 4 +- bin/solid.pill | 4 +- nix/deps-env.nix | 2 +- nix/nixcrpkgs/pkgs/curl/default.nix | 1 + nix/ops/default.nix | 9 +- nix/ops/fakeship/builder.sh | 7 +- nix/ops/solid/builder.sh | 24 +- nix/ops/test/builder.sh | 6 + nix/pkgs/default.nix | 15 +- nix/pkgs/ge-additions/builder.sh | 7 + nix/pkgs/ge-additions/cross.nix | 12 + nix/pkgs/ge-additions/default.nix | 9 + nix/pkgs/ge-additions/release.sh | 13 + nix/pkgs/urbit/builder.sh | 4 +- nix/pkgs/urbit/default.nix | 6 +- nix/pkgs/urbit/release.nix | 16 +- nix/pkgs/urbit/release.sh | 6 +- nix/pkgs/urbit/shell.nix | 3 +- nix/release.nix | 11 +- pkg/arvo | 1 - pkg/arvo/.gitignore | 3 + pkg/arvo/.travis.yml | 80 + pkg/arvo/.travis/.gitattributes | 2 + pkg/arvo/.travis/.gitignore | 1 + pkg/arvo/.travis/check-trailing-whitespace.sh | 11 + pkg/arvo/.travis/get-or-build-pill.sh | 64 + pkg/arvo/.travis/package-lock.json | 753 + pkg/arvo/.travis/package.json | 14 + pkg/arvo/.travis/pin-parent-pill-pier.url | 1 + pkg/arvo/.travis/pin-vere-commit.txt | 1 + pkg/arvo/.travis/print-core-backtrace.sh | 17 + pkg/arvo/.travis/test.js | 134 + pkg/arvo/LICENSE.txt | 21 + pkg/arvo/README.md | 66 + pkg/arvo/TESTING.udon | 57 + pkg/arvo/app/acme.hoon | 1394 ++ pkg/arvo/app/aqua-ames.hoon | 83 + pkg/arvo/app/aqua-behn.hoon | 131 + pkg/arvo/app/aqua-dill.hoon | 78 + pkg/arvo/app/aqua-eyre.hoon | 157 + pkg/arvo/app/aqua.hoon | 564 + pkg/arvo/app/azimuth-tracker.hoon | 332 + pkg/arvo/app/chat.hoon | 658 + pkg/arvo/app/chat/css/index.css | 2 + pkg/arvo/app/chat/img/Home.png | Bin 0 -> 255 bytes pkg/arvo/app/chat/img/Icon-Home.png | Bin 0 -> 255 bytes pkg/arvo/app/chat/img/Send.png | Bin 0 -> 1010 bytes pkg/arvo/app/chat/img/Tile.png | Bin 0 -> 1125 bytes pkg/arvo/app/chat/index.html | 16 + pkg/arvo/app/chat/js/index.js | 1 + pkg/arvo/app/chat/js/tile.js | 1 + pkg/arvo/app/claz.hoon | 896 + pkg/arvo/app/clock.hoon | 80 + pkg/arvo/app/clock/js/tile.js | 1 + pkg/arvo/app/dns-bind.hoon | 895 + pkg/arvo/app/dns-collector.hoon | 158 + pkg/arvo/app/dns.hoon | 291 + pkg/arvo/app/dojo.hoon | 1197 ++ pkg/arvo/app/eth-manage.hoon | 66 + pkg/arvo/app/eth-watcher.hoon | 571 + pkg/arvo/app/example-tapp-fetch.hoon | 147 + pkg/arvo/app/example-tapp-subscribe.hoon | 50 + pkg/arvo/app/gaze.hoon | 490 + pkg/arvo/app/hall.hoon | 3354 +++ pkg/arvo/app/hood.hoon | 200 + pkg/arvo/app/launch.hoon | 133 + pkg/arvo/app/launch/css/index.css | 2 + pkg/arvo/app/launch/img/Home.png | Bin 0 -> 255 bytes pkg/arvo/app/launch/index.hoon | 18 + pkg/arvo/app/launch/index.html | 18 + pkg/arvo/app/launch/js/index.js | 1 + pkg/arvo/app/lens.hoon | 114 + pkg/arvo/app/modulo.hoon | 51 + pkg/arvo/app/ph.hoon | 481 + pkg/arvo/app/publish.hoon | 1424 ++ pkg/arvo/app/publish/css/index.css | 2 + pkg/arvo/app/publish/img/arrow.png | Bin 0 -> 245 bytes pkg/arvo/app/publish/img/tile.png | Bin 0 -> 1162 bytes pkg/arvo/app/publish/index.hoon | 21 + pkg/arvo/app/publish/js/index.js | 1 + pkg/arvo/app/publish/js/tile.js | 1 + pkg/arvo/app/send-txs.hoon | 385 + pkg/arvo/app/talk.hoon | 2566 +++ pkg/arvo/app/test.hoon | 170 + pkg/arvo/app/test/example.udon | 8 + pkg/arvo/app/tiebout.hoon | 269 + pkg/arvo/app/time.hoon | 23 + pkg/arvo/app/timer.hoon | 125 + pkg/arvo/app/timer/img/example.png | Bin 0 -> 20543 bytes pkg/arvo/app/timer/img/volume-high.png | Bin 0 -> 15817 bytes pkg/arvo/app/timer/img/volume-mute.png | Bin 0 -> 16077 bytes pkg/arvo/app/timer/js/tile.js | 1 + pkg/arvo/app/weather.hoon | 170 + pkg/arvo/app/weather/img/chancerain.png | Bin 0 -> 549 bytes pkg/arvo/app/weather/img/clear-day.png | Bin 0 -> 2152 bytes pkg/arvo/app/weather/img/clear-night.png | Bin 0 -> 2126 bytes pkg/arvo/app/weather/img/cloudy.png | Bin 0 -> 1429 bytes pkg/arvo/app/weather/img/fog.png | Bin 0 -> 411 bytes pkg/arvo/app/weather/img/high.png | Bin 0 -> 960 bytes pkg/arvo/app/weather/img/low.png | Bin 0 -> 897 bytes .../app/weather/img/partly-cloudy-day.png | Bin 0 -> 2329 bytes .../app/weather/img/partly-cloudy-night.png | Bin 0 -> 1818 bytes pkg/arvo/app/weather/img/rain.png | Bin 0 -> 1918 bytes pkg/arvo/app/weather/img/sleet.png | Bin 0 -> 593 bytes pkg/arvo/app/weather/img/snow.png | Bin 0 -> 1534 bytes pkg/arvo/app/weather/img/sunset.png | Bin 0 -> 589 bytes pkg/arvo/app/weather/img/wind.png | Bin 0 -> 1064 bytes pkg/arvo/app/weather/img/winddirection.png | Bin 0 -> 512 bytes pkg/arvo/app/weather/img/windspeed.png | Bin 0 -> 521 bytes pkg/arvo/app/weather/js/tile.js | 1 + pkg/arvo/gen/acme/domain-validation.hoon | 27 + pkg/arvo/gen/aqua/dojo.hoon | 14 + pkg/arvo/gen/aqua/file.hoon | 9 + pkg/arvo/gen/aqua/init.hoon | 6 + pkg/arvo/gen/aqua/raw-event.hoon | 6 + pkg/arvo/gen/aqua/restore-fleet.hoon | 6 + pkg/arvo/gen/aqua/scry.hoon | 10 + pkg/arvo/gen/aqua/snap-fleet.hoon | 8 + pkg/arvo/gen/brass.hoon | 190 + pkg/arvo/gen/cat.hoon | 33 + pkg/arvo/gen/code.hoon | 16 + pkg/arvo/gen/deco.hoon | 178 + pkg/arvo/gen/dns-bind/authority.hoon | 42 + pkg/arvo/gen/dns/auto.hoon | 29 + pkg/arvo/gen/dns/request.hoon | 43 + pkg/arvo/gen/dojo/wipe.hoon | 9 + pkg/arvo/gen/frontpage.hoon | 26 + pkg/arvo/gen/glass.hoon | 131 + pkg/arvo/gen/hall/load-legacy.hoon | 13 + pkg/arvo/gen/hall/load.hoon | 13 + pkg/arvo/gen/hall/log.hoon | 13 + pkg/arvo/gen/hall/save.hoon | 13 + pkg/arvo/gen/hall/unlog.hoon | 13 + pkg/arvo/gen/hello.hoon | 12 + pkg/arvo/gen/help.hoon | 64 + pkg/arvo/gen/hood/autoload.hoon | 14 + pkg/arvo/gen/hood/automass.hoon | 14 + pkg/arvo/gen/hood/bonk.hoon | 7 + pkg/arvo/gen/hood/breload.hoon | 14 + pkg/arvo/gen/hood/cancel-automass.hoon | 13 + pkg/arvo/gen/hood/cancel.hoon | 14 + pkg/arvo/gen/hood/commit.hoon | 15 + pkg/arvo/gen/hood/cp.hoon | 17 + pkg/arvo/gen/hood/exit.hoon | 16 + pkg/arvo/gen/hood/hi.hoon | 7 + pkg/arvo/gen/hood/init-oauth2.hoon | 35 + pkg/arvo/gen/hood/init-oauth2/google.hoon | 32 + pkg/arvo/gen/hood/keep-ford.hoon | 13 + pkg/arvo/gen/hood/label.hoon | 14 + pkg/arvo/gen/hood/link.hoon | 16 + pkg/arvo/gen/hood/load.hoon | 15 + pkg/arvo/gen/hood/mass.hoon | 13 + pkg/arvo/gen/hood/merge.hoon | 46 + pkg/arvo/gen/hood/mount.hoon | 17 + pkg/arvo/gen/hood/mv.hoon | 18 + pkg/arvo/gen/hood/nuke.hoon | 13 + pkg/arvo/gen/hood/overload.hoon | 13 + pkg/arvo/gen/hood/ping.hoon | 12 + pkg/arvo/gen/hood/private.hoon | 10 + pkg/arvo/gen/hood/public.hoon | 10 + pkg/arvo/gen/hood/rc.hoon | 13 + pkg/arvo/gen/hood/reboot.hoon | 13 + pkg/arvo/gen/hood/rekey.hoon | 8 + pkg/arvo/gen/hood/reload-desk.hoon | 14 + pkg/arvo/gen/hood/reload.hoon | 14 + pkg/arvo/gen/hood/reset.hoon | 13 + pkg/arvo/gen/hood/rf.hoon | 13 + pkg/arvo/gen/hood/rm.hoon | 7 + pkg/arvo/gen/hood/schedule.hoon | 7 + pkg/arvo/gen/hood/serve.hoon | 16 + pkg/arvo/gen/hood/start.hoon | 17 + pkg/arvo/gen/hood/static.hoon | 78 + pkg/arvo/gen/hood/sync.hoon | 14 + pkg/arvo/gen/hood/syncs.hoon | 11 + pkg/arvo/gen/hood/track.hoon | 14 + pkg/arvo/gen/hood/unlink.hoon | 16 + pkg/arvo/gen/hood/unmount.hoon | 14 + pkg/arvo/gen/hood/unsync.hoon | 14 + pkg/arvo/gen/hood/verb.hoon | 16 + pkg/arvo/gen/hood/wipe-ford.hoon | 14 + pkg/arvo/gen/ivory.hoon | 74 + pkg/arvo/gen/key.hoon | 31 + pkg/arvo/gen/ls.hoon | 14 + pkg/arvo/gen/metal.hoon | 322 + pkg/arvo/gen/moon.hoon | 38 + pkg/arvo/gen/ph/cancel.hoon | 6 + pkg/arvo/gen/ph/init.hoon | 6 + pkg/arvo/gen/ph/print.hoon | 6 + pkg/arvo/gen/ph/run-all.hoon | 6 + pkg/arvo/gen/ph/run.hoon | 6 + pkg/arvo/gen/solid.hoon | 87 + pkg/arvo/gen/tapp-admin/cancel.hoon | 3 + pkg/arvo/gen/tapp-admin/restart.hoon | 3 + pkg/arvo/gen/test.hoon | 82 + pkg/arvo/gen/tree.hoon | 12 + pkg/arvo/lib/async.hoon | 204 + pkg/arvo/lib/base64.hoon | 136 + pkg/arvo/lib/bip32.hoon | 216 + pkg/arvo/lib/bip39.hoon | 46 + pkg/arvo/lib/bip39/english.hoon | 2052 ++ pkg/arvo/lib/chat.hoon | 140 + pkg/arvo/lib/cram.hoon | 61 + pkg/arvo/lib/der.hoon | 210 + pkg/arvo/lib/elem-to-react-json.hoon | 57 + pkg/arvo/lib/eth-watcher.hoon | 38 + pkg/arvo/lib/frontmatter.hoon | 35 + pkg/arvo/lib/generators.hoon | 33 + pkg/arvo/lib/hall-json.hoon | 605 + pkg/arvo/lib/hall-legacy.hoon | 199 + pkg/arvo/lib/hall.hoon | 286 + pkg/arvo/lib/hood/drum.hoon | 1047 + pkg/arvo/lib/hood/helm.hoon | 219 + pkg/arvo/lib/hood/kiln.hoon | 683 + pkg/arvo/lib/hood/write.hoon | 124 + pkg/arvo/lib/jose.hoon | 214 + pkg/arvo/lib/keygen.hoon | 106 + pkg/arvo/lib/launch.hoon | 24 + pkg/arvo/lib/number-to-words.hoon | 150 + pkg/arvo/lib/old-phon.hoon | 203 + pkg/arvo/lib/ph.hoon | 86 + pkg/arvo/lib/ph/azimuth.hoon | 365 + pkg/arvo/lib/ph/philter.hoon | 76 + pkg/arvo/lib/ph/tests.hoon | 177 + pkg/arvo/lib/ph/util.hoon | 102 + pkg/arvo/lib/pill.hoon | 129 + pkg/arvo/lib/pkcs.hoon | 378 + pkg/arvo/lib/pretty-file.hoon | 31 + pkg/arvo/lib/primitive-rsa.hoon | 84 + pkg/arvo/lib/publish.hoon | 232 + pkg/arvo/lib/rekey.hoon | 16 + pkg/arvo/lib/ring.hoon | 470 + pkg/arvo/lib/server.hoon | 136 + pkg/arvo/lib/show-dir.hoon | 22 + pkg/arvo/lib/sole.hoon | 139 + pkg/arvo/lib/stdio.hoon | 394 + pkg/arvo/lib/tapp.hoon | 526 + pkg/arvo/lib/test.hoon | 45 + pkg/arvo/lib/test/ford.hoon | 267 + pkg/arvo/lib/test/runner.hoon | 67 + pkg/arvo/lib/time-to-id.hoon | 10 + pkg/arvo/lib/tree.hoon | 34 + pkg/arvo/lib/urb-split.hoon | 10 + pkg/arvo/mar/acme/order.hoon | 9 + pkg/arvo/mar/atom.hoon | 18 + pkg/arvo/mar/azimuth/update.hoon | 8 + pkg/arvo/mar/chat/action.hoon | 58 + pkg/arvo/mar/chat/config.hoon | 48 + pkg/arvo/mar/chat/update.hoon | 96 + pkg/arvo/mar/css.hoon | 21 + pkg/arvo/mar/dill/belt.hoon | 60 + pkg/arvo/mar/dill/blit.hoon | 25 + pkg/arvo/mar/dns/address.hoon | 7 + pkg/arvo/mar/dns/binding.hoon | 7 + pkg/arvo/mar/dns/complete.hoon | 7 + pkg/arvo/mar/drum-put.hoon | 11 + pkg/arvo/mar/elem.hoon | 18 + pkg/arvo/mar/eth-watcher/action.hoon | 7 + pkg/arvo/mar/eth-watcher/update.hoon | 7 + pkg/arvo/mar/eth/txs.hoon | 70 + pkg/arvo/mar/front.hoon | 20 + pkg/arvo/mar/hall/action.hoon | 74 + pkg/arvo/mar/hall/command.hoon | 40 + pkg/arvo/mar/hall/prize.hoon | 42 + pkg/arvo/mar/hall/rumor.hoon | 40 + pkg/arvo/mar/hall/telegrams.hoon | 41 + pkg/arvo/mar/helm-hi.hoon | 19 + pkg/arvo/mar/hoon.hoon | 50 + pkg/arvo/mar/htm.hoon | 13 + pkg/arvo/mar/html.hoon | 21 + pkg/arvo/mar/httr.hoon | 23 + pkg/arvo/mar/hymn.hoon | 16 + pkg/arvo/mar/jam.hoon | 17 + pkg/arvo/mar/js.hoon | 22 + pkg/arvo/mar/json.hoon | 26 + pkg/arvo/mar/json/rpc/response.hoon | 38 + pkg/arvo/mar/launch/action.hoon | 11 + pkg/arvo/mar/lens/command.hoon | 62 + pkg/arvo/mar/lens/json.hoon | 12 + pkg/arvo/mar/md.hoon | 20 + pkg/arvo/mar/mime.hoon | 25 + pkg/arvo/mar/noun.hoon | 11 + pkg/arvo/mar/path.hoon | 6 + pkg/arvo/mar/pem.hoon | 19 + pkg/arvo/mar/pill.hoon | 36 + pkg/arvo/mar/png.hoon | 12 + pkg/arvo/mar/publish/action.hoon | 192 + pkg/arvo/mar/publish/comment.hoon | 68 + pkg/arvo/mar/publish/info.hoon | 84 + pkg/arvo/mar/publish/rumor.hoon | 55 + pkg/arvo/mar/publish/update.hoon | 26 + pkg/arvo/mar/purl.hoon | 14 + pkg/arvo/mar/ships.hoon | 15 + pkg/arvo/mar/snap.hoon | 16 + pkg/arvo/mar/snip.hoon | 61 + pkg/arvo/mar/sole/action.hoon | 45 + pkg/arvo/mar/sole/effect.hoon | 92 + pkg/arvo/mar/tang.hoon | 21 + pkg/arvo/mar/tiebout-action.hoon | 33 + pkg/arvo/mar/txt-diff.hoon | 11 + pkg/arvo/mar/txt.hoon | 270 + pkg/arvo/mar/udon.hoon | 32 + pkg/arvo/mar/umd.hoon | 32 + pkg/arvo/mar/urb.hoon | 17 + pkg/arvo/mar/urbit.hoon | 12 + pkg/arvo/mar/x-htm.hoon | 10 + pkg/arvo/mar/x-htm/elem.hoon | 3 + pkg/arvo/mar/xml.hoon | 20 + pkg/arvo/ren/publish/comments.hoon | 14 + pkg/arvo/ren/publish/post.hoon | 20 + pkg/arvo/ren/run.hoon | 10 + pkg/arvo/ren/test-gen.hoon | 4 + pkg/arvo/sur/aquarium.hoon | 101 + pkg/arvo/sur/asn1.hoon | 80 + pkg/arvo/sur/dns-bind.hoon | 58 + pkg/arvo/sur/dns.hoon | 5 + pkg/arvo/sur/eth-watcher.hoon | 39 + pkg/arvo/sur/hall.hoon | 271 + pkg/arvo/sur/keygen.hoon | 23 + pkg/arvo/sur/kyev.hoon | 11 + pkg/arvo/sur/lens.hoon | 30 + pkg/arvo/sur/ph.hoon | 9 + pkg/arvo/sur/publish.hoon | 128 + pkg/arvo/sur/ring.hoon | 37 + pkg/arvo/sur/sole.hoon | 83 + pkg/arvo/sur/tapp.hoon | 37 + pkg/arvo/sur/tiebout.hoon | 21 + pkg/arvo/sur/urb.hoon | 5 + pkg/arvo/sys/arvo.hoon | 953 + pkg/arvo/sys/hoon.hoon | 17473 ++++++++++++++++ pkg/arvo/sys/vane/alef.hoon | 2588 +++ pkg/arvo/sys/vane/ames.hoon | 1668 ++ pkg/arvo/sys/vane/behn.hoon | 291 + pkg/arvo/sys/vane/clay.hoon | 4619 ++++ pkg/arvo/sys/vane/dill.hoon | 588 + pkg/arvo/sys/vane/eyre.hoon | 2163 ++ pkg/arvo/sys/vane/ford.hoon | 6335 ++++++ pkg/arvo/sys/vane/gall.hoon | 1455 ++ pkg/arvo/sys/vane/iris.hoon | 400 + pkg/arvo/sys/vane/jael.hoon | 2537 +++ pkg/arvo/sys/vane/kale.hoon | 1016 + pkg/arvo/sys/vane/xmas.hoon | 1305 ++ pkg/arvo/sys/zuse.hoon | 9339 +++++++++ pkg/arvo/tests/app/acme.hoon | 53 + pkg/arvo/tests/bug/gh-703.hoon | 13 + pkg/arvo/tests/lib/base64.hoon | 77 + pkg/arvo/tests/lib/bip39.hoon | 256 + pkg/arvo/tests/lib/der.hoon | 53 + pkg/arvo/tests/lib/jose.hoon | 213 + pkg/arvo/tests/lib/keygen.hoon | 345 + pkg/arvo/tests/lib/number-to-words.hoon | 69 + pkg/arvo/tests/lib/pkcs.hoon | 390 + pkg/arvo/tests/lib/primitive-rsa.hoon | 137 + pkg/arvo/tests/lib/ring.hoon | 151 + pkg/arvo/tests/sys/hoon/auras.hoon | 146 + pkg/arvo/tests/sys/hoon/bits.hoon | 55 + pkg/arvo/tests/sys/hoon/hashes.hoon | 56 + pkg/arvo/tests/sys/hoon/molds.hoon | 35 + pkg/arvo/tests/sys/hoon/ob.hoon | 140 + pkg/arvo/tests/sys/vane/alef.hoon | 200 + pkg/arvo/tests/sys/vane/ames.hoon | 175 + pkg/arvo/tests/sys/vane/clay.hoon | 542 + pkg/arvo/tests/sys/vane/eyre.hoon | 2185 ++ pkg/arvo/tests/sys/vane/ford.hoon | 7394 +++++++ pkg/arvo/tests/sys/vane/iris.hoon | 535 + pkg/arvo/tests/sys/vane/jael.hoon | 159 + .../tests/sys/zuse/contain/capped-queue.hoon | 128 + pkg/arvo/tests/sys/zuse/contain/clock.hoon | 182 + pkg/arvo/tests/sys/zuse/crypto/argon.hoon | 25 + pkg/arvo/tests/sys/zuse/crypto/blake.hoon | 93 + pkg/arvo/tests/sys/zuse/crypto/keccak.hoon | 303 + pkg/arvo/tests/sys/zuse/crypto/pbkdf.hoon | 548 + pkg/arvo/tests/sys/zuse/crypto/ripemd.hoon | 58 + pkg/arvo/tests/sys/zuse/dawn.hoon | 356 + .../tests/sys/zuse/ethereum/encoding.hoon | 44 + pkg/arvo/tests/sys/zuse/ethereum/rlp.hoon | 53 + pkg/arvo/tests/sys/zuse/ethereum/signing.hoon | 54 + pkg/arvo/tests/sys/zuse/ordered-map.hoon | 97 + pkg/ge-additions/LICENSE | 27 + pkg/ge-additions/Makefile | 20 + pkg/ge-additions/README.md | 20 + pkg/ge-additions/ge-additions.c | 169 + pkg/ge-additions/ge-additions.h | 8 + pkg/urbit/.gitignore | 6 +- pkg/urbit/Makefile | 41 +- pkg/urbit/configure | 3 +- pkg/urbit/daemon/main.c | 45 +- pkg/urbit/include/c/defs.h | 4 +- pkg/urbit/include/jets/q.h | 1 - pkg/urbit/include/jets/w.h | 6 +- pkg/urbit/include/vere/vere.h | 7 +- pkg/urbit/jets/e/cue.c | 86 +- pkg/urbit/jets/e/ed_add_double_scalarmult.c | 106 + .../e/ed_add_scalarmult_scalarmult_base.c | 78 + pkg/urbit/jets/e/ed_point_add.c | 79 + pkg/urbit/jets/e/ed_scalarmult.c | 66 + pkg/urbit/jets/e/ed_scalarmult_base.c | 36 + pkg/urbit/jets/e/ed_veri.c | 4 +- pkg/urbit/jets/e/loss.c | 8 +- pkg/urbit/jets/f/ut.c | 7 +- pkg/urbit/jets/tree.c | 28 +- pkg/urbit/noun/allocate.c | 41 +- pkg/urbit/noun/events.c | 11 +- pkg/urbit/noun/manage.c | 8 +- pkg/urbit/noun/retrieve.c | 245 +- pkg/urbit/vere/ames.c | 15 + pkg/urbit/vere/daemon.c | 74 +- pkg/urbit/vere/dawn.c | 10 +- pkg/urbit/vere/http.c | 109 +- pkg/urbit/vere/pier.c | 171 +- pkg/urbit/vere/reck.c | 17 + pkg/urbit/vere/term.c | 26 +- pkg/urbit/vere/unix.c | 27 +- pkg/urbit/worker/main.c | 41 +- 414 files changed, 104925 insertions(+), 508 deletions(-) create mode 100644 nix/pkgs/ge-additions/builder.sh create mode 100644 nix/pkgs/ge-additions/cross.nix create mode 100644 nix/pkgs/ge-additions/default.nix create mode 100644 nix/pkgs/ge-additions/release.sh delete mode 160000 pkg/arvo create mode 100644 pkg/arvo/.gitignore create mode 100644 pkg/arvo/.travis.yml create mode 100644 pkg/arvo/.travis/.gitattributes create mode 100644 pkg/arvo/.travis/.gitignore create mode 100755 pkg/arvo/.travis/check-trailing-whitespace.sh create mode 100644 pkg/arvo/.travis/get-or-build-pill.sh create mode 100644 pkg/arvo/.travis/package-lock.json create mode 100644 pkg/arvo/.travis/package.json create mode 100644 pkg/arvo/.travis/pin-parent-pill-pier.url create mode 100644 pkg/arvo/.travis/pin-vere-commit.txt create mode 100644 pkg/arvo/.travis/print-core-backtrace.sh create mode 100644 pkg/arvo/.travis/test.js create mode 100644 pkg/arvo/LICENSE.txt create mode 100644 pkg/arvo/README.md create mode 100644 pkg/arvo/TESTING.udon create mode 100644 pkg/arvo/app/acme.hoon create mode 100644 pkg/arvo/app/aqua-ames.hoon create mode 100644 pkg/arvo/app/aqua-behn.hoon create mode 100644 pkg/arvo/app/aqua-dill.hoon create mode 100644 pkg/arvo/app/aqua-eyre.hoon create mode 100644 pkg/arvo/app/aqua.hoon create mode 100644 pkg/arvo/app/azimuth-tracker.hoon create mode 100644 pkg/arvo/app/chat.hoon create mode 100644 pkg/arvo/app/chat/css/index.css create mode 100644 pkg/arvo/app/chat/img/Home.png create mode 100644 pkg/arvo/app/chat/img/Icon-Home.png create mode 100644 pkg/arvo/app/chat/img/Send.png create mode 100644 pkg/arvo/app/chat/img/Tile.png create mode 100644 pkg/arvo/app/chat/index.html create mode 100644 pkg/arvo/app/chat/js/index.js create mode 100644 pkg/arvo/app/chat/js/tile.js create mode 100644 pkg/arvo/app/claz.hoon create mode 100644 pkg/arvo/app/clock.hoon create mode 100644 pkg/arvo/app/clock/js/tile.js create mode 100644 pkg/arvo/app/dns-bind.hoon create mode 100644 pkg/arvo/app/dns-collector.hoon create mode 100644 pkg/arvo/app/dns.hoon create mode 100644 pkg/arvo/app/dojo.hoon create mode 100644 pkg/arvo/app/eth-manage.hoon create mode 100644 pkg/arvo/app/eth-watcher.hoon create mode 100644 pkg/arvo/app/example-tapp-fetch.hoon create mode 100644 pkg/arvo/app/example-tapp-subscribe.hoon create mode 100644 pkg/arvo/app/gaze.hoon create mode 100644 pkg/arvo/app/hall.hoon create mode 100644 pkg/arvo/app/hood.hoon create mode 100644 pkg/arvo/app/launch.hoon create mode 100644 pkg/arvo/app/launch/css/index.css create mode 100644 pkg/arvo/app/launch/img/Home.png create mode 100644 pkg/arvo/app/launch/index.hoon create mode 100644 pkg/arvo/app/launch/index.html create mode 100644 pkg/arvo/app/launch/js/index.js create mode 100644 pkg/arvo/app/lens.hoon create mode 100644 pkg/arvo/app/modulo.hoon create mode 100644 pkg/arvo/app/ph.hoon create mode 100644 pkg/arvo/app/publish.hoon create mode 100644 pkg/arvo/app/publish/css/index.css create mode 100644 pkg/arvo/app/publish/img/arrow.png create mode 100644 pkg/arvo/app/publish/img/tile.png create mode 100644 pkg/arvo/app/publish/index.hoon create mode 100644 pkg/arvo/app/publish/js/index.js create mode 100644 pkg/arvo/app/publish/js/tile.js create mode 100644 pkg/arvo/app/send-txs.hoon create mode 100644 pkg/arvo/app/talk.hoon create mode 100644 pkg/arvo/app/test.hoon create mode 100644 pkg/arvo/app/test/example.udon create mode 100644 pkg/arvo/app/tiebout.hoon create mode 100644 pkg/arvo/app/time.hoon create mode 100644 pkg/arvo/app/timer.hoon create mode 100644 pkg/arvo/app/timer/img/example.png create mode 100644 pkg/arvo/app/timer/img/volume-high.png create mode 100644 pkg/arvo/app/timer/img/volume-mute.png create mode 100644 pkg/arvo/app/timer/js/tile.js create mode 100644 pkg/arvo/app/weather.hoon create mode 100644 pkg/arvo/app/weather/img/chancerain.png create mode 100644 pkg/arvo/app/weather/img/clear-day.png create mode 100644 pkg/arvo/app/weather/img/clear-night.png create mode 100644 pkg/arvo/app/weather/img/cloudy.png create mode 100644 pkg/arvo/app/weather/img/fog.png create mode 100644 pkg/arvo/app/weather/img/high.png create mode 100644 pkg/arvo/app/weather/img/low.png create mode 100644 pkg/arvo/app/weather/img/partly-cloudy-day.png create mode 100644 pkg/arvo/app/weather/img/partly-cloudy-night.png create mode 100644 pkg/arvo/app/weather/img/rain.png create mode 100644 pkg/arvo/app/weather/img/sleet.png create mode 100644 pkg/arvo/app/weather/img/snow.png create mode 100644 pkg/arvo/app/weather/img/sunset.png create mode 100644 pkg/arvo/app/weather/img/wind.png create mode 100644 pkg/arvo/app/weather/img/winddirection.png create mode 100644 pkg/arvo/app/weather/img/windspeed.png create mode 100644 pkg/arvo/app/weather/js/tile.js create mode 100644 pkg/arvo/gen/acme/domain-validation.hoon create mode 100644 pkg/arvo/gen/aqua/dojo.hoon create mode 100644 pkg/arvo/gen/aqua/file.hoon create mode 100644 pkg/arvo/gen/aqua/init.hoon create mode 100644 pkg/arvo/gen/aqua/raw-event.hoon create mode 100644 pkg/arvo/gen/aqua/restore-fleet.hoon create mode 100644 pkg/arvo/gen/aqua/scry.hoon create mode 100644 pkg/arvo/gen/aqua/snap-fleet.hoon create mode 100644 pkg/arvo/gen/brass.hoon create mode 100644 pkg/arvo/gen/cat.hoon create mode 100644 pkg/arvo/gen/code.hoon create mode 100644 pkg/arvo/gen/deco.hoon create mode 100644 pkg/arvo/gen/dns-bind/authority.hoon create mode 100644 pkg/arvo/gen/dns/auto.hoon create mode 100644 pkg/arvo/gen/dns/request.hoon create mode 100644 pkg/arvo/gen/dojo/wipe.hoon create mode 100644 pkg/arvo/gen/frontpage.hoon create mode 100644 pkg/arvo/gen/glass.hoon create mode 100644 pkg/arvo/gen/hall/load-legacy.hoon create mode 100644 pkg/arvo/gen/hall/load.hoon create mode 100644 pkg/arvo/gen/hall/log.hoon create mode 100644 pkg/arvo/gen/hall/save.hoon create mode 100644 pkg/arvo/gen/hall/unlog.hoon create mode 100644 pkg/arvo/gen/hello.hoon create mode 100644 pkg/arvo/gen/help.hoon create mode 100644 pkg/arvo/gen/hood/autoload.hoon create mode 100644 pkg/arvo/gen/hood/automass.hoon create mode 100644 pkg/arvo/gen/hood/bonk.hoon create mode 100644 pkg/arvo/gen/hood/breload.hoon create mode 100644 pkg/arvo/gen/hood/cancel-automass.hoon create mode 100644 pkg/arvo/gen/hood/cancel.hoon create mode 100644 pkg/arvo/gen/hood/commit.hoon create mode 100644 pkg/arvo/gen/hood/cp.hoon create mode 100644 pkg/arvo/gen/hood/exit.hoon create mode 100644 pkg/arvo/gen/hood/hi.hoon create mode 100644 pkg/arvo/gen/hood/init-oauth2.hoon create mode 100644 pkg/arvo/gen/hood/init-oauth2/google.hoon create mode 100644 pkg/arvo/gen/hood/keep-ford.hoon create mode 100644 pkg/arvo/gen/hood/label.hoon create mode 100644 pkg/arvo/gen/hood/link.hoon create mode 100644 pkg/arvo/gen/hood/load.hoon create mode 100644 pkg/arvo/gen/hood/mass.hoon create mode 100644 pkg/arvo/gen/hood/merge.hoon create mode 100644 pkg/arvo/gen/hood/mount.hoon create mode 100644 pkg/arvo/gen/hood/mv.hoon create mode 100644 pkg/arvo/gen/hood/nuke.hoon create mode 100644 pkg/arvo/gen/hood/overload.hoon create mode 100644 pkg/arvo/gen/hood/ping.hoon create mode 100644 pkg/arvo/gen/hood/private.hoon create mode 100644 pkg/arvo/gen/hood/public.hoon create mode 100644 pkg/arvo/gen/hood/rc.hoon create mode 100644 pkg/arvo/gen/hood/reboot.hoon create mode 100644 pkg/arvo/gen/hood/rekey.hoon create mode 100644 pkg/arvo/gen/hood/reload-desk.hoon create mode 100644 pkg/arvo/gen/hood/reload.hoon create mode 100644 pkg/arvo/gen/hood/reset.hoon create mode 100644 pkg/arvo/gen/hood/rf.hoon create mode 100644 pkg/arvo/gen/hood/rm.hoon create mode 100644 pkg/arvo/gen/hood/schedule.hoon create mode 100644 pkg/arvo/gen/hood/serve.hoon create mode 100644 pkg/arvo/gen/hood/start.hoon create mode 100644 pkg/arvo/gen/hood/static.hoon create mode 100644 pkg/arvo/gen/hood/sync.hoon create mode 100644 pkg/arvo/gen/hood/syncs.hoon create mode 100644 pkg/arvo/gen/hood/track.hoon create mode 100644 pkg/arvo/gen/hood/unlink.hoon create mode 100644 pkg/arvo/gen/hood/unmount.hoon create mode 100644 pkg/arvo/gen/hood/unsync.hoon create mode 100644 pkg/arvo/gen/hood/verb.hoon create mode 100644 pkg/arvo/gen/hood/wipe-ford.hoon create mode 100644 pkg/arvo/gen/ivory.hoon create mode 100644 pkg/arvo/gen/key.hoon create mode 100644 pkg/arvo/gen/ls.hoon create mode 100644 pkg/arvo/gen/metal.hoon create mode 100644 pkg/arvo/gen/moon.hoon create mode 100644 pkg/arvo/gen/ph/cancel.hoon create mode 100644 pkg/arvo/gen/ph/init.hoon create mode 100644 pkg/arvo/gen/ph/print.hoon create mode 100644 pkg/arvo/gen/ph/run-all.hoon create mode 100644 pkg/arvo/gen/ph/run.hoon create mode 100644 pkg/arvo/gen/solid.hoon create mode 100644 pkg/arvo/gen/tapp-admin/cancel.hoon create mode 100644 pkg/arvo/gen/tapp-admin/restart.hoon create mode 100644 pkg/arvo/gen/test.hoon create mode 100644 pkg/arvo/gen/tree.hoon create mode 100644 pkg/arvo/lib/async.hoon create mode 100644 pkg/arvo/lib/base64.hoon create mode 100644 pkg/arvo/lib/bip32.hoon create mode 100644 pkg/arvo/lib/bip39.hoon create mode 100644 pkg/arvo/lib/bip39/english.hoon create mode 100644 pkg/arvo/lib/chat.hoon create mode 100644 pkg/arvo/lib/cram.hoon create mode 100644 pkg/arvo/lib/der.hoon create mode 100644 pkg/arvo/lib/elem-to-react-json.hoon create mode 100644 pkg/arvo/lib/eth-watcher.hoon create mode 100644 pkg/arvo/lib/frontmatter.hoon create mode 100644 pkg/arvo/lib/generators.hoon create mode 100644 pkg/arvo/lib/hall-json.hoon create mode 100644 pkg/arvo/lib/hall-legacy.hoon create mode 100644 pkg/arvo/lib/hall.hoon create mode 100644 pkg/arvo/lib/hood/drum.hoon create mode 100644 pkg/arvo/lib/hood/helm.hoon create mode 100644 pkg/arvo/lib/hood/kiln.hoon create mode 100644 pkg/arvo/lib/hood/write.hoon create mode 100644 pkg/arvo/lib/jose.hoon create mode 100644 pkg/arvo/lib/keygen.hoon create mode 100644 pkg/arvo/lib/launch.hoon create mode 100644 pkg/arvo/lib/number-to-words.hoon create mode 100644 pkg/arvo/lib/old-phon.hoon create mode 100644 pkg/arvo/lib/ph.hoon create mode 100644 pkg/arvo/lib/ph/azimuth.hoon create mode 100644 pkg/arvo/lib/ph/philter.hoon create mode 100644 pkg/arvo/lib/ph/tests.hoon create mode 100644 pkg/arvo/lib/ph/util.hoon create mode 100644 pkg/arvo/lib/pill.hoon create mode 100644 pkg/arvo/lib/pkcs.hoon create mode 100644 pkg/arvo/lib/pretty-file.hoon create mode 100644 pkg/arvo/lib/primitive-rsa.hoon create mode 100644 pkg/arvo/lib/publish.hoon create mode 100644 pkg/arvo/lib/rekey.hoon create mode 100644 pkg/arvo/lib/ring.hoon create mode 100644 pkg/arvo/lib/server.hoon create mode 100644 pkg/arvo/lib/show-dir.hoon create mode 100644 pkg/arvo/lib/sole.hoon create mode 100644 pkg/arvo/lib/stdio.hoon create mode 100644 pkg/arvo/lib/tapp.hoon create mode 100644 pkg/arvo/lib/test.hoon create mode 100644 pkg/arvo/lib/test/ford.hoon create mode 100644 pkg/arvo/lib/test/runner.hoon create mode 100644 pkg/arvo/lib/time-to-id.hoon create mode 100644 pkg/arvo/lib/tree.hoon create mode 100644 pkg/arvo/lib/urb-split.hoon create mode 100644 pkg/arvo/mar/acme/order.hoon create mode 100644 pkg/arvo/mar/atom.hoon create mode 100644 pkg/arvo/mar/azimuth/update.hoon create mode 100644 pkg/arvo/mar/chat/action.hoon create mode 100644 pkg/arvo/mar/chat/config.hoon create mode 100644 pkg/arvo/mar/chat/update.hoon create mode 100644 pkg/arvo/mar/css.hoon create mode 100644 pkg/arvo/mar/dill/belt.hoon create mode 100644 pkg/arvo/mar/dill/blit.hoon create mode 100644 pkg/arvo/mar/dns/address.hoon create mode 100644 pkg/arvo/mar/dns/binding.hoon create mode 100644 pkg/arvo/mar/dns/complete.hoon create mode 100644 pkg/arvo/mar/drum-put.hoon create mode 100644 pkg/arvo/mar/elem.hoon create mode 100644 pkg/arvo/mar/eth-watcher/action.hoon create mode 100644 pkg/arvo/mar/eth-watcher/update.hoon create mode 100644 pkg/arvo/mar/eth/txs.hoon create mode 100644 pkg/arvo/mar/front.hoon create mode 100644 pkg/arvo/mar/hall/action.hoon create mode 100644 pkg/arvo/mar/hall/command.hoon create mode 100644 pkg/arvo/mar/hall/prize.hoon create mode 100644 pkg/arvo/mar/hall/rumor.hoon create mode 100644 pkg/arvo/mar/hall/telegrams.hoon create mode 100644 pkg/arvo/mar/helm-hi.hoon create mode 100644 pkg/arvo/mar/hoon.hoon create mode 100644 pkg/arvo/mar/htm.hoon create mode 100644 pkg/arvo/mar/html.hoon create mode 100644 pkg/arvo/mar/httr.hoon create mode 100644 pkg/arvo/mar/hymn.hoon create mode 100644 pkg/arvo/mar/jam.hoon create mode 100644 pkg/arvo/mar/js.hoon create mode 100644 pkg/arvo/mar/json.hoon create mode 100644 pkg/arvo/mar/json/rpc/response.hoon create mode 100644 pkg/arvo/mar/launch/action.hoon create mode 100644 pkg/arvo/mar/lens/command.hoon create mode 100644 pkg/arvo/mar/lens/json.hoon create mode 100644 pkg/arvo/mar/md.hoon create mode 100644 pkg/arvo/mar/mime.hoon create mode 100644 pkg/arvo/mar/noun.hoon create mode 100644 pkg/arvo/mar/path.hoon create mode 100644 pkg/arvo/mar/pem.hoon create mode 100644 pkg/arvo/mar/pill.hoon create mode 100644 pkg/arvo/mar/png.hoon create mode 100644 pkg/arvo/mar/publish/action.hoon create mode 100644 pkg/arvo/mar/publish/comment.hoon create mode 100644 pkg/arvo/mar/publish/info.hoon create mode 100644 pkg/arvo/mar/publish/rumor.hoon create mode 100644 pkg/arvo/mar/publish/update.hoon create mode 100644 pkg/arvo/mar/purl.hoon create mode 100644 pkg/arvo/mar/ships.hoon create mode 100644 pkg/arvo/mar/snap.hoon create mode 100644 pkg/arvo/mar/snip.hoon create mode 100644 pkg/arvo/mar/sole/action.hoon create mode 100644 pkg/arvo/mar/sole/effect.hoon create mode 100644 pkg/arvo/mar/tang.hoon create mode 100644 pkg/arvo/mar/tiebout-action.hoon create mode 100644 pkg/arvo/mar/txt-diff.hoon create mode 100644 pkg/arvo/mar/txt.hoon create mode 100644 pkg/arvo/mar/udon.hoon create mode 100644 pkg/arvo/mar/umd.hoon create mode 100644 pkg/arvo/mar/urb.hoon create mode 100644 pkg/arvo/mar/urbit.hoon create mode 100644 pkg/arvo/mar/x-htm.hoon create mode 100644 pkg/arvo/mar/x-htm/elem.hoon create mode 100644 pkg/arvo/mar/xml.hoon create mode 100644 pkg/arvo/ren/publish/comments.hoon create mode 100644 pkg/arvo/ren/publish/post.hoon create mode 100644 pkg/arvo/ren/run.hoon create mode 100644 pkg/arvo/ren/test-gen.hoon create mode 100644 pkg/arvo/sur/aquarium.hoon create mode 100644 pkg/arvo/sur/asn1.hoon create mode 100644 pkg/arvo/sur/dns-bind.hoon create mode 100644 pkg/arvo/sur/dns.hoon create mode 100644 pkg/arvo/sur/eth-watcher.hoon create mode 100644 pkg/arvo/sur/hall.hoon create mode 100644 pkg/arvo/sur/keygen.hoon create mode 100644 pkg/arvo/sur/kyev.hoon create mode 100644 pkg/arvo/sur/lens.hoon create mode 100644 pkg/arvo/sur/ph.hoon create mode 100644 pkg/arvo/sur/publish.hoon create mode 100644 pkg/arvo/sur/ring.hoon create mode 100644 pkg/arvo/sur/sole.hoon create mode 100644 pkg/arvo/sur/tapp.hoon create mode 100644 pkg/arvo/sur/tiebout.hoon create mode 100644 pkg/arvo/sur/urb.hoon create mode 100644 pkg/arvo/sys/arvo.hoon create mode 100644 pkg/arvo/sys/hoon.hoon create mode 100644 pkg/arvo/sys/vane/alef.hoon create mode 100644 pkg/arvo/sys/vane/ames.hoon create mode 100644 pkg/arvo/sys/vane/behn.hoon create mode 100644 pkg/arvo/sys/vane/clay.hoon create mode 100644 pkg/arvo/sys/vane/dill.hoon create mode 100644 pkg/arvo/sys/vane/eyre.hoon create mode 100644 pkg/arvo/sys/vane/ford.hoon create mode 100644 pkg/arvo/sys/vane/gall.hoon create mode 100644 pkg/arvo/sys/vane/iris.hoon create mode 100644 pkg/arvo/sys/vane/jael.hoon create mode 100644 pkg/arvo/sys/vane/kale.hoon create mode 100644 pkg/arvo/sys/vane/xmas.hoon create mode 100644 pkg/arvo/sys/zuse.hoon create mode 100644 pkg/arvo/tests/app/acme.hoon create mode 100644 pkg/arvo/tests/bug/gh-703.hoon create mode 100644 pkg/arvo/tests/lib/base64.hoon create mode 100644 pkg/arvo/tests/lib/bip39.hoon create mode 100644 pkg/arvo/tests/lib/der.hoon create mode 100644 pkg/arvo/tests/lib/jose.hoon create mode 100644 pkg/arvo/tests/lib/keygen.hoon create mode 100644 pkg/arvo/tests/lib/number-to-words.hoon create mode 100644 pkg/arvo/tests/lib/pkcs.hoon create mode 100644 pkg/arvo/tests/lib/primitive-rsa.hoon create mode 100644 pkg/arvo/tests/lib/ring.hoon create mode 100644 pkg/arvo/tests/sys/hoon/auras.hoon create mode 100644 pkg/arvo/tests/sys/hoon/bits.hoon create mode 100644 pkg/arvo/tests/sys/hoon/hashes.hoon create mode 100644 pkg/arvo/tests/sys/hoon/molds.hoon create mode 100644 pkg/arvo/tests/sys/hoon/ob.hoon create mode 100644 pkg/arvo/tests/sys/vane/alef.hoon create mode 100644 pkg/arvo/tests/sys/vane/ames.hoon create mode 100644 pkg/arvo/tests/sys/vane/clay.hoon create mode 100644 pkg/arvo/tests/sys/vane/eyre.hoon create mode 100644 pkg/arvo/tests/sys/vane/ford.hoon create mode 100644 pkg/arvo/tests/sys/vane/iris.hoon create mode 100644 pkg/arvo/tests/sys/vane/jael.hoon create mode 100644 pkg/arvo/tests/sys/zuse/contain/capped-queue.hoon create mode 100644 pkg/arvo/tests/sys/zuse/contain/clock.hoon create mode 100644 pkg/arvo/tests/sys/zuse/crypto/argon.hoon create mode 100644 pkg/arvo/tests/sys/zuse/crypto/blake.hoon create mode 100644 pkg/arvo/tests/sys/zuse/crypto/keccak.hoon create mode 100644 pkg/arvo/tests/sys/zuse/crypto/pbkdf.hoon create mode 100644 pkg/arvo/tests/sys/zuse/crypto/ripemd.hoon create mode 100644 pkg/arvo/tests/sys/zuse/dawn.hoon create mode 100644 pkg/arvo/tests/sys/zuse/ethereum/encoding.hoon create mode 100644 pkg/arvo/tests/sys/zuse/ethereum/rlp.hoon create mode 100644 pkg/arvo/tests/sys/zuse/ethereum/signing.hoon create mode 100644 pkg/arvo/tests/sys/zuse/ordered-map.hoon create mode 100644 pkg/ge-additions/LICENSE create mode 100644 pkg/ge-additions/Makefile create mode 100644 pkg/ge-additions/README.md create mode 100644 pkg/ge-additions/ge-additions.c create mode 100644 pkg/ge-additions/ge-additions.h create mode 100644 pkg/urbit/jets/e/ed_add_double_scalarmult.c create mode 100644 pkg/urbit/jets/e/ed_add_scalarmult_scalarmult_base.c create mode 100644 pkg/urbit/jets/e/ed_point_add.c create mode 100644 pkg/urbit/jets/e/ed_scalarmult.c create mode 100644 pkg/urbit/jets/e/ed_scalarmult_base.c diff --git a/bin/brass.pill b/bin/brass.pill index 7c041bef2..1fce9caad 100644 --- a/bin/brass.pill +++ b/bin/brass.pill @@ -1,3 +1,3 @@ version https://git-lfs.github.com/spec/v1 -oid sha256:2b7ee602f18661a07c88f2fbb2297f2d8e6fd329db0afc760ad334a845e73c9c -size 4601348 +oid sha256:e534cb57dc8b2bee35004d843c7e0b2d028ba699e86d47a58efac4b065ce2f1b +size 6047224 diff --git a/bin/ivory.pill b/bin/ivory.pill index 3d90c839b..771574fe1 100644 --- a/bin/ivory.pill +++ b/bin/ivory.pill @@ -1,3 +1,3 @@ version https://git-lfs.github.com/spec/v1 -oid sha256:847a5166d8d5106a0c909c914cc96ee6bcb47afef6ebdd6c05bebcd8b01ae87a -size 5859838 +oid sha256:96b1f1ad730789b1d557aac66b847047c98341bcf436e1927f40f082a728d641 +size 3816083 diff --git a/bin/solid.pill b/bin/solid.pill index 1d1c07bc3..bc8df50a1 100644 --- a/bin/solid.pill +++ b/bin/solid.pill @@ -1,3 +1,3 @@ version https://git-lfs.github.com/spec/v1 -oid sha256:cdf8ed31292285c9dda789a8ac313babb4d9ce98f19ace4a813d821a9861d685 -size 7168503 +oid sha256:e4a4f8f86b18de5e410caeb491eecf8cf4fe24fbaba03ad8183b55a13eee154a +size 9108350 diff --git a/nix/deps-env.nix b/nix/deps-env.nix index 370939365..ec773fe79 100644 --- a/nix/deps-env.nix +++ b/nix/deps-env.nix @@ -20,7 +20,7 @@ let vendor = with deps; - [ argon2 ed25519 h2o murmur3 scrypt secp256k1 sni softfloat3 uv ent ]; + [ argon2 ed25519 h2o murmur3 scrypt secp256k1 sni softfloat3 uv ent ge-additions ]; in diff --git a/nix/nixcrpkgs/pkgs/curl/default.nix b/nix/nixcrpkgs/pkgs/curl/default.nix index 7000fe6ba..8268e288e 100644 --- a/nix/nixcrpkgs/pkgs/curl/default.nix +++ b/nix/nixcrpkgs/pkgs/curl/default.nix @@ -12,6 +12,7 @@ crossenv.make_derivation rec { "--disable-shared" "--disable-manual" "--disable-ldap" + "--with-ssl=${openssl}" ]; src = crossenv.nixpkgs.fetchurl { diff --git a/nix/ops/default.nix b/nix/ops/default.nix index 7c15fb176..7412ecb58 100644 --- a/nix/ops/default.nix +++ b/nix/ops/default.nix @@ -10,6 +10,13 @@ let bootbrass = ../../bin/brass.pill; bootsolid = ../../bin/solid.pill; + rawzod = import ./fakeship { + inherit pkgs tlon deps debug; + pill = bootsolid; + ship = "zod"; + arvo = null; + }; + zod = import ./fakeship { inherit pkgs tlon deps arvo debug; pill = bootsolid; @@ -33,7 +40,7 @@ rec { solid = import ./solid { inherit arvo pkgs tlon deps debug; - pier = zod; + pier = rawzod; }; brass = import ./brass { diff --git a/nix/ops/fakeship/builder.sh b/nix/ops/fakeship/builder.sh index f7603170a..94736ad0f 100755 --- a/nix/ops/fakeship/builder.sh +++ b/nix/ops/fakeship/builder.sh @@ -2,7 +2,12 @@ source $stdenv/setup set -ex -$URBIT -d -F $SHIP -A "$ARVO" -B "$PILL" $out +if [ -z "$ARVO" ] +then + $URBIT -d -F $SHIP -B "$PILL" $out +else + $URBIT -d -F $SHIP -A "$ARVO" -B "$PILL" $out +fi check () { [ 3 -eq "$(herb $out -d 3)" ] diff --git a/nix/ops/solid/builder.sh b/nix/ops/solid/builder.sh index 943d4f2b6..5d8cbc66f 100755 --- a/nix/ops/solid/builder.sh +++ b/nix/ops/solid/builder.sh @@ -15,7 +15,29 @@ cleanup () { trap cleanup EXIT -herb ./pier -P solid.pill -d '+solid, =dub &' +# update pill strategy to ensure correct staging +# +herb ./pier -p hood -d "+hood/mount /=home=" + +cp $ARVO/lib/pill.hoon ./pier/home/lib/ +chmod -R u+rw ./pier/home/lib/ + +herb ./pier -p hood -d "+hood/commit %home" +herb ./pier -p hood -d "+hood/unmount %home" + +# stage new desk for pill contents +# +herb ./pier -p hood -d '+hood/merge %stage our %home' +herb ./pier -p hood -d "+hood/mount /=stage=" + +rm -rf ./pier/stage +cp -r $ARVO ./pier/stage +chmod -R u+rw ./pier/stage + +herb ./pier -p hood -d "+hood/commit %stage" +herb ./pier -p hood -d "+hood/unmount %stage" + +herb ./pier -P solid.pill -d '+solid /=stage=/sys, =dub &' mv solid.pill $out diff --git a/nix/ops/test/builder.sh b/nix/ops/test/builder.sh index f48b7f6d4..266b34a9d 100644 --- a/nix/ops/test/builder.sh +++ b/nix/ops/test/builder.sh @@ -20,6 +20,8 @@ shutdown () { trap shutdown EXIT +herb ./ship -p hood -d '+hood/mass' + # Start the test app herb ./ship -p hood -d '+hood/start %test' @@ -28,6 +30,8 @@ herb ./ship -d '~& ~ ~& %start-test-cores ~' herb ./ship -p test -d ':- %cores /' herb ./ship -d '~& %finish-test-cores ~' +herb ./ship -p hood -d '+hood/mass' + # Run the %renders tests herb ./ship -d '~& ~ ~& %start-test-renders ~' herb ./ship -p test -d ':- %renders /' @@ -37,6 +41,8 @@ herb ./ship -d '~& %finish-test-renders ~' herb ./ship -d '+test, =seed `@uvI`(shaz %reproducible)' | tee test-generator-output +herb ./ship -p hood -d '+hood/mass' + shutdown # Collect output diff --git a/nix/pkgs/default.nix b/nix/pkgs/default.nix index 1f7fa7fbf..76924d26d 100644 --- a/nix/pkgs/default.nix +++ b/nix/pkgs/default.nix @@ -4,13 +4,18 @@ let deps = import ../deps { inherit pkgs; }; - ent = import ./ent { inherit pkgs; }; - arvo = import ./arvo { inherit pkgs; }; - herb = import ../../pkg/herb { inherit pkgs; }; + ent = import ./ent { inherit pkgs; }; + arvo = import ./arvo { inherit pkgs; }; + herb = import ../../pkg/herb { inherit pkgs; }; + + ge-additions = import ./ge-additions { + inherit pkgs; + inherit (deps) ed25519; + }; mkUrbit = { debug }: import ./urbit { - inherit pkgs ent debug; + inherit pkgs ent debug ge-additions; inherit (deps) argon2 murmur3 uv ed25519 sni scrypt softfloat3; inherit (deps) secp256k1 h2o; }; @@ -20,4 +25,4 @@ let in -{ inherit ent arvo herb urbit urbit-debug; } +{ inherit ent ge-additions arvo herb urbit urbit-debug; } diff --git a/nix/pkgs/ge-additions/builder.sh b/nix/pkgs/ge-additions/builder.sh new file mode 100644 index 000000000..5a0404377 --- /dev/null +++ b/nix/pkgs/ge-additions/builder.sh @@ -0,0 +1,7 @@ +source $stdenv/setup + +cp -r $src ./src +chmod -R u+w ./src +cd ./src + +PREFIX=$out make install diff --git a/nix/pkgs/ge-additions/cross.nix b/nix/pkgs/ge-additions/cross.nix new file mode 100644 index 000000000..f16afad0b --- /dev/null +++ b/nix/pkgs/ge-additions/cross.nix @@ -0,0 +1,12 @@ +{ env_name, env, deps }: + +env.make_derivation rec { + name = "ge-additions"; + builder = ./release.sh; + src = ../../../pkg/ge-additions; + + cross_inputs = [ deps.ed25519 ]; + + CC = "${env.host}-gcc"; + AR = "${env.host}-ar"; +} diff --git a/nix/pkgs/ge-additions/default.nix b/nix/pkgs/ge-additions/default.nix new file mode 100644 index 000000000..e77098cff --- /dev/null +++ b/nix/pkgs/ge-additions/default.nix @@ -0,0 +1,9 @@ +{ pkgs, ed25519 }: + +pkgs.stdenv.mkDerivation rec { + name = "ge-additions"; + builder = ./builder.sh; + src = ../../../pkg/ge-additions; + + nativeBuildInputs = [ ed25519 ]; +} diff --git a/nix/pkgs/ge-additions/release.sh b/nix/pkgs/ge-additions/release.sh new file mode 100644 index 000000000..aaa54b5e1 --- /dev/null +++ b/nix/pkgs/ge-additions/release.sh @@ -0,0 +1,13 @@ +source $setup + +cp -r $src ./src +chmod -R u+w ./src +cd ./src + +for dep in $cross_inputs; do + export CFLAGS="${CFLAGS-} -I$dep/include" + export LDFLAGS="${LDFLAGS-} -L$dep/lib" +done + +PREFIX=$out make install + diff --git a/nix/pkgs/urbit/builder.sh b/nix/pkgs/urbit/builder.sh index aa73e06ea..3bd715538 100644 --- a/nix/pkgs/urbit/builder.sh +++ b/nix/pkgs/urbit/builder.sh @@ -11,5 +11,5 @@ make all -j8 make test mkdir -p $out/bin -cp urbit $out/bin/$exename -cp urbit-worker $out/bin/$exename-worker +cp ./build/urbit $out/bin/$exename +cp ./build/urbit-worker $out/bin/$exename-worker diff --git a/nix/pkgs/urbit/default.nix b/nix/pkgs/urbit/default.nix index 66ea890f4..5e971e684 100644 --- a/nix/pkgs/urbit/default.nix +++ b/nix/pkgs/urbit/default.nix @@ -1,7 +1,7 @@ { pkgs, debug, - argon2, ed25519, ent, h2o, murmur3, scrypt, secp256k1, sni, softfloat3, uv + argon2, ed25519, ent, ge-additions, h2o, murmur3, scrypt, secp256k1, sni, softfloat3, uv }: let @@ -11,10 +11,10 @@ let deps = with pkgs; - [ curl gmp libsigsegv ncurses openssl zlib lmdb ]; + [ curl gmp libsigsegv ncurses openssl zlib lmdb cacert xxd ]; vendor = - [ argon2 softfloat3 ed25519 ent h2o scrypt uv murmur3 secp256k1 sni ]; + [ argon2 softfloat3 ed25519 ent ge-additions h2o scrypt uv murmur3 secp256k1 sni ]; in diff --git a/nix/pkgs/urbit/release.nix b/nix/pkgs/urbit/release.nix index 005f001b8..171a89161 100644 --- a/nix/pkgs/urbit/release.nix +++ b/nix/pkgs/urbit/release.nix @@ -1,6 +1,6 @@ { env_name, env, deps }: -{ ent, name ? "urbit", debug ? false }: +{ ent, ge-additions, cacert, xxd, name ? "urbit", debug ? false }: let @@ -10,7 +10,7 @@ let vendor = with deps; - [ argon2 softfloat3 ed25519 h2o scrypt uv murmur3 secp256k1 sni ]; + [ argon2 softfloat3 ed25519 ge-additions h2o scrypt uv murmur3 secp256k1 sni ]; in @@ -21,10 +21,12 @@ env.make_derivation { CPU_DEBUG = debug; EVENT_TIME_DEBUG = false; NCURSES = env.ncurses; + SSL_CERT_FILE = "${cacert}/etc/ssl/certs/ca-bundle.crt"; - name = "${name}-${env_name}"; - exename = name; - src = ../../../pkg/urbit; - cross_inputs = crossdeps ++ vendor ++ [ ent ]; - builder = ./release.sh; + name = "${name}-${env_name}"; + exename = name; + src = ../../../pkg/urbit; + native_inputs = [ xxd ]; + cross_inputs = crossdeps ++ vendor ++ [ ent ]; + builder = ./release.sh; } diff --git a/nix/pkgs/urbit/release.sh b/nix/pkgs/urbit/release.sh index e21dd63a7..76b35040a 100644 --- a/nix/pkgs/urbit/release.sh +++ b/nix/pkgs/urbit/release.sh @@ -14,9 +14,9 @@ PKG_CONFIG=pkg-config-cross \ HOST=$host \ bash ./configure -make urbit urbit-worker -j8 +make build/urbit build/urbit-worker -j8 mkdir -p $out/bin cp -r $NCURSES/share/terminfo $out/bin/$exename-terminfo -cp urbit $out/bin/$exename -cp urbit-worker $out/bin/$exename-worker +cp ./build/urbit $out/bin/$exename +cp ./build/urbit-worker $out/bin/$exename-worker diff --git a/nix/pkgs/urbit/shell.nix b/nix/pkgs/urbit/shell.nix index 4a6ea350e..60591b5b9 100644 --- a/nix/pkgs/urbit/shell.nix +++ b/nix/pkgs/urbit/shell.nix @@ -9,7 +9,8 @@ in import ./default.nix { inherit pkgs; debug = false; - inherit (tlon) ent; + inherit (tlon) + ent ge-additions; inherit (deps) argon2 ed25519 h2o murmur3 scrypt secp256k1 sni softfloat3 uv; } diff --git a/nix/release.nix b/nix/release.nix index 860d521d3..648d5e6b1 100644 --- a/nix/release.nix +++ b/nix/release.nix @@ -16,16 +16,21 @@ let ent = env: import ./pkgs/ent/cross.nix env; + ge-additions = env: + import ./pkgs/ge-additions/cross.nix env; + urbit = env: import ./pkgs/urbit/release.nix env - { ent = ent env; debug = false; name = "urbit"; }; + { ent = ent env; ge-additions = ge-additions env; cacert = nixpkgs.cacert; + xxd = nixpkgs.xxd; debug = false; name = "urbit"; }; builds-for-platform = plat: plat.deps // { inherit (plat.env) curl libgmp libsigsegv ncurses openssl zlib lmdb; inherit (plat.env) cmake_toolchain; - ent = ent plat; - urbit = urbit plat; + ent = ent plat; + ge-additions = ge-additions plat; + urbit = urbit plat; }; darwin_extra = { diff --git a/pkg/arvo b/pkg/arvo deleted file mode 160000 index 23507c12f..000000000 --- a/pkg/arvo +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 23507c12fbe8ff42cb165e1ec5456b895bf6de5b diff --git a/pkg/arvo/.gitignore b/pkg/arvo/.gitignore new file mode 100644 index 000000000..acdf57e8f --- /dev/null +++ b/pkg/arvo/.gitignore @@ -0,0 +1,3 @@ +/sec/**/*.atom +*.swp +*.swo diff --git a/pkg/arvo/.travis.yml b/pkg/arvo/.travis.yml new file mode 100644 index 000000000..cf984c634 --- /dev/null +++ b/pkg/arvo/.travis.yml @@ -0,0 +1,80 @@ +language: node_js +node_js: +- 4 + +before_install: +# pwd: ~/urbit/arvo +- cd .travis/ +- bash check-trailing-whitespace.sh +- cd ../../ +# pwd: ~/urbit +# building vere directly in lieu of a working debian package script +- wget https://github.com/ninja-build/ninja/releases/download/v1.8.2/ninja-linux.zip +- unzip ninja-linux.zip +- sudo mv ninja /usr/bin/ + +install: +# pwd: ~/urbit +- pip3 install --user -I meson==0.44.1 +- git clone https://github.com/urbit/urbit +- cd ./urbit +# pwd: ~/urbit/urbit +- git checkout $(cat ../arvo/.travis/pin-vere-commit.txt) +- ./scripts/bootstrap +- ./scripts/build +- sudo ninja -C build install +- cd ../arvo +# pwd: ~/urbit/arvo + +before_script: +- cd .travis +# pwd: ~/urbit/arvo/.travis +- npm install +- bash get-or-build-pill.sh +# https://github.com/travis-ci/travis-ci/issues/2570 + +script: +- ulimit -c unlimited -S +- npm run -s test; bash print-core-backtrace.sh $? + +before_deploy: "[ -d piers ] || { mkdir piers && tar cvzSf piers/zod-$TRAVIS_COMMIT.tgz zod/; }" + +addons: + apt: + packages: + - python3 + - python3-pip + - libgmp3-dev + - libsigsegv-dev + - openssl + - libssl-dev + - libncurses5-dev + - gcc + - libcurl4-gnutls-dev + - unzip + - gdb + +deploy: + - skip_cleanup: true + provider: gcs + access_key_id: GOOGTADOPP55X5ZTH3IKAXQW + secret_access_key: + secure: lALZvAW22oBMCXafvDOkqKDkdP0K8bGKlSb6uhh54z+2bJu49+5vrfxgA9YLcExGiz8uFttzNYhEoAQEjb96DPHAHvH2iJrwieKltrWM4hLkGuSHVSCBIIm+Qe4BVRSVJPQ1rtO1ausNr0XuzO6BVnKY7NCrz8la2XNjm5+miQdtrJUnrfy2JsM/c/Bkwjj3Tc4op9Ne+7Xzc9DI6LB97XiJx5PgeOx1WeZi9IKQ3IhPBHBzBpBrJ4lWxb4PFvDUqNzSk1wuMGy/sH73IFhGcz3CZRZYbeICDdwmHcUnkdPxG6+RLH+YLhSxx175R+HdaARRQvRANxvY9KNJ11NKmV3Rs9q7fZgWZbrptuB0CDMhfZ/Aiz9tgHGV0UVhYHb8n614fDIKzpXwIy5DPjCKpxPoZRVzABQcdzPTvxnZtZDbarsfdfq0vh9xXNPLGuFYZQnZ6iEpv17qp/2TbeCBSMKIxwIG3LQTwr0a4wKL1T/YIZm6oiN6NycHhMHaczQIRANKw9e7oqbgnXu/WnqHIxyTY2CCvzVOgipRmKKa7jz7CcSoP883XZ9o7WAOnfJY+T4ofpdkzHn1ElNXPjDPpX7CUkowNFH4DZk2Ljwe0CgxPOF6ygnsNrqqs4XoNQaBnHGXMq20Upg6OK9MBmZibtlX9STCeSAt4WudekpEOPU= + bucket: ci-piers.urbit.org + local-dir: piers/ + acl: public-read + on: + repo: urbit/arvo + all_branches: true + - skip_cleanup: true + provider: gcs + access_key_id: GOOGTADOPP55X5ZTH3IKAXQW + secret_access_key: + secure: lALZvAW22oBMCXafvDOkqKDkdP0K8bGKlSb6uhh54z+2bJu49+5vrfxgA9YLcExGiz8uFttzNYhEoAQEjb96DPHAHvH2iJrwieKltrWM4hLkGuSHVSCBIIm+Qe4BVRSVJPQ1rtO1ausNr0XuzO6BVnKY7NCrz8la2XNjm5+miQdtrJUnrfy2JsM/c/Bkwjj3Tc4op9Ne+7Xzc9DI6LB97XiJx5PgeOx1WeZi9IKQ3IhPBHBzBpBrJ4lWxb4PFvDUqNzSk1wuMGy/sH73IFhGcz3CZRZYbeICDdwmHcUnkdPxG6+RLH+YLhSxx175R+HdaARRQvRANxvY9KNJ11NKmV3Rs9q7fZgWZbrptuB0CDMhfZ/Aiz9tgHGV0UVhYHb8n614fDIKzpXwIy5DPjCKpxPoZRVzABQcdzPTvxnZtZDbarsfdfq0vh9xXNPLGuFYZQnZ6iEpv17qp/2TbeCBSMKIxwIG3LQTwr0a4wKL1T/YIZm6oiN6NycHhMHaczQIRANKw9e7oqbgnXu/WnqHIxyTY2CCvzVOgipRmKKa7jz7CcSoP883XZ9o7WAOnfJY+T4ofpdkzHn1ElNXPjDPpX7CUkowNFH4DZk2Ljwe0CgxPOF6ygnsNrqqs4XoNQaBnHGXMq20Upg6OK9MBmZibtlX9STCeSAt4WudekpEOPU= + bucket: bootstrap.urbit.org + local-dir: built-pill/ + acl: public-read + on: + condition: "-d built-pill/" + repo: urbit/arvo + all_branches: true diff --git a/pkg/arvo/.travis/.gitattributes b/pkg/arvo/.travis/.gitattributes new file mode 100644 index 000000000..c1611b63d --- /dev/null +++ b/pkg/arvo/.travis/.gitattributes @@ -0,0 +1,2 @@ +# Don't show in diffs or auto-merge +package-lock.json binary diff --git a/pkg/arvo/.travis/.gitignore b/pkg/arvo/.travis/.gitignore new file mode 100644 index 000000000..c2658d7d1 --- /dev/null +++ b/pkg/arvo/.travis/.gitignore @@ -0,0 +1 @@ +node_modules/ diff --git a/pkg/arvo/.travis/check-trailing-whitespace.sh b/pkg/arvo/.travis/check-trailing-whitespace.sh new file mode 100755 index 000000000..323aa4924 --- /dev/null +++ b/pkg/arvo/.travis/check-trailing-whitespace.sh @@ -0,0 +1,11 @@ +#!/bin/bash + +whitespace=$(find .. -path ../.git -prune -o \ + -type f -exec egrep -l " +$" {} \;); + +if [ ! -z $whitespace ] +then + echo 'found trailing whitespace in:'; + echo $whitespace; + exit 1; +fi diff --git a/pkg/arvo/.travis/get-or-build-pill.sh b/pkg/arvo/.travis/get-or-build-pill.sh new file mode 100644 index 000000000..25d7dfce0 --- /dev/null +++ b/pkg/arvo/.travis/get-or-build-pill.sh @@ -0,0 +1,64 @@ +#!/bin/bash +set -euo pipefail +set -x + +# add urbit-runner to $PATH +PATH=./node_modules/.bin/:$PATH + +# XX use -s instead of hash pill +HASH=$(git -C .. log -1 HEAD --format=%H -- sys/) +export PILL_NAME="git-${HASH:0:10}" + +if [ ! ${PILL_FORCE:-} ]; then + : Trying pill for commit + wget https://bootstrap.urbit.org/$PILL_NAME.pill -O urbit.pill && exit 0 +fi + +# if wget failed + +if [ ${TRAVIS_COMMIT:-} ] && [ $TRAVIS_COMMIT != $HASH ]; then + : Directory sys/ not modified in commit $TRAVIS_COMMIT + : FIXME ignoring, as current sys/ commits are unlikely to contain the pill-build code + : +# : For auto-build please tag and push $HASH +# exit 1 +fi + +mkdir prev +{ + : Pilling: trying pinned fakezod + wget -i pin-parent-pill-pier.url -O - | tar xvz -C prev/ && + : Downloaded prev/zod && + urbit-runner -S prev/zod <<' .' + |autoload | + |mount % + . + [ $? = 0 ] && cp -r ../sys prev/zod/home/ && + cp ../gen/solid.hoon prev/zod/home/gen/ && + cp ../lib/pill.hoon prev/zod/home/lib/ +} || { + : Pilling: Parent-pill pier not available, trying preceding pill commit + HASH2=$(git -C .. log -2 $HASH --format=%H -- sys/ | tail -1) + PILL_NAME2="git-${HASH2:0:10}" + wget https://bootstrap.urbit.org/$PILL_NAME2.pill -O prev/urbit.pill && + ([ -d prev/zod ] && rm -r prev/zod || true) && + urbit-runner -A .. -B prev/urbit.pill -cSF zod prev/zod <<' .' + %booted-prev-zod + . +} || { + : Pilling: Out of ideas + exit 1 +} + +: Pier created, soliding actual pill +urbit-runner -S prev/zod <<. + |label %home %$PILL_NAME + .urbit/pill +solid /==/$PILL_NAME/sys, =dub & +. + +cp prev/zod/.urb/put/urbit.pill urbit.pill +mkdir built-pill; cp urbit.pill built-pill/$PILL_NAME.pill + +: +: Created $PILL_NAME.pill, to be uploaded if tests pass +: diff --git a/pkg/arvo/.travis/package-lock.json b/pkg/arvo/.travis/package-lock.json new file mode 100644 index 000000000..337a0c70a --- /dev/null +++ b/pkg/arvo/.travis/package-lock.json @@ -0,0 +1,753 @@ +{ + "name": "arvo-tests", + "version": "1.0.0", + "lockfileVersion": 1, + "requires": true, + "dependencies": { + "ajv": { + "version": "5.5.2", + "resolved": "https://registry.npmjs.org/ajv/-/ajv-5.5.2.tgz", + "integrity": "sha1-c7Xuyj+rZT49P5Qis0GtQiBdyWU=", + "requires": { + "co": "^4.6.0", + "fast-deep-equal": "^1.0.0", + "fast-json-stable-stringify": "^2.0.0", + "json-schema-traverse": "^0.3.0" + } + }, + "array-differ": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/array-differ/-/array-differ-1.0.0.tgz", + "integrity": "sha1-7/UuN1gknTO+QCuLuOVkuytdQDE=" + }, + "array-union": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/array-union/-/array-union-1.0.2.tgz", + "integrity": "sha1-mjRBDk9OPaI96jdb5b5w8kd47Dk=", + "requires": { + "array-uniq": "^1.0.1" + } + }, + "array-uniq": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/array-uniq/-/array-uniq-1.0.3.tgz", + "integrity": "sha1-r2rId6Jcx/dOBYiUdThY39sk/bY=" + }, + "arrify": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/arrify/-/arrify-1.0.1.tgz", + "integrity": "sha1-iYUI2iIm84DfkEcoRWhJwVAaSw0=" + }, + "asap": { + "version": "2.0.6", + "resolved": "https://registry.npmjs.org/asap/-/asap-2.0.6.tgz", + "integrity": "sha1-5QNHYR1+aQlDIIu9r+vLwvuGbUY=" + }, + "asn1": { + "version": "0.2.4", + "resolved": "https://registry.npmjs.org/asn1/-/asn1-0.2.4.tgz", + "integrity": "sha512-jxwzQpLQjSmWXgwaCZE9Nz+glAG01yF1QnWgbhGwHI5A6FRIEY6IVqtHhIepHqI7/kyEyQEagBC5mBEFlIYvdg==", + "requires": { + "safer-buffer": "~2.1.0" + } + }, + "assert-plus": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/assert-plus/-/assert-plus-1.0.0.tgz", + "integrity": "sha1-8S4PPF13sLHN2RRpQuTpbB5N1SU=" + }, + "asynckit": { + "version": "0.4.0", + "resolved": "https://registry.npmjs.org/asynckit/-/asynckit-0.4.0.tgz", + "integrity": "sha1-x57Zf380y48robyXkLzDZkdLS3k=" + }, + "aws-sign2": { + "version": "0.7.0", + "resolved": "https://registry.npmjs.org/aws-sign2/-/aws-sign2-0.7.0.tgz", + "integrity": "sha1-tG6JCTSpWR8tL2+G1+ap8bP+dqg=" + }, + "aws4": { + "version": "1.8.0", + "resolved": "https://registry.npmjs.org/aws4/-/aws4-1.8.0.tgz", + "integrity": "sha512-ReZxvNHIOv88FlT7rxcXIIC0fPt4KZqZbOlivyWtXLt8ESx84zd3kMC6iK5jVeS2qt+g7ftS7ye4fi06X5rtRQ==" + }, + "balanced-match": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.0.tgz", + "integrity": "sha1-ibTRmasr7kneFk6gK4nORi1xt2c=" + }, + "bcrypt-pbkdf": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/bcrypt-pbkdf/-/bcrypt-pbkdf-1.0.2.tgz", + "integrity": "sha1-pDAdOJtqQ/m2f/PKEaP2Y342Dp4=", + "requires": { + "tweetnacl": "^0.14.3" + } + }, + "bluebird": { + "version": "2.11.0", + "resolved": "http://registry.npmjs.org/bluebird/-/bluebird-2.11.0.tgz", + "integrity": "sha1-U0uQM8AiyVecVro7Plpcqvu2UOE=" + }, + "brace-expansion": { + "version": "1.1.11", + "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-1.1.11.tgz", + "integrity": "sha512-iCuPHDFgrHX7H2vEI/5xpz07zSHB00TpugqhmYtVmMO6518mCuRMoOYFldEBl0g187ufozdaHgWKcYFb61qGiA==", + "requires": { + "balanced-match": "^1.0.0", + "concat-map": "0.0.1" + } + }, + "caseless": { + "version": "0.12.0", + "resolved": "https://registry.npmjs.org/caseless/-/caseless-0.12.0.tgz", + "integrity": "sha1-G2gcIf+EAzyCZUMJBolCDRhxUdw=" + }, + "co": { + "version": "4.6.0", + "resolved": "https://registry.npmjs.org/co/-/co-4.6.0.tgz", + "integrity": "sha1-bqa989hTrlTMuOR7+gvz+QMfsYQ=" + }, + "colors": { + "version": "1.3.2", + "resolved": "https://registry.npmjs.org/colors/-/colors-1.3.2.tgz", + "integrity": "sha512-rhP0JSBGYvpcNQj4s5AdShMeE5ahMop96cTeDl/v9qQQm2fYClE2QXZRi8wLzc+GmXSxdIqqbOIAhyObEXDbfQ==" + }, + "combined-stream": { + "version": "1.0.7", + "resolved": "https://registry.npmjs.org/combined-stream/-/combined-stream-1.0.7.tgz", + "integrity": "sha512-brWl9y6vOB1xYPZcpZde3N9zDByXTosAeMDo4p1wzo6UMOX4vumB+TP1RZ76sfE6Md68Q0NJSrE/gbezd4Ul+w==", + "requires": { + "delayed-stream": "~1.0.0" + } + }, + "concat-map": { + "version": "0.0.1", + "resolved": "https://registry.npmjs.org/concat-map/-/concat-map-0.0.1.tgz", + "integrity": "sha1-2Klr13/Wjfd5OnMDajug1UBdR3s=" + }, + "core-js": { + "version": "2.5.7", + "resolved": "https://registry.npmjs.org/core-js/-/core-js-2.5.7.tgz", + "integrity": "sha512-RszJCAxg/PP6uzXVXL6BsxSXx/B05oJAQ2vkJRjyjrEcNVycaqOmNb5OTxZPE3xa5gwZduqza6L9JOCenh/Ecw==" + }, + "core-util-is": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/core-util-is/-/core-util-is-1.0.2.tgz", + "integrity": "sha1-tf1UIgqivFq1eqtxQMlAdUUDwac=" + }, + "dashdash": { + "version": "1.14.1", + "resolved": "https://registry.npmjs.org/dashdash/-/dashdash-1.14.1.tgz", + "integrity": "sha1-hTz6D3y+L+1d4gMmuN1YEDX24vA=", + "requires": { + "assert-plus": "^1.0.0" + } + }, + "del": { + "version": "2.2.2", + "resolved": "https://registry.npmjs.org/del/-/del-2.2.2.tgz", + "integrity": "sha1-wSyYHQZ4RshLyvhiz/kw2Qf/0ag=", + "requires": { + "globby": "^5.0.0", + "is-path-cwd": "^1.0.0", + "is-path-in-cwd": "^1.0.0", + "object-assign": "^4.0.1", + "pify": "^2.0.0", + "pinkie-promise": "^2.0.0", + "rimraf": "^2.2.8" + } + }, + "delayed-stream": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/delayed-stream/-/delayed-stream-1.0.0.tgz", + "integrity": "sha1-3zrhmayt+31ECqrgsp4icrJOxhk=" + }, + "ecc-jsbn": { + "version": "0.1.2", + "resolved": "https://registry.npmjs.org/ecc-jsbn/-/ecc-jsbn-0.1.2.tgz", + "integrity": "sha1-OoOpBOVDUyh4dMVkt1SThoSamMk=", + "requires": { + "jsbn": "~0.1.0", + "safer-buffer": "^2.1.0" + } + }, + "emitter-mixin": { + "version": "0.0.3", + "resolved": "https://registry.npmjs.org/emitter-mixin/-/emitter-mixin-0.0.3.tgz", + "integrity": "sha1-WUjLKG8uSO3DslGnz8H3iDOW1lw=" + }, + "errno": { + "version": "0.1.7", + "resolved": "https://registry.npmjs.org/errno/-/errno-0.1.7.tgz", + "integrity": "sha512-MfrRBDWzIWifgq6tJj60gkAwtLNb6sQPlcFrSOflcP1aFmmruKQ2wRnze/8V6kgyz7H3FF8Npzv78mZ7XLLflg==", + "requires": { + "prr": "~1.0.1" + } + }, + "escape-string-regexp": { + "version": "1.0.5", + "resolved": "https://registry.npmjs.org/escape-string-regexp/-/escape-string-regexp-1.0.5.tgz", + "integrity": "sha1-G2HAViGQqN/2rjuyzwIAyhMLhtQ=" + }, + "extend": { + "version": "1.2.1", + "resolved": "https://registry.npmjs.org/extend/-/extend-1.2.1.tgz", + "integrity": "sha1-oPX9bPyDpf5J72mNYOyKYk3UV2w=" + }, + "extsprintf": { + "version": "1.3.0", + "resolved": "https://registry.npmjs.org/extsprintf/-/extsprintf-1.3.0.tgz", + "integrity": "sha1-lpGEQOMEGnpBT4xS48V06zw+HgU=" + }, + "fast-deep-equal": { + "version": "1.1.0", + "resolved": "http://registry.npmjs.org/fast-deep-equal/-/fast-deep-equal-1.1.0.tgz", + "integrity": "sha1-wFNHeBfIa1HaqFPIHgWbcz0CNhQ=" + }, + "fast-json-stable-stringify": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/fast-json-stable-stringify/-/fast-json-stable-stringify-2.0.0.tgz", + "integrity": "sha1-1RQsDK7msRifh9OnYREGT4bIu/I=" + }, + "forever-agent": { + "version": "0.6.1", + "resolved": "https://registry.npmjs.org/forever-agent/-/forever-agent-0.6.1.tgz", + "integrity": "sha1-+8cfDEGt6zf5bFd60e1C2P2sypE=" + }, + "form-data": { + "version": "2.3.3", + "resolved": "https://registry.npmjs.org/form-data/-/form-data-2.3.3.tgz", + "integrity": "sha512-1lLKB2Mu3aGP1Q/2eCOx0fNbRMe7XdwktwOruhfqqd0rIJWwN4Dh+E3hrPSlDCXnSR7UtZ1N38rVXm+6+MEhJQ==", + "requires": { + "asynckit": "^0.4.0", + "combined-stream": "^1.0.6", + "mime-types": "^2.1.12" + } + }, + "fs.realpath": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/fs.realpath/-/fs.realpath-1.0.0.tgz", + "integrity": "sha1-FQStJSMVjKpA20onh8sBQRmU6k8=" + }, + "getpass": { + "version": "0.1.7", + "resolved": "https://registry.npmjs.org/getpass/-/getpass-0.1.7.tgz", + "integrity": "sha1-Xv+OPmhNVprkyysSgmBOi6YhSfo=", + "requires": { + "assert-plus": "^1.0.0" + } + }, + "glob": { + "version": "7.1.3", + "resolved": "https://registry.npmjs.org/glob/-/glob-7.1.3.tgz", + "integrity": "sha512-vcfuiIxogLV4DlGBHIUOwI0IbrJ8HWPc4MU7HzviGeNho/UJDfi6B5p3sHeWIQ0KGIU0Jpxi5ZHxemQfLkkAwQ==", + "requires": { + "fs.realpath": "^1.0.0", + "inflight": "^1.0.4", + "inherits": "2", + "minimatch": "^3.0.4", + "once": "^1.3.0", + "path-is-absolute": "^1.0.0" + } + }, + "globby": { + "version": "5.0.0", + "resolved": "https://registry.npmjs.org/globby/-/globby-5.0.0.tgz", + "integrity": "sha1-69hGZ8oNuzMLmbz8aOrCvFQ3Dg0=", + "requires": { + "array-union": "^1.0.1", + "arrify": "^1.0.0", + "glob": "^7.0.3", + "object-assign": "^4.0.1", + "pify": "^2.0.0", + "pinkie-promise": "^2.0.0" + } + }, + "graceful-fs": { + "version": "4.1.15", + "resolved": "https://registry.npmjs.org/graceful-fs/-/graceful-fs-4.1.15.tgz", + "integrity": "sha512-6uHUhOPEBgQ24HM+r6b/QwWfZq+yiFcipKFrOFiBEnWdy5sdzYoi+pJeQaPI5qOLRFqWmAXUPQNsielzdLoecA==" + }, + "har-schema": { + "version": "2.0.0", + "resolved": "https://registry.npmjs.org/har-schema/-/har-schema-2.0.0.tgz", + "integrity": "sha1-qUwiJOvKwEeCoNkDVSHyRzW37JI=" + }, + "har-validator": { + "version": "5.1.0", + "resolved": "https://registry.npmjs.org/har-validator/-/har-validator-5.1.0.tgz", + "integrity": "sha512-+qnmNjI4OfH2ipQ9VQOw23bBd/ibtfbVdK2fYbY4acTDqKTW/YDp9McimZdDbG8iV9fZizUqQMD5xvriB146TA==", + "requires": { + "ajv": "^5.3.0", + "har-schema": "^2.0.0" + } + }, + "hoek": { + "version": "4.2.1", + "resolved": "http://registry.npmjs.org/hoek/-/hoek-4.2.1.tgz", + "integrity": "sha512-QLg82fGkfnJ/4iy1xZ81/9SIJiq1NGFUMGs6ParyjBZr6jW2Ufj/snDqTHixNlHdPNwN2RLVD0Pi3igeK9+JfA==" + }, + "http-signature": { + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/http-signature/-/http-signature-1.2.0.tgz", + "integrity": "sha1-muzZJRFHcvPZW2WmCruPfBj7rOE=", + "requires": { + "assert-plus": "^1.0.0", + "jsprim": "^1.2.2", + "sshpk": "^1.7.0" + } + }, + "inflight": { + "version": "1.0.6", + "resolved": "https://registry.npmjs.org/inflight/-/inflight-1.0.6.tgz", + "integrity": "sha1-Sb1jMdfQLQwJvJEKEHW6gWW1bfk=", + "requires": { + "once": "^1.3.0", + "wrappy": "1" + } + }, + "inherits": { + "version": "2.0.3", + "resolved": "https://registry.npmjs.org/inherits/-/inherits-2.0.3.tgz", + "integrity": "sha1-Yzwsg+PaQqUC9SRmAiSA9CCCYd4=" + }, + "is-path-cwd": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/is-path-cwd/-/is-path-cwd-1.0.0.tgz", + "integrity": "sha1-0iXsIxMuie3Tj9p2dHLmLmXxEG0=" + }, + "is-path-in-cwd": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/is-path-in-cwd/-/is-path-in-cwd-1.0.1.tgz", + "integrity": "sha512-FjV1RTW48E7CWM7eE/J2NJvAEEVektecDBVBE5Hh3nM1Jd0kvhHtX68Pr3xsDf857xt3Y4AkwVULK1Vku62aaQ==", + "requires": { + "is-path-inside": "^1.0.0" + } + }, + "is-path-inside": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/is-path-inside/-/is-path-inside-1.0.1.tgz", + "integrity": "sha1-jvW33lBDej/cprToZe96pVy0gDY=", + "requires": { + "path-is-inside": "^1.0.1" + } + }, + "is-typedarray": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/is-typedarray/-/is-typedarray-1.0.0.tgz", + "integrity": "sha1-5HnICFjfDBsR3dppQPlgEfzaSpo=" + }, + "isemail": { + "version": "2.2.1", + "resolved": "http://registry.npmjs.org/isemail/-/isemail-2.2.1.tgz", + "integrity": "sha1-A1PT2aYpUQgMJiwqoKQrjqjp4qY=" + }, + "isstream": { + "version": "0.1.2", + "resolved": "https://registry.npmjs.org/isstream/-/isstream-0.1.2.tgz", + "integrity": "sha1-R+Y/evVa+m+S4VAOaQ64uFKcCZo=" + }, + "items": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/items/-/items-2.1.1.tgz", + "integrity": "sha1-i9FtnIOxlSneWuoyGsqtp4NkoZg=" + }, + "joi": { + "version": "9.2.0", + "resolved": "http://registry.npmjs.org/joi/-/joi-9.2.0.tgz", + "integrity": "sha1-M4WseQGSEwy+Iw6ALsAskhW7/to=", + "requires": { + "hoek": "4.x.x", + "isemail": "2.x.x", + "items": "2.x.x", + "moment": "2.x.x", + "topo": "2.x.x" + } + }, + "jsbn": { + "version": "0.1.1", + "resolved": "https://registry.npmjs.org/jsbn/-/jsbn-0.1.1.tgz", + "integrity": "sha1-peZUwuWi3rXyAdls77yoDA7y9RM=" + }, + "json-schema": { + "version": "0.2.3", + "resolved": "https://registry.npmjs.org/json-schema/-/json-schema-0.2.3.tgz", + "integrity": "sha1-tIDIkuWaLwWVTOcnvT8qTogvnhM=" + }, + "json-schema-traverse": { + "version": "0.3.1", + "resolved": "https://registry.npmjs.org/json-schema-traverse/-/json-schema-traverse-0.3.1.tgz", + "integrity": "sha1-NJptRMU6Ud6JtAgFxdXlm0F9M0A=" + }, + "json-stringify-safe": { + "version": "5.0.1", + "resolved": "https://registry.npmjs.org/json-stringify-safe/-/json-stringify-safe-5.0.1.tgz", + "integrity": "sha1-Epai1Y/UXxmg9s4B1lcB4sc1tus=" + }, + "jsprim": { + "version": "1.4.1", + "resolved": "https://registry.npmjs.org/jsprim/-/jsprim-1.4.1.tgz", + "integrity": "sha1-MT5mvB5cwG5Di8G3SZwuXFastqI=", + "requires": { + "assert-plus": "1.0.0", + "extsprintf": "1.3.0", + "json-schema": "0.2.3", + "verror": "1.10.0" + } + }, + "junk": { + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/junk/-/junk-1.0.3.tgz", + "integrity": "sha1-h75jSIZJy9ym9Tqzm+yczSNH9ZI=" + }, + "maximatch": { + "version": "0.1.0", + "resolved": "https://registry.npmjs.org/maximatch/-/maximatch-0.1.0.tgz", + "integrity": "sha1-hs2NawTJ8wfAWmuUGZBtA2D7E6I=", + "requires": { + "array-differ": "^1.0.0", + "array-union": "^1.0.1", + "arrify": "^1.0.0", + "minimatch": "^3.0.0" + } + }, + "mime-db": { + "version": "1.37.0", + "resolved": "https://registry.npmjs.org/mime-db/-/mime-db-1.37.0.tgz", + "integrity": "sha512-R3C4db6bgQhlIhPU48fUtdVmKnflq+hRdad7IyKhtFj06VPNVdk2RhiYL3UjQIlso8L+YxAtFkobT0VK+S/ybg==" + }, + "mime-types": { + "version": "2.1.21", + "resolved": "https://registry.npmjs.org/mime-types/-/mime-types-2.1.21.tgz", + "integrity": "sha512-3iL6DbwpyLzjR3xHSFNFeb9Nz/M8WDkX33t1GFQnFOllWk8pOrh/LSrB5OXlnlW5P9LH73X6loW/eogc+F5lJg==", + "requires": { + "mime-db": "~1.37.0" + } + }, + "minimatch": { + "version": "3.0.4", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.0.4.tgz", + "integrity": "sha512-yJHVQEhyqPLUTgt9B83PXu6W3rx4MvvHvSUvToogpwoGDOUQ+yDrR0HRot+yOCdCO7u4hX3pWft6kWBBcqh0UA==", + "requires": { + "brace-expansion": "^1.1.7" + } + }, + "minimist": { + "version": "0.0.8", + "resolved": "http://registry.npmjs.org/minimist/-/minimist-0.0.8.tgz", + "integrity": "sha1-hX/Kv8M5fSYluCKCYuhqp6ARsF0=" + }, + "mkdirp": { + "version": "0.5.1", + "resolved": "http://registry.npmjs.org/mkdirp/-/mkdirp-0.5.1.tgz", + "integrity": "sha1-MAV0OOrGz3+MR2fzhkjWaX11yQM=", + "requires": { + "minimist": "0.0.8" + } + }, + "moment": { + "version": "2.22.2", + "resolved": "https://registry.npmjs.org/moment/-/moment-2.22.2.tgz", + "integrity": "sha1-PCV/mDn8DpP/UxSWMiOeuQeD/2Y=" + }, + "nan": { + "version": "2.3.5", + "resolved": "http://registry.npmjs.org/nan/-/nan-2.3.5.tgz", + "integrity": "sha1-gioNwmYpDOTNOhIoLKPn42Rmigg=" + }, + "oauth-sign": { + "version": "0.9.0", + "resolved": "https://registry.npmjs.org/oauth-sign/-/oauth-sign-0.9.0.tgz", + "integrity": "sha512-fexhUFFPTGV8ybAtSIGbV6gOkSv8UtRbDBnAyLQw4QPKkgNlsH2ByPGtMUqdWkos6YCRmAqViwgZrJc/mRDzZQ==" + }, + "object-assign": { + "version": "4.1.1", + "resolved": "https://registry.npmjs.org/object-assign/-/object-assign-4.1.1.tgz", + "integrity": "sha1-IQmtx5ZYh8/AXLvUQsrIv7s2CGM=" + }, + "once": { + "version": "1.4.0", + "resolved": "https://registry.npmjs.org/once/-/once-1.4.0.tgz", + "integrity": "sha1-WDsap3WWHUsROsF9nFC6753Xa9E=", + "requires": { + "wrappy": "1" + } + }, + "path-is-absolute": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/path-is-absolute/-/path-is-absolute-1.0.1.tgz", + "integrity": "sha1-F0uSaHNVNP+8es5r9TpanhtcX18=" + }, + "path-is-inside": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/path-is-inside/-/path-is-inside-1.0.2.tgz", + "integrity": "sha1-NlQX3t5EQw0cEa9hAn+s8HS9/FM=" + }, + "performance-now": { + "version": "2.1.0", + "resolved": "https://registry.npmjs.org/performance-now/-/performance-now-2.1.0.tgz", + "integrity": "sha1-Ywn04OX6kT7BxpMHrjZLSzd8nns=" + }, + "pify": { + "version": "2.3.0", + "resolved": "http://registry.npmjs.org/pify/-/pify-2.3.0.tgz", + "integrity": "sha1-7RQaasBDqEnqWISY59yosVMw6Qw=" + }, + "pinkie": { + "version": "2.0.4", + "resolved": "https://registry.npmjs.org/pinkie/-/pinkie-2.0.4.tgz", + "integrity": "sha1-clVrgM+g1IqXToDnckjoDtT3+HA=" + }, + "pinkie-promise": { + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/pinkie-promise/-/pinkie-promise-2.0.1.tgz", + "integrity": "sha1-ITXW36ejWMBprJsXh3YogihFD/o=", + "requires": { + "pinkie": "^2.0.0" + } + }, + "promise": { + "version": "7.3.1", + "resolved": "https://registry.npmjs.org/promise/-/promise-7.3.1.tgz", + "integrity": "sha512-nolQXZ/4L+bP/UGlkfaIujX9BKxGwmQ9OT4mOt5yvy8iK1h3wqTEJCijzGANTCCl9nWjY41juyAn2K3Q1hLLTg==", + "requires": { + "asap": "~2.0.3" + } + }, + "promise-streams": { + "version": "2.1.1", + "resolved": "https://registry.npmjs.org/promise-streams/-/promise-streams-2.1.1.tgz", + "integrity": "sha1-cwnx02mDMOp/rasZIvE5iSKayFo=", + "requires": { + "bluebird": "^2.10.2" + } + }, + "prr": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/prr/-/prr-1.0.1.tgz", + "integrity": "sha1-0/wRS6BplaRexok/SEzrHXj19HY=" + }, + "psl": { + "version": "1.1.29", + "resolved": "https://registry.npmjs.org/psl/-/psl-1.1.29.tgz", + "integrity": "sha512-AeUmQ0oLN02flVHXWh9sSJF7mcdFq0ppid/JkErufc3hGIV/AMa8Fo9VgDo/cT2jFdOWoFvHp90qqBH54W+gjQ==" + }, + "pty.js": { + "version": "0.3.1", + "resolved": "https://registry.npmjs.org/pty.js/-/pty.js-0.3.1.tgz", + "integrity": "sha1-gfW+0zLW5eeraFaI0boDc0ENUbU=", + "requires": { + "extend": "~1.2.1", + "nan": "2.3.5" + } + }, + "punycode": { + "version": "1.4.1", + "resolved": "https://registry.npmjs.org/punycode/-/punycode-1.4.1.tgz", + "integrity": "sha1-wNWmOycYgArY4esPpSachN1BhF4=" + }, + "qs": { + "version": "6.5.2", + "resolved": "https://registry.npmjs.org/qs/-/qs-6.5.2.tgz", + "integrity": "sha512-N5ZAX4/LxJmF+7wN74pUD6qAh9/wnvdQcjq9TZjevvXzSUo7bfmw91saqMjzGS2xq91/odN2dW/WOl7qQHNDGA==" + }, + "recursive-copy": { + "version": "2.0.9", + "resolved": "https://registry.npmjs.org/recursive-copy/-/recursive-copy-2.0.9.tgz", + "integrity": "sha512-0AkHV+QtfS/1jW01z3m2t/TRTW56Fpc+xYbsoa/bqn8BCYPwmsaNjlYmUU/dyGg9w8MmGoUWihU5W+s+qjxvBQ==", + "requires": { + "del": "^2.2.0", + "emitter-mixin": "0.0.3", + "errno": "^0.1.2", + "graceful-fs": "^4.1.4", + "junk": "^1.0.1", + "maximatch": "^0.1.0", + "mkdirp": "^0.5.1", + "pify": "^2.3.0", + "promise": "^7.0.1", + "slash": "^1.0.0" + } + }, + "request": { + "version": "2.88.0", + "resolved": "https://registry.npmjs.org/request/-/request-2.88.0.tgz", + "integrity": "sha512-NAqBSrijGLZdM0WZNsInLJpkJokL72XYjUpnB0iwsRgxh7dB6COrHnTBNwN0E+lHDAJzu7kLAkDeY08z2/A0hg==", + "requires": { + "aws-sign2": "~0.7.0", + "aws4": "^1.8.0", + "caseless": "~0.12.0", + "combined-stream": "~1.0.6", + "extend": "~3.0.2", + "forever-agent": "~0.6.1", + "form-data": "~2.3.2", + "har-validator": "~5.1.0", + "http-signature": "~1.2.0", + "is-typedarray": "~1.0.0", + "isstream": "~0.1.2", + "json-stringify-safe": "~5.0.1", + "mime-types": "~2.1.19", + "oauth-sign": "~0.9.0", + "performance-now": "^2.1.0", + "qs": "~6.5.2", + "safe-buffer": "^5.1.2", + "tough-cookie": "~2.4.3", + "tunnel-agent": "^0.6.0", + "uuid": "^3.3.2" + }, + "dependencies": { + "extend": { + "version": "3.0.2", + "resolved": "https://registry.npmjs.org/extend/-/extend-3.0.2.tgz", + "integrity": "sha512-fjquC59cD7CyW6urNXK0FBufkZcoiGG80wTuPujX590cB5Ttln20E2UB4S/WARVqhXffZl2LNgS+gQdPIIim/g==" + } + } + }, + "rimraf": { + "version": "2.6.2", + "resolved": "https://registry.npmjs.org/rimraf/-/rimraf-2.6.2.tgz", + "integrity": "sha512-lreewLK/BlghmxtfH36YYVg1i8IAce4TI7oao75I1g245+6BctqTVQiBP3YUJ9C6DQOXJmkYR9X9fCLtCOJc5w==", + "requires": { + "glob": "^7.0.5" + } + }, + "rx": { + "version": "4.1.0", + "resolved": "https://registry.npmjs.org/rx/-/rx-4.1.0.tgz", + "integrity": "sha1-pfE/957zt0D+MKqAP7CfmIBdR4I=" + }, + "safe-buffer": { + "version": "5.1.2", + "resolved": "https://registry.npmjs.org/safe-buffer/-/safe-buffer-5.1.2.tgz", + "integrity": "sha512-Gd2UZBJDkXlY7GbJxfsE8/nvKkUEU1G38c1siN6QP6a9PT9MmHB8GnpscSmMJSoF8LOIrt8ud/wPtojys4G6+g==" + }, + "safer-buffer": { + "version": "2.1.2", + "resolved": "https://registry.npmjs.org/safer-buffer/-/safer-buffer-2.1.2.tgz", + "integrity": "sha512-YZo3K82SD7Riyi0E1EQPojLz7kpepnSQI9IyPbHHg1XXXevb5dJI7tpyN2ADxGcQbHG7vcyRHk0cbwqcQriUtg==" + }, + "slash": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/slash/-/slash-1.0.0.tgz", + "integrity": "sha1-xB8vbDn8FtHNF61LXYlhFK5HDVU=" + }, + "split": { + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/split/-/split-1.0.1.tgz", + "integrity": "sha512-mTyOoPbrivtXnwnIxZRFYRrPNtEFKlpB2fvjSnCQUiAA6qAZzqwna5envK4uk6OIeP17CsdF3rSBGYVBsU0Tkg==", + "requires": { + "through": "2" + } + }, + "sshpk": { + "version": "1.15.2", + "resolved": "https://registry.npmjs.org/sshpk/-/sshpk-1.15.2.tgz", + "integrity": "sha512-Ra/OXQtuh0/enyl4ETZAfTaeksa6BXks5ZcjpSUNrjBr0DvrJKX+1fsKDPpT9TBXgHAFsa4510aNVgI8g/+SzA==", + "requires": { + "asn1": "~0.2.3", + "assert-plus": "^1.0.0", + "bcrypt-pbkdf": "^1.0.0", + "dashdash": "^1.12.0", + "ecc-jsbn": "~0.1.1", + "getpass": "^0.1.1", + "jsbn": "~0.1.0", + "safer-buffer": "^2.0.2", + "tweetnacl": "~0.14.0" + } + }, + "stream-snitch": { + "version": "0.0.3", + "resolved": "https://registry.npmjs.org/stream-snitch/-/stream-snitch-0.0.3.tgz", + "integrity": "sha1-iXp48TonFPqESqd74VR3qJbYUqk=" + }, + "through": { + "version": "2.3.8", + "resolved": "http://registry.npmjs.org/through/-/through-2.3.8.tgz", + "integrity": "sha1-DdTJ/6q8NXlgsbckEV1+Doai4fU=" + }, + "topo": { + "version": "2.0.2", + "resolved": "http://registry.npmjs.org/topo/-/topo-2.0.2.tgz", + "integrity": "sha1-zVYVdSU5BXwNwEkaYhw7xvvh0YI=", + "requires": { + "hoek": "4.x.x" + } + }, + "tough-cookie": { + "version": "2.4.3", + "resolved": "https://registry.npmjs.org/tough-cookie/-/tough-cookie-2.4.3.tgz", + "integrity": "sha512-Q5srk/4vDM54WJsJio3XNn6K2sCG+CQ8G5Wz6bZhRZoAe/+TxjWB/GlFAnYEbkYVlON9FMk/fE3h2RLpPXo4lQ==", + "requires": { + "psl": "^1.1.24", + "punycode": "^1.4.1" + } + }, + "tunnel-agent": { + "version": "0.6.0", + "resolved": "https://registry.npmjs.org/tunnel-agent/-/tunnel-agent-0.6.0.tgz", + "integrity": "sha1-J6XeoGs2sEoKmWZ3SykIaPD8QP0=", + "requires": { + "safe-buffer": "^5.0.1" + } + }, + "tweetnacl": { + "version": "0.14.5", + "resolved": "https://registry.npmjs.org/tweetnacl/-/tweetnacl-0.14.5.tgz", + "integrity": "sha1-WuaBd/GS1EViadEIr6k/+HQ/T2Q=" + }, + "urbit-runner": { + "version": "github:urbit/runner-js#ee2455015dc4ea243d0e0ec623975632c9249c4e", + "from": "github:urbit/runner-js#ee24550", + "requires": { + "colors": "^1.1.2", + "escape-string-regexp": "^1.0.5", + "once": "^1.4.0", + "promise-streams": "^2.1.1", + "pty.js": "^0.3.1", + "recursive-copy": "^2.0.7", + "split": "^1.0.1", + "stream-snitch": "0.0.3", + "wait-on": "^2.0.2" + } + }, + "uuid": { + "version": "3.3.2", + "resolved": "https://registry.npmjs.org/uuid/-/uuid-3.3.2.tgz", + "integrity": "sha512-yXJmeNaw3DnnKAOKJE51sL/ZaYfWJRl1pK9dr19YFCu0ObS231AB1/LbqTKRAQ5kw8A90rA6fr4riOUpTZvQZA==" + }, + "verror": { + "version": "1.10.0", + "resolved": "https://registry.npmjs.org/verror/-/verror-1.10.0.tgz", + "integrity": "sha1-OhBcoXBTr1XW4nDB+CiGguGNpAA=", + "requires": { + "assert-plus": "^1.0.0", + "core-util-is": "1.0.2", + "extsprintf": "^1.2.0" + } + }, + "wait-on": { + "version": "2.1.2", + "resolved": "https://registry.npmjs.org/wait-on/-/wait-on-2.1.2.tgz", + "integrity": "sha512-Jm6pzZkbswtcRUXohxY1Ek5MrL16AwHj83drgW2FTQuglHuhZhVMyBLPIYG0rL1wvr5rdC1uzRuU/7Bc+B9Pwg==", + "requires": { + "core-js": "^2.4.1", + "joi": "^9.2.0", + "minimist": "^1.2.0", + "request": "^2.78.0", + "rx": "^4.1.0" + }, + "dependencies": { + "minimist": { + "version": "1.2.0", + "resolved": "http://registry.npmjs.org/minimist/-/minimist-1.2.0.tgz", + "integrity": "sha1-o1AIsg9BOD7sH7kU9M1d95omQoQ=" + } + } + }, + "wrappy": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/wrappy/-/wrappy-1.0.2.tgz", + "integrity": "sha1-tSQ9jz7BqjXxNkYFvA0QNuMKtp8=" + } + } +} diff --git a/pkg/arvo/.travis/package.json b/pkg/arvo/.travis/package.json new file mode 100644 index 000000000..81237cbf4 --- /dev/null +++ b/pkg/arvo/.travis/package.json @@ -0,0 +1,14 @@ +{ + "name": "arvo-tests", + "version": "1.0.0", + "description": "Test harness for Urbit arvo distribution", + "scripts": { + "test": "node test.js" + }, + "private": true, + "author": "~fyr", + "license": "MIT", + "dependencies": { + "urbit-runner": "github:urbit/runner-js#ee24550" + } +} diff --git a/pkg/arvo/.travis/pin-parent-pill-pier.url b/pkg/arvo/.travis/pin-parent-pill-pier.url new file mode 100644 index 000000000..0a100e273 --- /dev/null +++ b/pkg/arvo/.travis/pin-parent-pill-pier.url @@ -0,0 +1 @@ +https://ci-piers.urbit.org/zod-d71780001aed3ba464d8b24f223f6bc597236718.tgz diff --git a/pkg/arvo/.travis/pin-vere-commit.txt b/pkg/arvo/.travis/pin-vere-commit.txt new file mode 100644 index 000000000..59ecdb221 --- /dev/null +++ b/pkg/arvo/.travis/pin-vere-commit.txt @@ -0,0 +1 @@ +d0401f0034e348ec1db498f2c7884194d99b6de4 diff --git a/pkg/arvo/.travis/print-core-backtrace.sh b/pkg/arvo/.travis/print-core-backtrace.sh new file mode 100644 index 000000000..52b421525 --- /dev/null +++ b/pkg/arvo/.travis/print-core-backtrace.sh @@ -0,0 +1,17 @@ +#!/bin/bash +set -euo pipefail +set -x + +RESULT=$1 + +if [[ ${RESULT} -eq 0 ]]; then + exit 0 +else + for i in $(find ./ -maxdepth 1 -name 'core*' -print) + do + gdb urbit core* -ex "thread apply all bt" -ex "set pagination 0" -batch + done +fi + +echo "build failed with status code $RESULT" +exit $RESULT diff --git a/pkg/arvo/.travis/test.js b/pkg/arvo/.travis/test.js new file mode 100644 index 000000000..3e8d0314c --- /dev/null +++ b/pkg/arvo/.travis/test.js @@ -0,0 +1,134 @@ +'use strict'; + +var fs = require('fs') +var runner = require('urbit-runner') +var Urbit = runner.Urbit; +var ERROR = runner.ERROR; +var actions = runner.actions + +var args = ['-B', 'urbit.pill', '-A', '..', '-cSF', 'zod', 'zod']; +var urbit = new Urbit(args); + +// XX upstream this into runner-js +// +function rePill(urb) { + return new Promise(function(resolve,reject){ + fs.stat('./built-pill/', function(err, stat) { + if (err) return resolve() + + fs.readdir('./built-pill/', function(err, files) { + if (err || (1 !== files.length)) { + return resolve() + } + + var name = files[0].replace(/\.pill$/, '') + + urb.note('re-soliding pill') + + return urb.expect(/dojo> /) + .then(function(){ + return urb.line('|label %home %' + name) + }) + .then(function(){ + return urb.expect(/dojo> /) + }) + .then(function(){ + return urb.line('.latest/pill +solid /==/' + name + '/sys') + }) + .then(function(){ + return urb.expectEcho("%resolid") + }) + .then(function(){ + return urb.resetListeners(); + }) + .then(function(){ + var write = fs.createWriteStream('./built-pill/' + name + '.pill') + var read = fs.createReadStream('./zod/.urb/put/latest.pill') + + read.on('error', function(err){ + return reject(err) + }) + + write.on('error', function(err){ + return reject(err) + }) + + write.on('finish', function(){ + return resolve() + }) + + return read.pipe(write) + }) + // XX find a better way to add this to the promise chain + // + .then(function(){ + return barMass(urb); + }) + .catch(function(err){ + return reject(err) + }); + }) + }) + }) +} + +// XX upstream this into runner-js +// +function barMass(urb) { + return urb.line("|mass") + .then(function(){ + return urb.expectEcho("%ran-mass") + .then(function(){ return urb.resetListeners(); }) + }) +} + +function aqua(urb) { + return urb.line("|start %ph") + .then(function(){ + return urb.line(":ph|init"); + }) + .then(function(){ + return urb.line(":aqua &pill +solid"); + }) + .then(function(){ + urb.every(/TEST [^ ]* FAILED/, function(arg){ + throw Error(arg); + }); + return urb.line(":ph|run %hi"); + }) + .then(function(){ + return urb.expectEcho("ALL TESTS SUCCEEDED") + .then(function(){ return urb.resetListeners(); }) + }) +} + +Promise.resolve(urbit) +.then(actions.safeBoot) +.then(function(){ + return barMass(urbit); +}) +.then(actions.test) +.then(actions.testCores) +.then(actions.testRenderers) +.then(function(){ + return barMass(urbit); +}) +.then(function(){ + return aqua(urbit); +}) +.then(function(){ + return rePill(urbit); +}) +.then(function(){ + return urbit.expect(/dojo> /); +}) +.then(function(){ + return urbit.exit(0); +}) +.catch(function(err){ + return urbit.waitSilent() + .then(function(){ + urbit.warn('Test aborted:', err); + return urbit.exit(1); + }); +}); diff --git a/pkg/arvo/LICENSE.txt b/pkg/arvo/LICENSE.txt new file mode 100644 index 000000000..eed28e653 --- /dev/null +++ b/pkg/arvo/LICENSE.txt @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2017 Urbit + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. \ No newline at end of file diff --git a/pkg/arvo/README.md b/pkg/arvo/README.md new file mode 100644 index 000000000..76398e367 --- /dev/null +++ b/pkg/arvo/README.md @@ -0,0 +1,66 @@ +# Arvo + +A clean-slate operating system. + +## Usage + +To run Arvo, you'll need [Urbit](https://github.com/urbit/urbit/). To install Urbit and run Arvo please follow the instructions in the [getting started docs](https://urbit.org/docs/getting-started/). You'll be on the live network in a few minutes. + +If you're doing development on Arvo, keep reading. + +## Documentation + +Find Arvo's documentation [on urbit.org](https://urbit.org/docs/learn/arvo/). + +## Development + +To boot a fake ship from your development files, run `urbit` with the following arguments: + +``` +urbit -F zod -A /path/to/arvo -c fakezod +``` + +Mount Arvo's filesystem allows you to update its contents through Unix. To do so, run `|mount` in dojo. It is most common to `|mount /=home=`. + +To create a custom pill (bootstrapping object) from the files loaded into the home desk, run `.my/pill +solid`. Your pill will appear in `/path/to/fakezod/.urb/put/my.pill`. + +To boot a fake ship with a custom pill, use the `-B` flag: + +``` +urbit -F zod -A /path/to/arvo -B /path/to.pill -c fakezod +``` + +To run all tests in `/tests`, run `+test` in dojo. `+test /some/path` would only run all tests in `/tests/some/path`. + +## Maintainers + +Most parts of Arvo have dedicated maintainers. + +* `/sys/hoon`: @pilfer-pandex (~pilfer-pandex) +* `/sys/zuse`: @pilfer-pandex (~pilfer-pandex) +* `/sys/arvo`: @jtobin (~nidsut-tomdun) +* `/sys/vane/ames`: @belisarius222 (~rovnys-ricfer) & @joemfb (~master-morzod) +* `/sys/vane/behn`: @belisarius222 (~rovnys-ricfer) +* `/sys/vane/clay`: @philipcmonk (~wicdev-wisryt) +* `/sys/vane/dill`: @bernardodelaplaz (~rigdyn-sondur) +* `/sys/vane/eyre`: @eglaysher (~littel-ponnys) +* `/sys/vane/ford`: @belisarius222 (~rovnys-ricfer) & @eglaysher (~littel-ponnys) +* `/sys/vane/gall`: @jtobin (~nidsut-tomdun) +* `/sys/vane/jael`: @fang- (~palfun-foslup) & @joemfb (~master-morzod) +* `/app/acme`: @joemfb (~master-morzod) +* `/app/dns`: @joemfb (~master-morzod) +* `/app/hall`: @fang- (~palfun-foslup) +* `/app/talk`: @fang- (~palfun-foslup) +* `/app/aqua`: @philipcmonk (~wicdev-wisryt) +* `/lib/test`: @eglaysher (~littel-ponnys) + +## Contributing + +Contributions of any form are more than welcome! If something doesn't seem right, and there is no issue about it yet, feel free to open one. + +If you're looking to make code contributions, there are a few things you can do: + +- Join the [urbit-dev](https://groups.google.com/a/urbit.org/forum/#!forum/dev) mailing list. +- [Ask us about Hoon School](mailto:support@urbit.org), a course we run to teach the Hoon programming language and Urbit application development. +- Check out [good contributor issues](https://github.com/urbit/arvo/issues?q=is%3Aopen+is%3Aissue+label%3A%22good+contributor+issue%22). +- Reach out to [support@urbit.org](mailto:support@urbit.org) to say hi and ask any questions you might have. diff --git a/pkg/arvo/TESTING.udon b/pkg/arvo/TESTING.udon new file mode 100644 index 000000000..faebbea83 --- /dev/null +++ b/pkg/arvo/TESTING.udon @@ -0,0 +1,57 @@ +:- ~[comments+&] +;> + +# Writing Unit Tests + +Urbit comes with a built in system for writing tests. Like hoon files with a +certain shape go in `%/app` or `%/gen` or `%/mar`, hoon files with a certain +shape can go in `%/tests` and then are exposed to a system wide test runner. + +Say you put a test suite in `%/tests/new-hoon/thr.hoon`: + +``` +> +ls %/tests +new-hoon/ +> +ls %/tests/new-hoon +ls/hoon mp/hoon myb/hoon thr/hoon +``` + +You can then just run that individual test suite (and not the ones that are beside it in the `%/tests/new-hoon` directory) with: + +``` +> +tests /new-hoon/thr +/new-hoon/thr/test-seconds OK +/new-hoon/thr/test-partition OK +/new-hoon/thr/test-firsts OK +/new-hoon/thr/test-apply OK +``` + +## The test file + +So what is the structure of these test files? They contain a door, with arms starting with `++test-` or `++check-`. At minimum: + +``` +/+ *test +|% +++ test-some-test + (expect-eq !>(4) !>(4)) +-- +``` + +All of the utilities you need to write tests are in the tester library. Also, like other hoon files, you can stack cores for models and utility functions with only the final core being inspected for test arms. + +## Some Details + +So internally, how does this work? + +The `+test` generator depends on each file/directory in `%/tests/` through a renderer. Each node in the filesystem tree is rendered by `%/ren/test-tree.hoon`, which calls itself recursively for subdirectories. + +This means all compiling of test cases happens inside ford, which can cache work and not recompile tests whose dependencies haven't changed. At runtime, all the `+test` generator does is filter and execute tests from the tree. + +I would like to get to a place where any direct scrying of the filesystem is discouraged, and almost everything flows through the functional reactive build system. This is what it is here for. + +### Future distribution of hoon libraries + +Implicit in having a standard way to write tests and a standard `+test` runner is the idea that all functionality on the current desk should be tested. + +Let's say I'm shipping a program on Urbit and I use multiple third-party libraries. Each of those libraries should have their own test suites placed in `%/tests/`. When I `|merge` their desks into my application desk, having a standard test runner means that all their tests and all my application tests get run. If you're depending on a library, you want to make sure that the tests for your dependencies run when you test your application. diff --git a/pkg/arvo/app/acme.hoon b/pkg/arvo/app/acme.hoon new file mode 100644 index 000000000..bb0df2ae4 --- /dev/null +++ b/pkg/arvo/app/acme.hoon @@ -0,0 +1,1394 @@ +/- asn1, hall +/+ base64, der, primitive-rsa, *pkcs, *jose +=, eyre +=* rsa primitive-rsa +:: +|% +:: +en-base64url: url-safe base64 encoding, without padding +:: +++ en-base64url + ~(en base64 | &) +:: +de-base64url: url-safe base64 decoding, without padding +:: +++ de-base64url + ~(de base64 | &) +:: +join-turf +:: +++ join-turf + |= hot=(list turf) + ^- cord + %+ rap 3 + %- (bake join ,[cord wain]) + [', ' (turn hot en-turf:html)] +:: |octn: encode/decode unsigned atoms as big-endian octet stream +:: +++ octn + |% + ++ en |=(a=@u `octs`[(met 3 a) (swp 3 a)]) + ++ de |=(a=octs `@u`(rev 3 p.a q.a)) + -- +:: |body: acme api response body types +:: +++ body + |% + +$ acct [wen=@t sas=@t] + :: + +$ order + $: exp=@t + sas=@t + aut=(list purl) + fin=(unit purl) + cer=(unit purl) + == + :: + +$ auth + $: dom=turf + sas=@t + exp=@t + cal=challenge + == + :: + +$ challenge [typ=@t sas=@t url=purl tok=@t err=(unit error)] + :: + +$ error [type=@t detail=@t] + -- +:: +:: |grab: acme api response json reparsers +:: +++ grab + =, dejs:format + |% + :: +json-purl: parse url + :: + ++ json-purl (su auri:de-purl:html) + :: +json-date: parse iso-8601 + :: + :: XX actually parse + :: + ++ json-date so + :: +directory: parse ACME service directory + :: + ++ directory + %- ot + :~ 'newAccount'^json-purl + 'newNonce'^json-purl + 'newOrder'^json-purl + 'revokeCert'^json-purl + 'keyChange'^json-purl + == + :: +acct: parse ACME service account + :: + ++ acct + ^- $-(json acct:body) + :: ignoring key, contact, initialIp + :: + (ot 'createdAt'^json-date 'status'^so ~) + :: +order: parse certificate order + :: + ++ order + ^- $-(json order:body) + %- ou + :~ 'expires'^(un json-date) + 'status'^(un so) + 'authorizations'^(uf ~ (ar json-purl)) + 'finalize'^(uf ~ (mu json-purl)) + 'certificate'^(uf ~ (mu json-purl)) + == + :: +auth: parse authorization + :: + ++ auth + => |% + :: +iden: extract +turf from service identifier + :: + ++ iden + |= [typ=@t hot=host] + ^- turf + ?>(&(?=(%dns typ) ?=([%& *] hot)) p.hot) + :: +http-trial: extract %http-01 challenge + :: + ++ trial + |= a=(list challenge:body) + ^- challenge:body + =/ b (skim a |=([typ=@t *] ?=(%http-01 typ))) + ?>(?=(^ b) i.b) + -- + ^- $-(json auth:body) + %- ot + :~ 'identifier'^(cu iden (ot type+so value+(su thos:de-purl:html) ~)) + 'status'^so + 'expires'^json-date + 'challenges'^(cu trial (ar challenge)) + == + :: +challenge: parse domain validation challenge + :: + ++ challenge + ^- $-(json challenge:body) + %- ou + :~ 'type'^(un so) + 'status'^(un so) + 'url'^(un json-purl) + 'token'^(un so) + 'error'^(uf ~ (mu error)) + == + :: +error: parse ACME service error response + :: + ++ error + ^- $-(json error:body) + (ot type+so detail+so ~) + -- +-- +:: +:::: acme state +:: +|% +:: +move: output effect +:: ++$ move [bone card] +:: +card: output effect payload +:: ++$ card + $% [%serve wire =binding:eyre =generator:eyre] + [%http-response =http-event:http] + [%poke wire dock poke] + [%request wire request:http outbound-config:iris] + [%rule wire %cert (unit [wain wain])] + [%wait wire @da] + == +:: +poke: outgoing app pokes +:: ++$ poke + $% [%hall-action %phrase audience:hall (list speech:hall)] + == +:: +nonce-next: next effect to emit upon receiving nonce +:: ++$ nonce-next + $? %register + %new-order + %finalize-order + %finalize-trial + == +:: +acct: an ACME service account +:: ++$ acct + $: :: key: account keypair + :: + key=key:rsa + :: reg: account registration + :: + :: XX wen=@da once parser is fixed + :: + reg=(unit [wen=@t kid=@t]) + == +:: +config: finalized configuration +:: ++$ config + $: :: dom: domains + :: + dom=(set turf) + :: key: certificate keypair + :: + key=key:rsa + :: cer: signed certificate + :: + cer=wain + :: exp: expiration date + :: + exp=@da + :: dor: source ACME service order URL + :: + dor=purl + == +:: +trial: domain validation challenge +:: ++$ trial + $% :: %http only for now + :: + $: %http + :: ego: ACME service challenge url + :: + ego=purl + :: tok: challenge token + :: + tok=@t + :: sas: challenge status + :: + sas=?(%recv %pend %auth) + == == +:: +auth: domain authorization +:: ++$ auth + $: :: ego: ACME service authorization url + :: + ego=purl + :: dom: domain under authorization + :: + dom=turf + :: cal: domain validation challenge + :: + cal=trial + == +:: +order-auth: domain authorization state for order processing +:: ++$ order-auth + $: :: pending: remote authorization urls + :: + pending=(list purl) + :: active: authorization in progress + :: + active=(unit [idx=@ auth]) + :: done: finalized authorizations (XX or failed?) + :: + done=(list auth) + == +:: +order: ACME certificate order +:: ++$ order + $: :: dom: domains + :: + dom=(set turf) + :: try: attempt number + :: + try=@ud + :: sas: order state + :: + sas=$@(%wake [%rest wen=@da]) + :: exp: expiration date + :: + :: XX @da once ISO-8601 parser + :: + exp=@t + :: ego: ACME service order url + :: + ego=purl + :: fin: ACME service order finalization url + :: + fin=purl + :: key: certificate keypair + :: + key=key:rsa + :: csr: DER-encoded PKCS10 certificate signing request + :: + csr=@ux + :: aut: authorizations required by this order + :: + aut=order-auth + == +:: +history: archive of past ACME service interactions +:: ++$ history + $: :: act: list of revoked account keypairs + :: + act=(list acct) + :: fig: list of expired configurations + :: + fig=(list config) + :: fal: list of failed order attempts + :: + fal=(list order) + == +:: +directory: ACME v2 service directory +:: ++$ directory + $: :: register: registration url (newAccount) + :: + register=purl + :: nonce: nonce creation url (newNonce) + :: + nonce=purl + :: new-order: order creation url (newOrder) + :: + new-order=purl + :: revoke: certificate revocation url (revokeCert) + :: + revoke=purl + :: rekey: account key revocation url (keyChange) + :: + rekey=purl + == +:: +acme: complete app state +:: ++$ acme + $: :: dir: ACME service directory + :: + dir=directory + :: act: ACME service account + :: + act=acct + :: liv: active, live configuration + :: + liv=(unit config) + :: hit: ACME account history + :: + hit=history + :: nonces: list of unused nonces + :: + nonces=(list @t) + :: rod: active, in-progress order + :: + rod=(unit order) + :: next-order: queued domains for validation + :: + next-order=(unit [try=@ud dom=(map turf [idx=@ud valid=?])]) + :: cey: certificate key XX move? + :: + cey=key:rsa + :: challenges: domain-validation challenge tokens + :: + challenges=(set @t) + == +-- +:: +:::: acme app +:: +:: directory-base: LetsEncrypt service directory url +:: +=/ directory-base=purl + =- (need (de-purl:html -)) + 'https://acme-v02.api.letsencrypt.org/directory' +:: mov: list of outgoing moves for the current transaction +:: +=| mov=(list move) +:: +|_ [bow=bowl:gall acme] +:: +this: self +:: +:: XX Should be a +* core alias, see urbit/arvo#712 +:: +++ this . +:: +emit: emit a move +:: +++ emit + |= car=card + this(mov [[ost.bow car] mov]) +:: +abet: finalize transaction +:: +++ abet + ^- (quip move _this) + [(flop mov) this(mov ~)] +:: +backoff: calculate exponential backoff +:: +++ backoff + |= try=@ud + ^- @dr + ?: =(0 try) ~s0 + %+ add + (mul ~s1 (bex (dec try))) + (mul ~s0..0001 (~(rad og eny.bow) 1.000)) +:: +acme-wire: create :acme http-request wire +:: +++ acme-wire + |= [try=@ud act=@tas =wire] + ^- ^wire + (weld /acme/try/(scot %ud try)/[act] wire) +:: +notify: send :hall notification +:: +++ notify + |= [=cord =tang] + ^- card + =/ msg=speech:hall + :+ %app dap.bow + =/ line [%lin & cord] + ?~(tang line [%fat [%tank tang] line]) + =/ act + [%phrase (sy [our.bow %inbox] ~) [msg ~]] + [%poke / [our.bow %hall] %hall-action act] +:: +request: unauthenticated http request +:: +++ request + |= [wir=wire req=hiss] + ^- card + [%request wir (hiss-to-request:html req) *outbound-config:iris] +:: +signed-request: JWS JSON POST +:: +++ signed-request + |= [url=purl non=@t bod=json] + ^- hiss + :^ url %post + (my content-type+['application/jose+json' ~] ~) + :- ~ + ^- octs + =; pro=json + (as-octt:mimes:html (en-json:html (sign:jws key.act pro bod))) + :- %o %- my :~ + nonce+s+non + url+s+(crip (en-purl:html url)) + ?^ reg.act + kid+s+kid.u.reg.act + jwk+(pass:en:jwk key.act) + == +:: +stateful-request: emit signed, nonce'd request +:: +++ stateful-request + |= [[try=@ud act=@tas =wire] =purl =json] + ^+ this + ?~ nonces + (nonce:effect [act wire]) + %- emit(nonces t.nonces) + %+ request (acme-wire try act wire) + (signed-request purl i.nonces json) +:: +bad-nonce: check if an http response is a badNonce error +:: +++ bad-nonce + |= rep=httr + ^- ? + :: XX always 400? + :: + ?. =(400 p.rep) | + ?~ r.rep | + =/ jon=(unit json) (de-json:html q.u.r.rep) + ?~ jon | + =('urn:ietf:params:acme:error:badNonce' type:(error:grab u.jon)) +:: +rate-limited: handle Acme service rate-limits +:: +++ rate-limited + |= [try=@ud act=@tas spur=wire bod=(unit octs)] + ^+ this + =/ jon=(unit json) + ?~(bod ~ (de-json:html q.u.bod)) + ?~ jon + :: no details, back way off + :: XX specifically based on wire + :: + (retry:effect try act spur (min ~d1 (backoff (add 10 try)))) + =/ err (error:grab u.jon) + ?. =('params:acme:error:rateLimited' type.err) + :: incorrect 429 status? backoff normally + :: + (retry:effect try act spur (min ~h1 (backoff try))) + + =/ detail (trip detail.err) + :: too many certificates for these domains + :: + ?: ?=(^ (find "already issued for exact" detail)) + =. ..this (retry:effect try act spur ~d7) + =/ msg=cord + %+ rap 3 + :~ 'rate limit exceeded: ' + ' too many certificates issued for ' + ?~ rod + :: XX shouldn't happen + :: + (en-turf:html /network/arvo/(crip +:(scow %p our.bow))) + (join-turf ~(tap in dom.u.rod)) + '. retrying in ~d7.' + == + (emit (notify msg ~)) + :: too many certificates for top-level-domain + :: + ?: ?=(^ (find "too many certificates already" detail)) + =. ..this (retry:effect try act spur ~d7) + =/ lul=@dr + (add ~d7 (mul ~m1 (~(rad og eny.bow) (bex 10)))) + =/ msg=cord + %+ rap 3 + :~ 'rate limit exceeded: ' + ' too many certificates issued for ' + :: XX get from detail + :: + (en-turf:html /network/arvo) + '. retrying in ' + (scot %dr lul) '.' + == + (emit (notify msg ~)) + :: XX match more rate-limit conditions + :: or backoff by wire + :: + :: - "too many registrations for this IP" + :: - "too many registrations for this IP range" + :: - "too many currently pending authorizations" + :: - "too many failed authorizations recently" + :: - "too many new orders recently" + :: + (retry:effect try act spur (min ~d1 (backoff (add 10 try)))) +:: +failure-message: generic http failure message +:: +++ failure-message + |= =purl + ^- cord + %+ rap 3 + :~ 'unable to reach ' + (crip (en-purl:html purl)) '. ' + 'please confirm your urbit has network connectivity.' + == +:: |effect: send moves to advance +:: +++ effect + |_ try-count=(unit @ud) + :: +try: this effect attempt number + :: + ++ try (fall try-count 1) + :: +validate-domain: confirm that a pending domain resolves to us + :: + ++ validate-domain + |= idx=@ud + ^+ this + ~| %validate-domain-effect-fail + ?. ?=(^ next-order) ~|(%no-next-order !!) + =/ pending + (skip ~(tap by dom.u.next-order) |=([turf @ud valid=?] valid)) + ?: =(~ pending) + new-order:effect + =/ next=[=turf idx=@ud valid=?] + ~| [%no-next-domain idx=idx] + (head (skim pending |=([turf idx=@ud ?] =(idx ^idx)))) + :: XX should confirm that :turf points to us + :: confirms that domain exists (and an urbit is on :80) + :: + =/ =purl + :- [sec=| por=~ host=[%& turf.next]] + [[ext=`~.udon path=/static] query=~] + =/ =wire + (acme-wire try %validate-domain /idx/(scot %ud idx.next)) + (emit (request wire purl %get ~ ~)) + :: +directory: get ACME service directory + :: + ++ directory + ^+ this + :: XX now in wire? + :: + (emit (request (acme-wire try %directory /) directory-base %get ~ ~)) + :: +nonce: get a new nonce for the next request + :: + ++ nonce + |= nex=wire + ~| [%bad-nonce-next nex] + ?> ?& ?=(^ nex) + ?=(nonce-next i.nex) + == + ^+ this + :: XX now in wire? + :: + =/ =wire + (acme-wire try %nonce [%next nex]) + (emit (request wire nonce.dir %get ~ ~)) + :: +register: create ACME service account + :: + :: Note: accepts services ToS. + :: XX add rekey mechanism + :: + ++ register + ^+ this + ?. =(~ reg.act) + ?: =(~ next-order) + this + (validate-domain:effect 0) + =/ =json [%o (my [['termsOfServiceAgreed' b+&] ~])] + :: XX date in wire? + :: + =/ wire-params [try %register /] + (stateful-request wire-params register.dir json) + :: +renew: renew certificate + :: + ++ renew + ^+ this + ~| %renew-effect-fail + ?. ?=(^ reg.act) ~|(%no-account !!) + ?. ?=(^ liv) ~|(%no-live-config !!) + =< new-order:effect + (queue-next-order 1 & dom.u.liv) + :: +new-order: create a new certificate order + :: + ++ new-order + ^+ this + ~| %new-order-effect-fail + ?. ?=(^ reg.act) ~|(%no-account !!) + ?. ?=([~ ^] next-order) ~|(%no-domains !!) + =/ =json + :- %o %- my :~ + :- %identifiers + :- %a + %+ turn + ~(tap in ~(key by `(map turf *)`dom.u.next-order)) + |=(a=turf [%o (my type+s+'dns' value+s+(en-turf:html a) ~)]) + == + =/ wire-params [try %new-order /(scot %da now.bow)] + (stateful-request wire-params new-order.dir json) + :: +cancel-order: cancel failed order, set retry timer + :: + ++ cancel-order + ^+ this + ~| %cancel-order-effect-fail + =* order ?>(?=(^ rod) u.rod) :: XX TMI + :: backoff faster than usual + :: + =/ lul=@dr (min ~h1 (backoff (add 5 try.order))) + :: XX get failure reason + :: + =/ msg=cord + (cat 3 'retrying certificate request in ' (scot %dr lul)) + =. ..this (emit (notify msg ~)) + =. ..this (retry:effect try %new-order / lul) + :: domains might already be validated + :: + =. ..this (queue-next-order +(try.order) & dom.order) + cancel-current-order + :: +finalize-order: finalize completed order + :: + ++ finalize-order + ^+ this + ~| %finalize-order-effect-fail + ?. ?=(^ reg.act) ~|(%no-account !!) + ?. ?=(^ rod) ~|(%no-active-order !!) + ?. ?=(~ pending.aut.u.rod) ~|(%pending-authz !!) + ?. ?=(~ active.aut.u.rod) ~|(%active-authz !!) + :: XX revisit wrt rate limits + :: + ?> ?=(%wake sas.u.rod) + =/ =json + [%o (my csr+s+(en-base64url (met 3 csr.u.rod) `@`csr.u.rod) ~)] + =/ wire-params [try %finalize-order /(scot %da now.bow)] + (stateful-request wire-params fin.u.rod json) + :: +check-order: check completed order for certificate availability + :: + ++ check-order + ^+ this + ~| %check-order-effect-fail + ?. ?=(^ reg.act) ~|(%no-account !!) + ?. ?=(^ rod) ~|(%no-active-order !!) + ?. ?=(~ pending.aut.u.rod) ~|(%pending-authz !!) + ?. ?=(~ active.aut.u.rod) ~|(%active-authz !!) + :: XX revisit wrt rate limits + :: + ?> ?=(%wake sas.u.rod) + =/ =wire + (acme-wire try %check-order /(scot %da now.bow)) + (emit (request wire ego.u.rod %get ~ ~)) + :: +certificate: download PEM-encoded certificate + :: + ++ certificate + |= url=purl + ^+ this + ~| %certificate-effect-fail + ?. ?=(^ reg.act) ~|(%no-account !!) + ?. ?=(^ rod) ~|(%no-active-order !!) + =/ hed (my accept+['applicate/x-pem-file' ~] ~) + =/ =wire + (acme-wire try %certificate /(scot %da now.bow)) + (emit (request wire url %get hed ~)) + :: +install: tell %eyre about our certificate + :: + ++ install + ^+ this + ~| %install-effect-fail + ?> ?=(^ liv) + =/ key=wain (ring:en:pem:pkcs8 key.u.liv) + (emit %rule /install %cert `[key `wain`cer.u.liv]) + :: +get-authz: get next ACME service domain authorization object + :: + ++ get-authz + ^+ this + ~| %get-authz-effect-fail + ?. ?=(^ reg.act) ~|(%no-account !!) + ?. ?=(^ rod) ~|(%no-active-order !!) + ?. ?=(^ pending.aut.u.rod) ~|(%no-pending-authz !!) + :: XX revisit wrt rate limits + :: + ?> ?=(%wake sas.u.rod) + =/ =wire + (acme-wire try %get-authz /(scot %da now.bow)) + (emit (request wire i.pending.aut.u.rod %get ~ ~)) + :: XX check/finalize-authz ?? + :: + :: +test-trial: confirm that ACME domain validation challenge is available + :: + ++ test-trial + ^+ this + ~| %test-trial-effect-fail + ?. ?=(^ reg.act) ~|(%no-account !!) + ?. ?=(^ rod) ~|(%no-active-order !!) + ?. ?=(^ active.aut.u.rod) ~|(%no-active-authz !!) + :: XX revisit wrt rate limits + :: + ?> ?=(%wake sas.u.rod) + =* aut u.active.aut.u.rod + =/ pat=path /'.well-known'/acme-challenge/[tok.cal.aut] + :: note: requires port 80, just as the ACME service will + :: + =/ url=purl [[sec=| por=~ hos=[%& dom.aut]] [ext=~ pat] hed=~] + :: =/ url=purl [[sec=| por=`8.081 hos=[%& /localhost]] [ext=~ pat] hed=~] + :: XX idx in wire? + :: + =/ =wire + (acme-wire try %test-trial /(scot %da now.bow)) + (emit (request wire url %get ~ ~)) + :: +finalize-trial: notify ACME service that challenge is ready + :: + ++ finalize-trial + ^+ this + ~| %finalize-trial-effect-fail + ?. ?=(^ reg.act) ~|(%no-account !!) + ?. ?=(^ rod) ~|(%no-active-order !!) + ?. ?=(^ active.aut.u.rod) ~|(%no-active-authz !!) + :: XX revisit wrt rate limits + :: + ?> ?=(%wake sas.u.rod) + =* aut u.active.aut.u.rod + :: empty object included for signature + :: XX include index in wire? + :: + =/ wire-params [try %finalize-trial /(scot %da now.bow)] + (stateful-request wire-params ego.cal.aut [%o ~]) + :: XX delete-trial? + :: + :: +retry: retry effect after timeout + :: + ++ retry + |= [try=@ud act=@tas =wire lull=@dr] + :: XX validate wire + :: + (emit %wait (acme-wire +(try) act wire) (add now.bow lull)) + -- +:: |event: accept event, emit next effect(s) +:: +:: XX should these next effects be triggered at call sites instead? +:: +++ event + |_ try=@ud + :: +validate-domain: accept a pending domain confirmation response + :: + ++ validate-domain + |= [=wire rep=httr] + ^+ this + ?> ?=([%idx @ *] wire) + ?. ?=(^ next-order) + this + =/ idx (slav %ud i.t.wire) + =/ valid |(=(200 p.rep) =(307 p.rep)) + =/ item=(list [=turf idx=@ud valid=?]) + (skim ~(tap by dom.u.next-order) |=([turf idx=@ud ?] =(^idx idx))) + ?. ?& ?=([^ ~] item) + !valid.i.item + == + this + =. dom.u.next-order + (~(put by dom.u.next-order) turf.i.item [idx valid]) + ?. valid + ?: (lth try 10) + =/ lul=@dr (min ~h1 (backoff try)) + (retry:effect try %validate-domain /idx/(scot %ud idx) lul) + :: XX remove next-order, cancel pending requests + :: XX include suggestion to fix + :: + =/ msg=cord + %+ rap 3 + :~ 'unable to reach ' (scot %p our.bow) + ' via http at ' (en-turf:html turf.i.item) ':80' + == + (emit(next-order ~) (notify msg [(sell !>(rep)) ~])) + ?: ?=(~ (skip ~(val by dom.u.next-order) |=([@ud valid=?] valid))) + new-order:effect + (validate-domain:effect +(idx)) + :: +directory: accept ACME service directory, trigger registration + :: + ++ directory + |= [wir=wire rep=httr] + ^+ this + ?. =(200 p.rep) + ?: (lth try 10) + (retry:effect try %directory / (min ~m30 (backoff try))) + (emit (notify (failure-message directory-base) [(sell !>(rep)) ~])) + =. dir (directory:grab (need (de-json:html q:(need r.rep)))) + ?~(reg.act register:effect this) + :: +nonce: accept new nonce and trigger next effect + :: + :: Nonce has already been saved in +http-response. The next effect + :: is specified in the wire. + :: + ++ nonce + |= [=wire rep=httr] + ^+ this + ~| [%unrecognized-nonce-wire wire] + ?> &(?=(^ wire) ?=([%next ^] wire)) + =* nex i.t.wire + ~| [%unknown-nonce-next nex] + ?> ?=(nonce-next nex) + ?. =(204 p.rep) + ?: (lth try 10) + (retry:effect try %nonce t.wire (min ~m30 (backoff try))) + (emit (notify (failure-message nonce.dir) [(sell !>(rep)) ~])) + ?- nex + %register register:effect + %new-order new-order:effect + %finalize-order finalize-order:effect + %finalize-trial finalize-trial:effect + == + :: +register: accept ACME service registration + :: + ++ register + |= [wir=wire rep=httr] + ^+ this + ?. |(=(200 p.rep) =(201 p.rep)) + :: XX possible 204? + :: + ?: (lth try 10) + (retry:effect try %register / (min ~h1 (backoff try))) + (emit (notify (failure-message register.dir) [(sell !>(rep)) ~])) + =/ loc=@t + q:(head (skim q.rep |=((pair @t @t) ?=(%location p)))) + :: XX @da once parser is fixed + :: + =/ wen=@t + ?~ r.rep + (scot %da now.bow) + =/ bod=acct:body + (acct:grab (need (de-json:html q.u.r.rep))) + ?> ?=(%valid sas.bod) + wen.bod + =. reg.act `[wen loc] + ?: =(~ next-order) + this + (validate-domain:effect 0) + :: XX rekey + :: + :: +new-order: order created, begin processing authorizations + :: + ++ new-order + |= [wir=wire rep=httr] + ^+ this + ?. =(201 p.rep) + :: XX possible 204? + :: + ?: (lth try 10) + (retry:effect try %new-order / (min ~h1 (backoff try))) + :: XX next steps, retrying in ?? + :: + (emit (notify (failure-message register.dir) [(sell !>(rep)) ~])) + ?> ?=(^ next-order) + =/ loc=@t + q:(head (skim q.rep |=((pair @t @t) ?=(%location p)))) + =/ ego=purl (need (de-purl:html loc)) + :: XX parse identifiers, confirm equal to pending domains + :: XX check status + :: + =/ bod=order:body + (order:grab (need (de-json:html q:(need r.rep)))) + =/ dom=(set turf) ~(key by dom.u.next-order) + :: XX maybe generate key here? + :: + =/ csr=@ux +:(en:der:pkcs10 cey ~(tap in dom)) + =/ dor=order + :* dom + try.u.next-order + sas=%wake + exp.bod + ego + (need fin.bod) + cey + csr + [aut.bod ~ ~] + == + get-authz:effect(rod `dor, next-order ~) + :: +finalize-order: order finalized, poll for certificate + :: + ++ finalize-order + |= [wir=wire rep=httr] + ^+ this + ?: =(504 p.rep) + :: retry timeouts frequently + :: + (retry:effect try %finalize-order / (min ~m10 (backoff try))) + :: check-order regardless of status code + :: + check-order:effect + :: +check-order: check order status, dispatch appropriately + :: + ++ check-order + |= [wir=wire rep=httr] + ^+ this + ~| [%strange-check-order wir] + ?> ?=(^ rod) + ?. =(200 p.rep) + ?: (lth try 10) + (retry:effect try %check-order / (min ~m10 (backoff try))) + :: XX next steps, retrying in, delete order ?? + :: + (emit (notify (failure-message ego.u.rod) [(sell !>(rep)) ~])) + =/ bod=order:body + (order:grab (need (de-json:html q:(need r.rep)))) + ?+ sas.bod + ~& [%check-order-status-unknown sas.bod] + this + :: order failed (at any stage) + :: + %invalid + ~& [%check-order-fail %invalid wir rep] + :: XX check authz, get the failure reason + :: XX possible to retry any reasons? + :: + =< cancel-order:effect + (emit (notify 'certificate order failed' [(sell !>(rep)) ~])) + :: initial order state + :: + %pending + check-order:effect + :: validations completed + :: + %ready + finalize-order:effect + :: finalization requested + :: + %processing + check-order:effect + :: certificate issued + :: + %valid + :: XX update order state + :: XX =< delete-trial + :: + ~| impossible-order+[wir rep bod] + (certificate:effect (need cer.bod)) + == + :: + :: +certificate: accept PEM-encoded certificate + :: + ++ certificate + |= [wir=wire rep=httr] + ^+ this + ~| [%strange-certificate-response wir] + ?> ?=(^ rod) + ?. =(200 p.rep) + :: will re-attempt certificate download per order status + :: + ?: (lth try 10) + (retry:effect try %check-order / (min ~m10 (backoff try))) + :: XX next steps, retrying in, get url somehow ?? + :: + =/ msg=cord + %+ rap 3 + :~ 'unable to download certificate. ' + 'please confirm that your urbit has network connectivity.' + == + (emit (notify msg [(sell !>(rep)) ~])) + =/ cer=wain (to-wain:format q:(need r.rep)) + =/ fig=config + :: XX expiration date + :: + [dom.u.rod key.u.rod cer (add now.bow ~d90) ego.u.rod] + :: archive live config + :: + =? fig.hit ?=(^ liv) [u.liv fig.hit] + :: save new live config, clear active order + :: + => .(liv (some fig), rod ~) + ?> ?=(^ liv) + :: notify :hall + :: + => =/ msg=cord + %+ rap 3 + :~ 'received https certificate for ' + (join-turf ~(tap in dom.u.liv)) + == + (emit (notify msg ~)) + :: set renewal timer, install certificate in %eyre + :: + :: Certificates expire after ~d90. We want time for retries and + :: to work around rate limits, so our renewal timer is for ~d60. + :: Renewals count towards weekly rate limits, but are allowed to + :: continue past rate limits, so fudge the timer towards the end + :: of the week nearest ~d60. + :: + =< install:effect + =; lul=@dr + (retry:effect 0 %renew / lul) + %+ add + (mul ~m1 (~(rad og eny.bow) (bex 8))) + =/ weekday (daws:chrono:userlib (yore now.bow)) + ?: (gth weekday 4) + (sub ~d60 (mul ~d1 (sub weekday 4))) + (add ~d60 (mul ~d1 (sub 4 weekday))) + :: +get-authz: accept ACME service authorization object + :: + ++ get-authz + |= [wir=wire rep=httr] + ^+ this + ~| [%strange-authorization wir] + ?> ?=(^ rod) + ?> ?=(^ pending.aut.u.rod) + ?. =(200 p.rep) + ?: (lth try 10) + (retry:effect try %get-authz / (min ~m10 (backoff try))) + :: XX next steps, retrying in ?? + :: + (emit (notify (failure-message i.pending.aut.u.rod) [(sell !>(rep)) ~])) + =/ bod=auth:body + (auth:grab (need (de-json:html q:(need r.rep)))) + =/ cal=trial + :: XX parse token to verify url-safe base64? + :: + [%http url.cal.bod tok.cal.bod %recv] + :: XX check that URLs are the same + :: + =/ tau=auth [i.pending.aut.u.rod dom.bod cal] + :: XX get idx from wire instead? + :: + =/ idx=@ud +((lent done.aut.u.rod)) + =/ rod-aut=order-auth + %= aut.u.rod + pending t.pending.aut.u.rod + active `[idx tau] + == + :: XX space leak, should be pruned on order completion or timeout + :: + =. challenges (~(put in challenges) tok.cal) + test-trial:effect(aut.u.rod rod-aut) + :: XX check/finalize-authz ?? + :: + :: +test-trial: accept response from challenge test + :: + ++ test-trial + |= [wir=wire rep=httr] + ~| [%strange-test-trial wir] + ?> ?=(^ rod) + ?> ?=(^ active.aut.u.rod) + =* aut u.active.aut.u.rod + ^+ this + ?. =(200 p.rep) + ?: (lth try 10) + (retry:effect try %test-trial / (min ~m10 (backoff try))) + :: XX next steps, check connectivity, etc. ?? + :: + =< cancel-order:effect + =/ msg=cord + %+ rap 3 + :~ 'unable to retrieve self-hosted domain validation token ' + 'via ' (en-turf:html dom.aut) '. ' + 'please confirm your urbit has network connectivity.' + == + (emit (notify msg [(sell !>(rep)) ~])) + =/ bod + %- as-octs:mimes:html + (rap 3 [tok.cal.aut '.' (pass:thumb:jwk key.act) ~]) + ?. ?& ?=(^ r.rep) + =(bod u.r.rep) + == + :: XX probably a DNS misconfiguration + :: + =/ =tang + :~ ?~(r.rep leaf+"~" (sell !>(u.r.rep))) + leaf+"actual:" + (sell !>((some bod))) + leaf+"expected:" + == + (emit (notify 'domain validation value is wrong' tang)) + finalize-trial:effect + :: +finalize-trial: + :: + ++ finalize-trial + |= [wir=wire rep=httr] + ^+ this + ~| [%strange-finalize-trial wir] + ?> ?=(^ rod) + ?> ?=(^ active.aut.u.rod) + =* aut u.active.aut.u.rod + ?. =(200 p.rep) + :: XX possible 204? assume pending? + :: XX handle "challenge is not pending" + :: + ?: =(504 p.rep) + :: retry timeouts frequently + :: + ?: (lth try 10) + (retry:effect try %finalize-trial / (min ~m10 (backoff try))) + :: XX next steps, check connectivity, etc. ?? + :: + (emit (notify (failure-message ego.cal.aut) [(sell !>(rep)) ~])) + :: XX get challenge, confirm urn:ietf:params:acme:error:connection + :: + :: =/ err=error:body + :: (error:grab (need (de-json:html q:(need r.rep)))) + :: ?: =('urn:ietf:params:acme:error:malformed' status.err) + :: + =< cancel-order:effect + =/ msg=cord + 'unable to finalize domain validation challenge' + (emit (notify msg [(sell !>(rep)) ~])) + =/ bod=challenge:body + (challenge:grab (need (de-json:html q:(need r.rep)))) + :: XX check for other possible values in 200 response + :: note: may have already been validated + :: + ?> ?=(?(%pending %valid) sas.bod) + =/ rod-aut=order-auth + aut.u.rod(active ~, done [+.aut(sas.cal %pend) done.aut.u.rod]) + ?~ pending.aut.u.rod + check-order:effect(aut.u.rod rod-aut) + get-authz:effect(aut.u.rod rod-aut) + :: XX delete-trial? + :: + :: +retry: retry effect after timeout + :: + ++ retry + |= =wire + ^+ this + ?> ?=([%try @ @tas *] wire) + =/ try (slav %ud i.t.wire) + =* fec ~(. effect (some +(try))) + =* act i.t.t.wire + =* spur t.t.t.wire + ?+ act + ~&([%unknown-retry act] this) + %validate-domain + ?> ?=([%idx @ ~] spur) + (validate-domain:fec (slav %ud i.t.spur)) + %directory directory:fec + %nonce ?> ?=(^ spur) + (nonce:fec t.spur) + %register register:fec + %renew renew:fec + %new-order new-order:fec + %finalize-order finalize-order:fec + %check-order check-order:fec + %certificate check-order:fec :: intentional + %get-authz get-authz:fec + %test-trial test-trial:fec + %finalize-trial finalize-trial:fec + == + -- +++ http-response + |= [=wire response=client-response:iris] + ^- (quip move _this) + :: ignore progress reports + :: + ?: ?=(%progress -.response) + [~ this] + :: + ?> ?=([%acme ^] wire) + =< abet + :: + ?: ?=(%cancel -.response) + (retry:event t.wire) + :: + =/ rep=httr (to-httr:iris +.response) + :: add nonce to pool, if present + :: + =/ nonhed (skim q.rep |=((pair @t @t) ?=(%replay-nonce p))) + =? nonces ?=(^ nonhed) [q.i.nonhed nonces] + :: + ?> ?=([%try @ @tas *] t.wire) + =/ try (slav %ud i.t.t.wire) + =* ven ~(. event try) + =* act i.t.t.t.wire + =* spur t.t.t.t.wire + :: backoff if rate-limited + :: + ?: =(429 p.rep) + (rate-limited try act spur r.rep) + :: request nonce if expired-invalid + :: + ?: (bad-nonce rep) + (nonce:effect [act spur]) + :: XX replace with :hall notification + :: + ~| [%http-response-fail wire] + %. [spur rep] + ?+ act + ~&([%unknown-http-response act] !!) + %validate-domain + validate-domain:ven + %directory directory:ven + %nonce nonce:ven + %register register:ven + :: XX rekey + :: + %new-order new-order:ven + %finalize-order finalize-order:ven + %check-order check-order:ven + %certificate certificate:ven + %get-authz get-authz:ven + :: XX check/finalize-authz ?? + :: + %test-trial test-trial:ven + %finalize-trial finalize-trial:ven + :: XX delete-trial? + :: + == +:: +peek: read from app state +:: +++ peek + |= =path + ^- (unit (unit [%noun (unit @t)])) + ?+ path + ~ + :: + [%x %domain-validation @t ~] + =* token i.t.t.path + :^ ~ ~ %noun + ?. (~(has in challenges) token) + ~ + (some (rap 3 [token '.' (pass:thumb:jwk key.act) ~])) + == +:: +wake: timer wakeup event +:: +++ wake + |= [wir=wire error=(unit tang)] + ^- (quip move _this) + ?^ error + %- (slog u.error) + abet + ?> ?=([%acme *] wir) + abet:(retry:event t.wir) +:: +poke-acme-order: create new order for a set of domains +:: +++ poke-acme-order + |= a=(set turf) + abet:(add-order a) +:: +poke-noun: for debugging +:: +++ poke-noun + |= a=* + ^- (quip move _this) + =< abet + ?+ a + this + :: + %dbug-account + ~& registered=reg.act + ~& [%public (pass:en:pem:pkcs1 key.act)] + ~? !=(~ sek.key.act) + [%private (ring:en:pem:pkcs1 key.act)] + this + :: + %dbug-certificate + ?~ liv ~&(~ this) + ~& [%key (ring:en:pem:pkcs8 key.u.liv)] + ~& [%cert `wain`cer.u.liv] + ~& [%expires exp.u.liv] + ~& :- %domains + (join-turf ~(tap in dom.u.liv)) + this + :: + %dbug-history + ~& [%account-history act.hit] + ~& [%config-history fig.hit] + ~& [%failed-order-history fal.hit] + this + :: + :: install privkey and cert .pem from /=home=/acme, ignores app state + ::TODO refactor this out of %acme, see also arvo#1151 + :: + %install-from-clay + =/ bas=path /(scot %p our.bow)/home/(scot %da now.bow)/acme + =/ key=wain .^(wain %cx (weld bas /privkey/pem)) + =/ cer=wain .^(wain %cx (weld bas /cert/pem)) + (emit %rule /install %cert `[key cer]) + :: + %init + init + :: + %register + register:effect + :: + %poll + check-order:effect + :: + %retry + (add-order (sy /network/arvo/(crip +:(scow %p our.bow)) ~)) + == +:: +poke-path: for debugging +:: +++ poke-path + |=(a=path abet:(add-order (sy a ~))) +:: +prep: initialize and adapt state +:: +++ prep + |= old=(unit acme) + ^- (quip move _this) + ?~ old + =/ =binding:eyre + [~ /'.well-known'/acme-challenge] + =/ =generator:eyre + [q.byk.bow /gen/acme/domain-validation/hoon ~] + =/ =move + [ost.bow %serve /acme binding generator] + [[move ~] this] + [~ this(+<+ u.old)] +:: +bound: response to %serve binding request +:: +++ bound + |= [=wire accepted=? =binding:eyre] + ?: accepted + [~ this] + :: XX better error message + :: + ~& [%acme-http-path-binding-failed +<] + [~ this] +:: +rekey: create new 2.048 bit RSA key +:: +:: XX do something about this iteration +:: +++ rekey + |= eny=@ + =| i=@ + |- ^- key:rsa + =/ k (new-key:rsa 2.048 eny) + =/ m (met 0 n.pub.k) + :: ?: =(0 (mod m 8)) k + ?: =(2.048 m) k + ~& [%key iter=i width=m] + $(i +(i), eny +(eny)) +:: +init: initialize :acme state +:: +:: We defer the initial request for independence from the causal event, +:: which is necessary to init on the boot event. Which we no longer do, +:: but we're preserving the pattern for future flexibility. +:: +++ init + =< (retry:effect 0 %directory / `@dr`1) + %= this + act [(rekey eny.bow) ~] + cey (rekey (mix eny.bow (shaz now.bow))) + == +:: +queue-next-order: enqueue domains for validation +:: +++ queue-next-order + |= [try=@ud valid=? dom=(set turf)] + ^+ this + %= this next-order + :+ ~ + try + %+ roll + ~(tap in dom) + |= [=turf state=(map turf [idx=@ud valid=?])] + (~(put by state) turf [~(wyt by state) valid]) + == +:: +cancel-current-order: and archive failure for future autopsy +:: +:: XX we may have pending moves out for this order +:: put dates in wires, check against order creation date? +:: or re-use order-id? +:: +++ cancel-current-order + ^+ this + ?~ rod this + %= this + rod ~ + fal.hit [u.rod fal.hit] + == +:: +add-order: add new certificate order +:: +++ add-order + |= dom=(set turf) + ^+ this + ?: =(~ dom) + ~|(%acme-empty-certificate-order !!) + ?: ?=(?(%earl %pawn) (clan:title our.bow)) + this + =. ..this (queue-next-order 1 | dom) + =. ..this cancel-current-order + :: notify :hall + :: + =. ..this + =/ msg=cord + %+ rap 3 + :~ 'requesting an https certificate for ' + (join-turf ~(tap in dom)) + == + (emit (notify msg ~)) + :: if registered, create order + :: + ?^ reg.act + (validate-domain:effect 0) + :: if initialized, defer + :: + ?.(=(act *acct) this init) +-- diff --git a/pkg/arvo/app/aqua-ames.hoon b/pkg/arvo/app/aqua-ames.hoon new file mode 100644 index 000000000..96e77f809 --- /dev/null +++ b/pkg/arvo/app/aqua-ames.hoon @@ -0,0 +1,83 @@ +:: This needs a better SDN solution. Every ship should have an IP +:: address, and we should eventually test changing those IP +:: addresses. +:: +:: For now, we broadcast every packet to every ship and rely on them +:: to drop them. +:: +/- aquarium +=, aquarium +=> |% + +$ move (pair bone card) + +$ card + $% [%poke wire dock %aqua-events (list aqua-event)] + [%peer wire dock path] + [%pull wire dock ~] + == + :: + +$ state + $: %0 + subscribed=_| + == + -- +=, gall +=| moves=(list move) +=| aqua-event-list=(list aqua-event) +=| ships=(list ship) +|_ $: bowl + state + == +++ this . +++ apex %_(this moves ~, aqua-event-list ~, ships ~) +++ abet + =? this !=(~ aqua-event-list) + %- emit-moves + [ost %poke /aqua-events [our %aqua] %aqua-events aqua-event-list]~ + :: ~? !?=(~ moves) [%aqua-ames-moves (lent moves)] + [moves this] +:: +++ emit-moves + |= ms=(list move) + %_(this moves (weld moves ms)) +:: +++ emit-aqua-events + |= aes=(list aqua-event) + %_(this aqua-event-list (weld aqua-event-list aes)) +:: +++ poke-aqua-vane-control + |= command=?(%subscribe %unsubscribe) + :_ this(subscribed =(command %subscribe)) + (aqua-vane-control-handler our ost subscribed command) +:: +:: Handle effects from ships. We only react to %send effects. +:: +++ diff-aqua-effects + |= [way=wire afs=aqua-effects] + ^- (quip move _this) + =. this apex =< abet + |- ^+ this + ?~ ufs.afs + this + =. this + ?+ -.q.i.ufs.afs this + %restore (handle-restore who.afs) + %send (handle-send i.ufs.afs) + == + $(ufs.afs t.ufs.afs) +:: +++ handle-restore + |= who=@p + %- emit-aqua-events + [%event who [//newt/0v1n.2m9vh %barn ~]]~ +:: +++ handle-send + |= [way=wire %send lan=lane:ames pac=@] + ^+ this + =/ hear [//newt/0v1n.2m9vh %hear lan pac] + =? ships =(~ ships) + .^((list ship) %gx /(scot %p our)/aqua/(scot %da now)/ships/noun) + %- emit-aqua-events + %+ turn ships + |= who=ship + [%event who hear] +-- diff --git a/pkg/arvo/app/aqua-behn.hoon b/pkg/arvo/app/aqua-behn.hoon new file mode 100644 index 000000000..c0f67d2df --- /dev/null +++ b/pkg/arvo/app/aqua-behn.hoon @@ -0,0 +1,131 @@ +/- aquarium +=, aquarium +=> |% + +$ move (pair bone card) + +$ card + $% [%poke wire dock %aqua-events (list aqua-event)] + [%peer wire dock path] + [%pull wire dock ~] + [%wait wire p=@da] + [%rest wire p=@da] + == + :: + +$ state + $: %0 + subscribed=_| + piers=(map ship pier) + == + :: + +$ pier next-timer=(unit @da) + -- +=, gall +=| moves=(list move) +|_ $: bowl + state + == +++ this . +++ apex %_(this moves ~) +++ abet [(flop moves) this] +++ emit-moves + |= ms=(list move) + %_(this moves (weld ms moves)) +:: +++ emit-aqua-events + |= aes=(list aqua-event) + %- emit-moves + [ost %poke /aqua-events [our %aqua] %aqua-events aes]~ +:: +++ poke-aqua-vane-control + |= command=?(%subscribe %unsubscribe) + :_ this(subscribed =(command %subscribe)) + (aqua-vane-control-handler our ost subscribed command) +:: +++ diff-aqua-effects + |= [way=wire afs=aqua-effects] + ^- (quip move _this) + =. this apex =< abet + |- ^+ this + ?~ ufs.afs + this + =. this + ?+ -.q.i.ufs.afs this + %sleep abet-pe:handle-sleep:(pe who.afs) + %restore abet-pe:handle-restore:(pe who.afs) + %doze abet-pe:(handle-doze:(pe who.afs) i.ufs.afs) + == + $(ufs.afs t.ufs.afs) +:: +:: Received timer wake +:: +++ wake + |= [way=wire error=(unit tang)] + ^- (quip move _this) + =. this apex =< abet + ?> ?=([@ *] way) + =/ who (,@p (slav %p i.way)) + abet-pe:(take-wake:(pe who) t.way error) +:: +++ pe + |= who=ship + =+ (~(gut by piers) who *pier) + =* pier-data - + |% + ++ abet-pe + ^+ this + =. piers (~(put by piers) who pier-data) + this + :: + ++ handle-sleep + ^+ ..abet-pe + =< ..abet-pe(pier-data *pier) + ?~ next-timer + ..abet-pe + cancel-timer + :: + ++ handle-restore + ^+ ..abet-pe + =. this + %- emit-aqua-events + [%event who [//behn/0v1n.2m9vh %born ~]]~ + ..abet-pe + :: + ++ handle-doze + |= [way=wire %doze tim=(unit @da)] + ^+ ..abet-pe + ?~ tim + ?~ next-timer + ..abet-pe + cancel-timer + ?~ next-timer + (set-timer u.tim) + (set-timer:cancel-timer u.tim) + :: + ++ set-timer + |= tim=@da + ~? debug=| [who=who %setting-timer tim] + =. next-timer `tim + =. this (emit-moves [ost %wait /(scot %p who) tim]~) + ..abet-pe + :: + ++ cancel-timer + ~? debug=| [who=who %cancell-timer (need next-timer)] + =. this (emit-moves [ost %rest /(scot %p who) (need next-timer)]~) + =. next-timer ~ + ..abet-pe + :: + ++ take-wake + |= [way=wire error=(unit tang)] + ~? debug=| [who=who %aqua-behn-wake now error=error] + =. next-timer ~ + =. this + %- emit-aqua-events + :_ ~ + ^- aqua-event + :+ %event who + :- //behn/0v1n.2m9vh + ?~ error + [%wake ~] + [%crud %fail u.error] + ..abet-pe + -- +-- diff --git a/pkg/arvo/app/aqua-dill.hoon b/pkg/arvo/app/aqua-dill.hoon new file mode 100644 index 000000000..442104e51 --- /dev/null +++ b/pkg/arvo/app/aqua-dill.hoon @@ -0,0 +1,78 @@ +:: Would love to see a proper stateful terminal handler. Ideally, +:: you'd be able to ^X into the virtual ship, like the old ^W. +:: +:: However, that's probably not the primary way of interacting with +:: it. In practice, most of the time you'll be running from a file +:: (eg for automated testing) or fanning the same command to multiple +:: ships or otherwise making use of the fact that we can +:: programmatically send events. +:: +/- aquarium +=, aquarium +=> |% + +$ move (pair bone card) + +$ card + $% [%poke wire dock %aqua-events (list aqua-event)] + [%peer wire dock path] + [%pull wire dock ~] + == + :: + +$ state + $: %0 + subscribed=_| + == + -- +=, gall +=| moves=(list move) +|_ $: bowl + state + == +++ this . +++ apex %_(this moves ~) +++ abet [(flop moves) this] +++ emit-moves + |= ms=(list move) + %_(this moves (weld ms moves)) +:: +++ emit-aqua-events + |= aes=(list aqua-event) + %- emit-moves + [ost %poke /aqua-events [our %aqua] %aqua-events aes]~ +:: +++ poke-aqua-vane-control + |= command=?(%subscribe %unsubscribe) + :_ this(subscribed =(command %subscribe)) + (aqua-vane-control-handler our ost subscribed command) +:: +++ diff-aqua-effects + |= [way=wire afs=aqua-effects] + ^- (quip move _this) + =. this apex =< abet + |- ^+ this + ?~ ufs.afs + this + =. this + ?+ -.q.i.ufs.afs this + %blit (handle-blit who.afs i.ufs.afs) + == + $(ufs.afs t.ufs.afs) +:: +++ handle-blit + |= [who=@p way=wire %blit blits=(list blit:dill)] + ^+ this + =/ last-line + %+ roll blits + |= [b=blit:dill line=tape] + ?- -.b + %lin (tape p.b) + %mor ~& "{}: {line}" "" + %hop line + %bel line + %clr "" + %sag ~& [%save-jamfile-to p.b] line + %sav ~& [%save-file-to p.b] line + %url ~& [%activate-url p.b] line + == + ~? !=(~ last-line) last-line + this +-- diff --git a/pkg/arvo/app/aqua-eyre.hoon b/pkg/arvo/app/aqua-eyre.hoon new file mode 100644 index 000000000..435a33fbd --- /dev/null +++ b/pkg/arvo/app/aqua-eyre.hoon @@ -0,0 +1,157 @@ +:: Pass-through Eyre driver +:: +/- aquarium +=, aquarium +=> |% + +$ move (pair bone card) + +$ card + $% [%poke wire dock %aqua-events (list aqua-event)] + [%peer wire dock path] + [%pull wire dock ~] + [%hiss wire p=(unit user:eyre) q=mark r=(cask hiss:eyre)] + == + :: + +$ state + $: %0 + subscribed=_| + piers=(map ship pier) + == + :: + +$ pier http-requests=(set @ud) + -- +=, gall +=| moves=(list move) +|_ $: bowl + state + == +++ this . +++ apex %_(this moves ~) +++ abet [(flop moves) this] +++ emit-moves + |= ms=(list move) + %_(this moves (weld ms moves)) +:: +++ emit-aqua-events + |= aes=(list aqua-event) + %- emit-moves + [ost %poke /aqua-events [our %aqua] %aqua-events aes]~ +:: +++ poke-aqua-vane-control + |= command=?(%subscribe %unsubscribe) + :_ this(subscribed =(command %subscribe)) + (aqua-vane-control-handler our ost subscribed command) +:: +++ diff-aqua-effects + |= [way=wire afs=aqua-effects] + ^- (quip move _this) + =. this apex =< abet + |- ^+ this + ?~ ufs.afs + this + =. this + ?+ -.q.i.ufs.afs this + %sleep abet-pe:handle-sleep:(pe who.afs) + %restore abet-pe:handle-restore:(pe who.afs) + %thus abet-pe:(handle-thus:(pe who.afs) i.ufs.afs) + == + $(ufs.afs t.ufs.afs) +:: +:: Received inbound HTTP response +:: +++ sigh-httr + |= [way=wire res=httr:eyre] + ^- (quip move _this) + =. this apex =< abet + ?> ?=([@ *] way) + =/ who (,@p (slav %p i.way)) + ~& [%received-httr who] + abet-pe:(take-sigh-httr:(pe who) t.way res) +:: +:: Received inbound HTTP response error +:: +++ sigh-tang + |= [way=wire tan=tang] + ^- (quip move _this) + =. this apex =< abet + ?> ?=([@ *] way) + =/ who (,@p (slav %p i.way)) + ~& [%received-httr who] + abet-pe:(take-sigh-tang:(pe who) t.way tan) +:: +++ pe + |= who=ship + =+ (~(gut by piers) who *pier) + =* pier-data - + |% + ++ abet-pe + ^+ this + =. piers (~(put by piers) who pier-data) + this + :: + ++ handle-sleep + ^+ ..abet-pe + ..abet-pe(pier-data *pier) + :: + ++ handle-restore + ^+ ..abet-pe + =. this + %- emit-aqua-events + [%event who [//http/0v1n.2m9vh %born ~]]~ + ..abet-pe + :: + ++ handle-thus + |= [way=wire %thus num=@ud req=(unit hiss:eyre)] + ^+ ..abet-pe + ?~ req + ?. (~(has in http-requests) num) + ..abet-pe + :: Eyre doesn't support cancelling HTTP requests from userspace, + :: so we remove it from our state so we won't pass along the + :: response. + :: + ~& [who=who %aqua-eyre-cant-cancel-thus num=num] + =. http-requests (~(del in http-requests) num) + ..abet-pe + ~& [who=who %aqua-eyre-requesting u.req] + =. http-requests (~(put in http-requests) num) + =. this + %- emit-moves :_ ~ + :* ost + %hiss + /(scot %p who)/(scot %ud num) + ~ + %httr + [%hiss u.req] + == + ..abet-pe + :: + :: Pass HTTP response back to virtual ship + :: + ++ take-sigh-httr + |= [way=wire res=httr:eyre] + ^+ ..abet-pe + ?> ?=([@ ~] way) + =/ num (slav %ud i.way) + ?. (~(has in http-requests) num) + ~& [who=who %ignoring-httr num=num] + ..abet-pe + =. http-requests (~(del in http-requests) num) + =. this + (emit-aqua-events [%event who [//http/0v1n.2m9vh %receive num [%start [p.res q.res] r.res &]]]~) + ..abet-pe + :: + :: Got error in HTTP response + :: + ++ take-sigh-tang + |= [way=wire tan=tang] + ^+ ..abet-pe + ?> ?=([@ ~] way) + =/ num (slav %ud i.way) + ?. (~(has in http-requests) num) + ~& [who=who %ignoring-httr num=num] + ..abet-pe + =. http-requests (~(del in http-requests) num) + %- (slog tan) + ..abet-pe + -- +-- diff --git a/pkg/arvo/app/aqua.hoon b/pkg/arvo/app/aqua.hoon new file mode 100644 index 000000000..865525ef6 --- /dev/null +++ b/pkg/arvo/app/aqua.hoon @@ -0,0 +1,564 @@ +:: An aquarium of virtual ships. Put in some fish and watch them! +:: +:: usage: +:: |start %aqua +:: /- aquarium +:: :aqua &pill .^(pill:aquarium %cx %/urbit/pill) +:: OR +:: :aqua &pill +solid +:: +:: Then try stuff: +:: :aqua [%init ~[~bud ~dev]] +:: :aqua [%dojo ~[~bud ~dev] "[our eny (add 3 5)]"] +:: :aqua [%dojo ~[~bud] "|hi ~dev"] +:: :aqua [%wish ~[~bud ~dev] '(add 2 3)'] +:: :aqua [%peek ~[~bud] /cx/~bud/home/(scot %da now)/app/curl/hoon] +:: :aqua [%dojo ~[~bud ~dev] '|mount %'] +:: :aqua [%file ~[~bud ~dev] %/sys/vane] +:: :aqua [%pause-events ~[~bud ~dev]] +:: +:: +:: We get ++unix-event and ++pill from /-aquarium +:: +/- aquarium +/+ pill +=, pill-lib=pill +=, aquarium +=> $~ |% + +$ move (pair bone card) + +$ card + $% [%diff diff-type] + == + :: + :: Outgoing subscription updates + :: + +$ diff-type + $% [%aqua-effects aqua-effects] + [%aqua-events aqua-events] + [%aqua-boths aqua-boths] + == + :: + +$ state + $: %0 + pil=pill + assembled=* + tym=@da + fleet-snaps=(map term (map ship pier)) + piers=(map ship pier) + == + :: + +$ pier + $: snap=* + event-log=(list unix-timed-event) + next-events=(qeu unix-event) + processing-events=? + == + -- +=, gall +:: +:: unix-{effects,events,boths}: collect jar of effects and events to +:: brodcast all at once to avoid gall backpressure +:: moves: Hoist moves into state for cleaner state management +:: +=| unix-effects=(jar ship unix-effect) +=| unix-events=(jar ship unix-timed-event) +=| unix-boths=(jar ship unix-both) +=| moves=(list move) +|_ $: hid=bowl + state + == +:: +:: Represents a single ship's state. +:: +++ pe + |= who=ship + =+ (~(gut by piers) who *pier) + =* pier-data - + |% + :: + :: Done; install data + :: + ++ abet-pe + ^+ this + =. piers (~(put by piers) who pier-data) + this + :: + :: Initialize new ship + :: + ++ apex + =. pier-data *pier + =. snap assembled + ~& pill-size=(met 3 (jam snap)) + ..abet-pe + :: + :: Enqueue events to child arvo + :: + ++ push-events + |= ues=(list unix-event) + ^+ ..abet-pe + =. next-events (~(gas to next-events) ues) + ..abet-pe + :: + :: Send moves to host arvo + :: + ++ emit-moves + |= ms=(list move) + =. this (^emit-moves ms) + ..abet-pe + :: + :: Process the events in our queue. + :: + ++ plow + |- ^+ ..abet-pe + ?: =(~ next-events) + ..abet-pe + ?. processing-events + ..abet-pe + =^ ue next-events ~(get to next-events) + =/ poke-arm (mox +47.snap) + ?> ?=(%0 -.poke-arm) + =/ poke p.poke-arm + =. tym (max +(tym) now.hid) + =/ poke-result (mule |.((slum poke tym ue))) + ?: ?=(%| -.poke-result) + %- (slog >%aqua-crash< >guest=who< p.poke-result) + $ + =. snap +.p.poke-result + =. ..abet-pe (publish-event tym ue) + =. ..abet-pe (handle-effects ((list ovum) -.p.poke-result)) + $ + :: + :: Peek + :: + ++ peek + |= p=* + =/ res (mox +46.snap) + ?> ?=(%0 -.res) + =/ peek p.res + =/ pax (path p) + ?> ?=([@ @ @ @ *] pax) + =. i.t.t.t.pax (scot %da tym) + =/ pek (slum peek [tym pax]) + pek + :: + :: Wish + :: + ++ wish + |= txt=@t + =/ res (mox +22.snap) + ?> ?=(%0 -.res) + =/ wish p.res + ~& [who=who %wished (slum wish txt)] + ..abet-pe + :: + ++ mox |=(* (mock [snap +<] scry)) + :: + :: Start/stop processing events. When stopped, events are added to + :: our queue but not processed. + :: + ++ start-processing-events .(processing-events &) + ++ stop-processing-events .(processing-events |) + :: + :: Handle all the effects produced by a single event. + :: + ++ handle-effects + |= effects=(list ovum) + ^+ ..abet-pe + ?~ effects + ..abet-pe + =. ..abet-pe + =/ sof ((soft unix-effect) i.effects) + ?~ sof + ~? aqua-debug=| [who=who %unknown-effect i.effects] + ..abet-pe + (publish-effect u.sof) + $(effects t.effects) + :: + :: Give effect to our subscribers + :: + ++ publish-effect + |= uf=unix-effect + ^+ ..abet-pe + =. unix-effects (~(add ja unix-effects) who uf) + =. unix-boths (~(add ja unix-boths) who [%effect uf]) + ..abet-pe + :: + :: Give event to our subscribers + :: + ++ publish-event + |= ute=unix-timed-event + ^+ ..abet-pe + =. event-log [ute event-log] + =. unix-events (~(add ja unix-events) who ute) + =. unix-boths (~(add ja unix-boths) who [%event ute]) + ..abet-pe + -- +:: +++ this . +:: +:: ++apex-aqua and ++abet-aqua must bookend calls from gall +:: +++ apex-aqua + ^+ this + =: moves ~ + unix-effects ~ + unix-events ~ + unix-boths ~ + == + this +:: +++ abet-aqua + ^- (quip move _this) + =. this + %- emit-moves + %- zing ^- (list (list move)) + %+ turn ~(tap by sup.hid) + |= [b=bone her=ship pax=path] + ^- (list move) + ?+ pax ~ + [%effects @ ~] + =/ who (slav %p i.t.pax) + =/ ufs (~(get ja unix-effects) who) + ?~ ufs + ~ + [b %diff %aqua-effects who (flop ufs)]~ + :: + [%effects ~] + %+ turn + ~(tap by unix-effects) + |= [who=ship ufs=(list unix-effect)] + [b %diff %aqua-effects who (flop ufs)] + :: + [%events @ ~] + =/ who (slav %p i.t.pax) + =/ ve (~(get ja unix-events) who) + ?~ ve + ~ + [b %diff %aqua-events who (flop ve)]~ + :: + [%boths @ ~] + =/ who (slav %p i.t.pax) + =/ bo (~(get ja unix-boths) who) + ?~ bo + ~ + [b %diff %aqua-boths who (flop bo)]~ + == + [(flop moves) this] +:: +++ emit-moves + |= ms=(list move) + =. moves (weld ms moves) + this +:: +:: +:: Run all events on all ships until all queues are empty +:: +++ plow-all + |- ^+ this + =/ who + =/ pers ~(tap by piers) + |- ^- (unit ship) + ?~ pers + ~ + ?: &(?=(^ next-events.q.i.pers) processing-events.q.i.pers) + `p.i.pers + $(pers t.pers) + ~? aqua-debug=| plowing=who + ?~ who + this + =. this abet-pe:plow:(pe u.who) + $ +:: +:: Subscribe to effects from a ship +:: +++ peer-effects + |= pax=path + ^- (quip move _this) + ?. ?=([@ *] pax) + ~& [%aqua-bad-peer-effects pax] + `this + ?~ (slaw %p i.pax) + ~& [%aqua-bad-peer-effects-ship pax] + !! + `this +:: +:: Subscribe to events to a ship +:: +++ peer-events + |= pax=path + ^- (quip move _this) + ?. ?=([@ ~] pax) + ~& [%aqua-bad-peer-events pax] + `this + ?~ (slaw %p i.pax) + ~& [%aqua-bad-peer-events-ship pax] + !! + `this +:: +:: Subscribe to both events and effects of a ship +:: +++ peer-boths + |= pax=path + ^- (quip move _this) + ?. ?=([@ ~] pax) + ~& [%aqua-bad-peer-boths pax] + `this + ?~ (slaw %p i.pax) + ~& [%aqua-bad-peer-boths-ship pax] + !! + `this +:: +:: Load a pill and assemble arvo. Doesn't send any of the initial +:: events. +:: +++ poke-pill + |= p=pill + ^- (quip move _this) + =. this apex-aqua =< abet-aqua + =. pil p + ~& lent=(met 3 (jam boot-ova.pil)) + =/ res=toon :: (each * (list tank)) + (mock [boot-ova.pil [2 [0 3] [0 2]]] scry) + =. fleet-snaps ~ + ?- -.res + %0 + ~& %suc + =. assembled +7.p.res + this + :: + %1 + ~& [%vere-blocked p.res] + this + :: + %2 + ~& %vere-fail + %- (slog p.res) + this + == +:: +:: Handle commands from CLI +:: +:: Should put some thought into arg structure, maybe make a mark. +:: +:: Should convert some of these to just rewrite into ++poke-events. +:: +++ poke-noun + |= val=* + ^- (quip move _this) + =. this apex-aqua =< abet-aqua + ^+ this + :: Could potentially factor out the three lines of turn-ships + :: boilerplate + :: + ?+ val ~|(%bad-noun-arg !!) + [%swap-vanes vs=*] + ?> ?=([[%7 * %1 installed=*] ~] boot-ova.pil) + =. installed.boot-ova.pil + %+ roll (,(list term) vs.val) + |= [v=term _installed.boot-ova.pil] + %^ slum installed.boot-ova.pil now.hid + =/ vane + ?+ v ~|([%unknown-vane v] !!) + %a %ames + %b %behn + %c %clay + %d %dill + %e %eyre + %f %ford + %g %gall + %j %ford + == + =/ pax + /(scot %p our.hid)/home/(scot %da now.hid)/sys/vane/[vane] + =/ txt .^(@ %cx (weld pax /hoon)) + [/vane/[vane] [%veer v pax txt]] + => .(this ^+(this this)) + =^ ms this (poke-pill pil) + (emit-moves ms) + :: + [%swap-files ~] + =. userspace-ova.pil + =/ slim-dirs + `(list path)`~[/app /gen /lib /mar /sur /hoon/sys /arvo/sys /zuse/sys] + :_ ~ + %- unix-event + %- %*(. file-ovum:pill-lib directories slim-dirs) + /(scot %p our.hid)/home/(scot %da now.hid) + =^ ms this (poke-pill pil) + (emit-moves ms) + :: + [%wish hers=* p=@t] + %+ turn-ships ((list ship) hers.val) + |= [who=ship thus=_this] + =. this thus + (wish:(pe who) p.val) + :: + [%unpause-events hers=*] + %+ turn-ships ((list ship) hers.val) + |= [who=ship thus=_this] + =. this thus + start-processing-events:(pe who) + :: + [%pause-events hers=*] + %+ turn-ships ((list ship) hers.val) + |= [who=ship thus=_this] + =. this thus + stop-processing-events:(pe who) + :: + [%clear-snap lab=@tas] + =. fleet-snaps ~ :: (~(del by fleet-snaps) lab.val) + this + == +:: +:: Apply a list of events tagged by ship +:: +++ poke-aqua-events + |= events=(list aqua-event) + ^- (quip move _this) + =. this apex-aqua =< abet-aqua + %+ turn-events events + |= [ae=aqua-event thus=_this] + =. this thus + ?- -.ae + %init-ship + =. this abet-pe:(publish-effect:(pe who.ae) [/ %sleep ~]) + =/ initted + =< plow + %- push-events:apex:(pe who.ae) + ^- (list unix-event) + :~ [/ %wack 0] :: eny + [/ %whom who.ae] :: eny + [//newt/0v1n.2m9vh %barn ~] + [//behn/0v1n.2m9vh %born ~] + :+ //term/1 %boot + ?~ keys.ae + [%fake who.ae] + [%dawn u.keys.ae] + -.userspace-ova.pil + [//http/0v1n.2m9vh %born ~] + [//http/0v1n.2m9vh %live 8.080 `8.445] + == + =. this abet-pe:initted + (pe who.ae) + :: + %pause-events + stop-processing-events:(pe who.ae) + :: + %snap-ships + =. fleet-snaps + %+ ~(put by fleet-snaps) lab.ae + %- malt + %+ murn hers.ae + |= her=ship + ^- (unit (pair ship pier)) + =+ per=(~(get by piers) her) + ?~ per + ~ + `[her u.per] + (pe -.hers.ae) + :: + %restore-snap + =. this + %+ turn-ships (turn ~(tap by piers) head) + |= [who=ship thus=_this] + =. this thus + (publish-effect:(pe who) [/ %sleep ~]) + =. piers (~(uni by piers) (~(got by fleet-snaps) lab.ae)) + =. this + %+ turn-ships (turn ~(tap by piers) head) + |= [who=ship thus=_this] + =. this thus + (publish-effect:(pe who) [/ %restore ~]) + (pe ~bud) :: XX why ~bud? need an example + :: + %event + ~? &(aqua-debug=| !?=(?(%belt %hear) -.q.ue.ae)) + raw-event=[who.ae -.q.ue.ae] + ~? &(debug=| ?=(%receive -.q.ue.ae)) + raw-event=[who.ae ue.ae] + (push-events:(pe who.ae) [ue.ae]~) + == +:: +:: Run a callback function against a list of ships, aggregating state +:: and plowing all ships at the end. +:: +:: I think we should use patterns like this more often. Because we +:: don't, here's some points to be aware. +:: +:: `fun` must take `this` as a parameter, since it needs to be +:: downstream of previous state changes. You could use `state` as +:: the state variable, but it muddles the code and it's not clear +:: whether it's better. You could use the `_(pe)` core if you're +:: sure you'll never need to refer to anything outside of your pier, +:: but I don't think we can guarantee that. +:: +:: The callback function must start with `=. this thus`, or else +:: you don't get the new state. Would be great if you could hot-swap +:: that context in here, but we don't know where to put it unless we +:: restrict the callbacks to always have `this` at a particular axis, +:: and that doesn't feel right +:: +++ turn-plow + |* arg=mold + |= [hers=(list arg) fun=$-([arg _this] _(pe))] + |- ^+ this + ?~ hers + plow-all + =. this + abet-pe:plow:(fun i.hers this) + $(hers t.hers, this this) +:: +++ turn-ships (turn-plow ship) +++ turn-events (turn-plow aqua-event) +:: +:: Check whether we have a snapshot +:: +++ peek-x-fleet-snap + |= pax=path + ^- (unit (unit [%noun noun])) + ?. ?=([@ ~] pax) + ~ + :^ ~ ~ %noun + (~(has by fleet-snaps) i.pax) +:: +:: Pass scry into child ship +:: +++ peek-x-i + |= pax=path + ^- (unit (unit [%noun noun])) + ?. ?=([@ @ @ @ @ *] pax) + ~ + =/ who (slav %p i.pax) + =/ pier (~(get by piers) who) + ?~ pier + ~ + :^ ~ ~ %noun + (peek:(pe who) t.pax) +:: +:: Get all created ships +:: +++ peek-x-ships + |= pax=path + ^- (unit (unit [%noun (list ship)])) + ?. ?=(~ pax) + ~ + :^ ~ ~ %noun + `(list ship)`(turn ~(tap by piers) head) +:: +:: Trivial scry for mock +:: +++ scry |=([* *] ~) +:: +:: Throw away old state if it doesn't soft to new state. +:: +++ prep + |= old/(unit noun) + ^- [(list move) _+>.$] + ~& prep=%aqua + ?~ old + `+>.$ + =+ new=((soft state) u.old) + ?~ new + `+>.$ + `+>.$(+<+ u.new) +-- diff --git a/pkg/arvo/app/azimuth-tracker.hoon b/pkg/arvo/app/azimuth-tracker.hoon new file mode 100644 index 000000000..5d5bbecec --- /dev/null +++ b/pkg/arvo/app/azimuth-tracker.hoon @@ -0,0 +1,332 @@ +/+ tapp, stdio +=, able:kale +=> |% + +$ pending-udiffs (map number:block udiffs:point) + +$ config + $: url=@ta + from-number=number:block + == + +$ app-state ~ + +$ peek-data ~ + +$ in-poke-data + $% [%watch =config] + [%clear ~] + [%noun *] + == + +$ out-poke-data ~ + +$ in-peer-data ~ + +$ out-peer-data ~ + ++ tapp + %: ^tapp + app-state + peek-data + in-poke-data + out-poke-data + in-peer-data + out-peer-data + == + ++ tapp-async tapp-async:tapp + ++ stdio (^stdio out-poke-data out-peer-data) + -- +:: +:: Async helpers +:: +=> |% + ++ topics + => azimuth-events:azimuth + :_ ~ + :~ broke-continuity + changed-keys + lost-sponsor + escape-accepted + == + :: + ++ request-rpc + |= [url=@ta id=(unit @t) req=request:rpc:ethereum] + =/ m (async:stdio ,json) + ^- form:m + %+ (retry json) `10 + =/ m (async:stdio ,(unit json)) + ^- form:m + |^ + =/ =request:http + :* method=%'POST' + url=url + header-list=['Content-Type'^'application/json' ~] + ^= body + %- some %- as-octt:mimes:html + %- en-json:html + (request-to-json:rpc:ethereum id req) + == + ;< ~ bind:m (send-request:stdio request) + ;< rep=(unit client-response:iris) bind:m + take-maybe-response:stdio + ?~ rep + (pure:m ~) + (parse-response u.rep) + :: + ++ parse-response + |= =client-response:iris + =/ m (async:stdio ,(unit json)) + ^- form:m + ?> ?=(%finished -.client-response) + =/ body=@t q.data:(need full-file.client-response) + =/ jon=(unit json) (de-json:html body) + ?~ jon + (pure:m ~) + =, dejs-soft:format + =/ array=(unit (list response:rpc:jstd)) + ((ar parse-one-response) u.jon) + ?~ array + =/ res=(unit response:rpc:jstd) (parse-one-response u.jon) + ?~ res + (async-fail:stdio %request-rpc-parse-error >id< ~) + ?: ?=(%error -.u.res) + (async-fail:stdio %request-rpc-error >id< >+.res< ~) + ?. ?=(%result -.u.res) + (async-fail:stdio %request-rpc-fail >u.res< ~) + (pure:m `res.u.res) + (async-fail:stdio %request-rpc-batch >%not-implemented< ~) + :: (pure:m `[%batch u.array]) + :: + ++ parse-one-response + |= =json + ^- (unit response:rpc:jstd) + =/ res=(unit [@t ^json]) + %. json + =, dejs-soft:format + (ot id+so result+some ~) + ?^ res `[%result u.res] + ~| parse-one-response=json + :+ ~ %error %- need + %. json + =, dejs-soft:format + (ot id+so error+(ot code+no message+so ~) ~) + -- + :: + ++ retry + |* result=mold + |= [crash-after=(unit @ud) computation=_*form:(async:stdio (unit result))] + =/ m (async:stdio ,result) + =| try=@ud + |^ + |- ^- form:m + =* loop $ + ?: =(crash-after `try) + (async-fail:stdio %retry-too-many ~) + ;< ~ bind:m (backoff try ~m1) + ;< res=(unit result) bind:m computation + ?^ res + (pure:m u.res) + loop(try +(try)) + :: + ++ backoff + |= [try=@ud limit=@dr] + =/ m (async:stdio ,~) + ^- form:m + ;< eny=@uvJ bind:m get-entropy:stdio + ;< now=@da bind:m get-time:stdio + %- wait:stdio + %+ add now + %+ min limit + ?: =(0 try) ~s0 + %+ add + (mul ~s1 (bex (dec try))) + (mul ~s0..0001 (~(rad og eny) 1.000)) + -- + :: + ++ get-latest-block + |= url=@ta + =/ m (async:stdio ,block) + ^- form:m + ;< =json bind:m (request-rpc url `'block number' %eth-block-number ~) + (get-block-by-number url (parse-eth-block-number:rpc:ethereum json)) + :: + ++ get-block-by-number + |= [url=@ta =number:block] + =/ m (async:stdio ,block) + ^- form:m + |^ + ;< =json bind:m + (request-rpc url `'block by number' %eth-get-block-by-number number |) + =/ =block (parse-block json) + ?. =(number number.id.block) + (async-fail:stdio %reorg-detected >number< >block< ~) + (pure:m block) + :: + ++ parse-block + |= =json + ^- block + =< [[&1 &2] |2] + ^- [@ @ @] + ~| json + %. json + =, dejs:format + %- ot + :~ hash+parse-hex-result:rpc:ethereum + number+parse-hex-result:rpc:ethereum + 'parentHash'^parse-hex-result:rpc:ethereum + == + -- + :: + ++ get-logs-by-hash + |= [url=@ta =hash:block] + =/ m (async:stdio udiffs:point) + ^- form:m + ;< =json bind:m + %+ request-rpc url + :* `'logs by hash' + %eth-get-logs-by-hash + hash + ~[azimuth:contracts:azimuth] + topics + == + =/ event-logs=(list event-log:rpc:ethereum) + (parse-event-logs:rpc:ethereum json) + =/ =udiffs:point + %+ murn event-logs + |= =event-log:rpc:ethereum + ^- (unit [=ship =udiff:point]) + ?~ mined.event-log + ~ + ?: removed.u.mined.event-log + ~& [%removed-log event-log] + ~ + =/ =id:block [block-hash block-number]:u.mined.event-log + =, azimuth-events:azimuth + =, abi:ethereum + ?: =(broke-continuity i.topics.event-log) + =/ who=@ (decode-topics t.topics.event-log ~[%uint]) + =/ num=@ (decode-results data.event-log ~[%uint]) + `[who id %rift num] + ?: =(changed-keys i.topics.event-log) + =/ who=@ (decode-topics t.topics.event-log ~[%uint]) + =+ ^- [enc=octs aut=octs sut=@ud rev=@ud] + %+ decode-results data.event-log + ~[[%bytes-n 32] [%bytes-n 32] %uint %uint] + `[who id %keys rev sut (pass-from-eth:azimuth enc aut sut)] + ?: =(lost-sponsor i.topics.event-log) + =+ ^- [who=@ pos=@] + (decode-topics t.topics.event-log ~[%uint %uint]) + `[who id %spon ~] + ?: =(escape-accepted i.topics.event-log) + =+ ^- [who=@ wer=@] + (decode-topics t.topics.event-log ~[%uint %uint]) + `[who id %spon `wer] + ~& [%bad-topic event-log] + ~ + (pure:m udiffs) + :: + ++ jael-update + |= =udiffs:point + =/ m (async:stdio ,~) + |- ^- form:m + =* loop $ + ?~ udiffs + (pure:m ~) + ~& > [%update block i.udiffs] + :: ;< ~ bind:m (send-effect [%vent-update i.udiffs]) + loop(udiffs t.udiffs) + -- +:: +:: Main loop +:: +=> |% + ++ watch + |= =config + =/ m (async:stdio ,~) + ^- form:m + =/ =number:block from-number.config + =| =pending-udiffs + =| blocks=(list block) + |- ^- form:m + =* poll-loop $ + ~& [%poll-loop number] + ;< =latest=block bind:m (get-latest-block url.config) + |- ^- form:m + =* walk-loop $ + ~& [%walk-loop number] + ?: (gth number number.id.latest-block) + ;< now=@da bind:m get-time:stdio + ;< ~ bind:m (wait:stdio (add now ~s10)) + poll-loop + ;< =block bind:m (get-block-by-number url.config number) + ;< [=new=^pending-udiffs new-blocks=(lest ^block)] bind:m + (take-block url.config pending-udiffs block blocks) + =: pending-udiffs new-pending-udiffs + blocks new-blocks + number +(number.id.i.new-blocks) + == + walk-loop + :: + ++ take-block + |= [url=@ta =a=pending-udiffs =block blocks=(list block)] + =/ m (async:stdio ,[pending-udiffs (lest ^block)]) + ^- form:m + ~& [%taking id.block] + ?: &(?=(^ blocks) !=(parent-hash.block hash.id.i.blocks)) + ~& %rewinding + (rewind url a-pending-udiffs block blocks) + ;< =b=pending-udiffs bind:m + (release-old-events a-pending-udiffs number.id.block) + ;< =new=udiffs:point bind:m (get-logs-by-hash url hash.id.block) + ~? !=(~ new-udiffs) [%adding-diffs new-udiffs] + =. b-pending-udiffs (~(put by b-pending-udiffs) number.id.block new-udiffs) + (pure:m b-pending-udiffs block blocks) + :: + ++ release-old-events + |= [=pending-udiffs =number:block] + =/ m (async:stdio ,^pending-udiffs) + ^- form:m + =/ rel-number (sub number 30) + =/ =udiffs:point (~(get ja pending-udiffs) rel-number) + ;< ~ bind:m (jael-update udiffs) + (pure:m (~(del by pending-udiffs) rel-number)) + :: + ++ rewind + |= [url=@ta =pending-udiffs =block blocks=(list block)] + =/ m (async:stdio ,[^pending-udiffs (lest ^block)]) + |- ^- form:m + =* loop $ + ~& [%wind block ?~(blocks ~ i.blocks)] + ?~ blocks + (pure:m pending-udiffs block blocks) + ?: =(parent-hash.block hash.id.i.blocks) + (pure:m pending-udiffs block blocks) + ;< =next=^block bind:m (get-block-by-number url number.id.i.blocks) + ?: =(~ pending-udiffs) + ;< ~ bind:m (disavow block) + loop(block next-block, blocks t.blocks) + =. pending-udiffs (~(del by pending-udiffs) number.id.block) + loop(block next-block, blocks t.blocks) + :: + ++ disavow + |= =block + =/ m (async:stdio ,~) + ^- form:m + (jael-update [*ship id.block %disavow ~]~) + -- +:: +:: Main +:: +=* default-tapp default-tapp:tapp +%- create-tapp-poke-peer-take:tapp +|_ [=bowl:gall state=app-state] +++ handle-poke + |= =in-poke-data + =/ m tapp-async + ^- form:m + ?- -.in-poke-data + %noun (watch (config +.in-poke-data)) + %watch (watch +.in-poke-data) + %clear !! + == +:: +++ handle-take + |= =sign:tapp + !! + :: ?> ?=(%sources -.sign) + :: (handle-poke %watch +.sign) +:: +++ handle-peer ~(handle-peer default-tapp bowl state) +-- diff --git a/pkg/arvo/app/chat.hoon b/pkg/arvo/app/chat.hoon new file mode 100644 index 000000000..e9d425073 --- /dev/null +++ b/pkg/arvo/app/chat.hoon @@ -0,0 +1,658 @@ +/- hall +/+ *server, chat, hall-json +/= index + /^ octs + /; as-octs:mimes:html + /: /===/app/chat/index + /| /html/ + /~ ~ + == +/= tile-js + /^ octs + /; as-octs:mimes:html + /: /===/app/chat/js/tile + /| /js/ + /~ ~ + == +/= script + /^ octs + /; as-octs:mimes:html + /: /===/app/chat/js/index + /| /js/ + /~ ~ + == +/= style + /^ octs + /; as-octs:mimes:html + /: /===/app/chat/css/index + /| /css/ + /~ ~ + == +/= style + /^ octs + /; as-octs:mimes:html + /: /===/app/chat/css/index + /| /css/ + /~ ~ + == +/= chat-png + /^ (map knot @) + /: /===/app/chat/img /_ /png/ +:: +=, chat +:: +|_ [bol=bowl:gall sta=state] +:: +++ this . +:: +:: +prep: set up the app, migrate the state once started +:: +++ prep + |= old=(unit state) + ^- (quip move _this) + =/ launcha/poke + [%launch-action [%chat /chattile '/~chat/js/tile.js']] + ?~ old + =/ inboxpat /circle/inbox/config/group + =/ circlespat /circles/[(scot %p our.bol)] + =/ inboxwir /circle/[(scot %p our.bol)]/inbox/config/group + =/ inboxi/poke + :- %hall-action + [%source %inbox %.y (silt [[our.bol %i] ~]~)] + =/ fakeannounce=poke + :- %hall-action + [%create %hall-internal-announcements '' %village] + =/ announce=poke + :- %hall-action + [%create %announcements 'Announcements from Tlon' %journal] + =/ help=poke + :- %hall-action + [%create %urbit-help 'Get help about Urbit' %channel] + =/ dev=poke + :- %hall-action + [%create %urbit-dev 'Chat about developing on Urbit' %channel] + =/ sourcefakeannounce/poke + :- %hall-action + [%source %inbox %.y (silt [[our.bol %hall-internal-announcements] ~]~)] + =/ sourceannounce/poke + :- %hall-action + [%source %inbox %.y (silt [[~marzod %announcements] ~]~)] + =/ hallactions=(list move) + ?: =((clan:title our.bol) %czar) + ~ + ?: =(our.bol ~marzod) + ~& %marzod-chat + :- [ost.bol %poke /announce [our.bol %hall] announce] + [ost.bol %poke /announce [our.bol %hall] sourceannounce]~ + ?: =(our.bol ~dopzod) + ~& %dopzod-chat + :- [ost.bol %poke /announce [our.bol %hall] dev] + [ost.bol %poke /announce [our.bol %hall] help]~ + :- [ost.bol %poke /announce [our.bol %hall] fakeannounce] + :- [ost.bol %poke /announce [our.bol %hall] sourcefakeannounce] + [ost.bol %poke /announce [our.bol %hall] sourceannounce]~ + =/ moves=(list move) + :~ [ost.bol %peer inboxwir [our.bol %hall] inboxpat] + [ost.bol %peer circlespat [our.bol %hall] circlespat] + [ost.bol %connect / [~ /'~chat'] %chat] + [ost.bol %poke /chat [our.bol %hall] inboxi] + [ost.bol %poke /chat [our.bol %launch] launcha] + == + :_ this + %+ weld moves hallactions + :- [ost.bol %poke /chat [our.bol %launch] launcha]~ + this(sta u.old) +:: +++ construct-tile-json + |= str=streams + ^- json + =/ numbers/(list [circle:hall @ud]) + %+ turn ~(tap by messages.str) + |= [cir=circle:hall lis=(list envelope:hall)] + ^- [circle:hall @ud] + ?~ lis + [cir 0] + =/ last (snag (dec (lent lis)) `(list envelope:hall)`lis) + [cir (add num.last 1)] + =/ maptjson=(map @t json) + %- my + :~ ['config' (config-to-json str)] + ['numbers' (numbers-to-json numbers)] + == + [%o maptjson] +:: +++ peer-chattile + |= wir=wire + ^- (quip move _this) + :_ this + [ost.bol %diff %json (construct-tile-json str.sta)]~ +:: +:: +peer-messages: subscribe to subset of messages and updates +:: +:: +++ peer-primary + |= wir=wire + ^- (quip move _this) + =* messages messages.str.sta + =/ lismov/(list move) + %+ murn ~(tap by messages) + |= [cir=circle:hall lis=(list envelope:hall)] + ^- (unit move) + =/ envs/(unit (list envelope:hall)) (~(get by messages) cir) + ?~ envs + ~ + =/ length/@ (lent u.envs) + =/ start/@ + ?: (gte length 100) + (sub length 100) + 0 + =/ end/@ length + =/ offset/@ (sub end start) + :- ~ + :* ost.bol + %diff + %chat-update + [%messages cir start end (swag [start offset] u.envs)] + == + :_ this + [[ost.bol %diff %chat-config str.sta] lismov] +:: +:: +poke-chat: send us an action +:: +++ poke-chat-action + |= act=action:chat + ^- (quip move _this) + :_ this + %+ turn lis.act + |= hac=action:hall + ^- move + :* ost.bol + %poke + /p/[(scot %da now.bol)] + [our.bol %hall] + [%hall-action hac] + == +:: +:: +send-chat-update: utility func for sending updates to all our subscribers +:: +++ send-chat-update + |= [upd=update str=streams] + ^- (list move) + =/ updates/(list move) + %+ turn (prey:pubsub:userlib /primary bol) + |= [=bone *] + [bone %diff %chat-update upd] + :: + =/ jon/json (construct-tile-json str) + =/ tile-updates/(list move) + %+ turn (prey:pubsub:userlib /chattile bol) + |= [=bone *] + [bone %diff %json jon] + :: + %+ weld + updates + tile-updates +:: +:: +:: +hall arms +:: +:: +:: +diff-hall-prize: handle full state initially handed to us by hall +:: +++ diff-hall-prize + |= [wir=wire piz=prize:hall] + ^- (quip move _this) + ?~ wir + (mean [leaf+"invalid wire for diff: {(spud wir)}"]~) + ?+ i.wir + (mean [leaf+"invalid wire for diff: {(spud wir)}"]~) + :: + :: %circles wire + :: + %circles + ?> ?=(%circles -.piz) + =/ str %= str.sta + circles cis.piz + == + :- (send-chat-update [[%circles cis.piz] str]) + this(str.sta str) + :: + :: %circle wire + :: + %circle +:: :: +:: :: %circle prize +:: :: +:: %circle + ?> ?=(%circle -.piz) + =/ circle/circle:hall [our.bol &3:wir] + ?: =(circle [our.bol %inbox]) + :: + :: fill inbox config and remote configs with prize data + :: + =/ configs + %- ~(uni in configs.str.sta) + ^- (map circle:hall (unit config:hall)) + (~(run by rem.cos.piz) |=(a=config:hall `a)) + :: + =/ circles/(list circle:hall) + %+ turn ~(tap in src.loc.cos.piz) + |= src=source:hall + ^- circle:hall + cir.src + :: + =/ meslis/(list [circle:hall (list envelope:hall)]) + %+ turn circles + |= cir=circle:hall + ^- [circle:hall (list envelope:hall)] + [cir ~] + :: + =/ localpeers/(set @p) + %- silt %+ turn ~(tap by loc.pes.piz) + |= [shp=@p stat=status:hall] + shp + :: + =/ peers/(map circle:hall (set @p)) + %- ~(rep by rem.pes.piz) + |= [[cir=circle:hall grp=group:hall] acc=(map circle:hall (set @p))] + ^- (map circle:hall (set @p)) + =/ newset + %- silt %+ turn ~(tap by grp) + |= [shp=@p stat=status:hall] + shp + (~(put by acc) cir newset) + :: + :- + %+ turn ~(tap in (~(del in (silt circles)) [our.bol %inbox])) + |= cir=circle:hall + ^- move + =/ wir/wire /circle/[(scot %p our.bol)]/[nom.cir]/config/group + =/ pat/path /circle/[nom.cir]/config/group + [ost.bol %peer wir [our.bol %hall] pat] + :: + %= this + inbox.str.sta loc.cos.piz + configs.str.sta configs + messages.str.sta (molt meslis) + peers.str.sta (~(put by peers) [our.bol %inbox] localpeers) + == + :: + :: fill remote configs with message data + :: + =* messages messages.str.sta + =/ circle/circle:hall [`@p`(slav %p &2:wir) &3:wir] + =/ localpeers/(set @p) + %- silt %+ turn ~(tap by loc.pes.piz) + |= [shp=@p stat=status:hall] + shp + :: + =/ peers/(map circle:hall (set @p)) + %- ~(rep by rem.pes.piz) + |= [[cir=circle:hall grp=group:hall] acc=(map circle:hall (set @p))] + ^- (map circle:hall (set @p)) + =/ newset + %- silt %+ turn ~(tap by grp) + |= [shp=@p stat=status:hall] + shp + (~(put by acc) cir newset) + =/ str + %= str.sta + messages (~(put by messages) circle nes.piz) + peers (~(uni by peers.str.sta) (~(put by peers) circle localpeers)) + == + =/ messageupdate/update + :* %messages + circle + 0 + (lent messages) + nes.piz + == + :- (send-chat-update [messageupdate str]) + this(str.sta str) + == +:: +:: +diff-hall-rumor: handle updates to hall state +:: +++ diff-hall-rumor + |= [wir=wire rum=rumor:hall] + ^- (quip move _this) + ?~ wir + (mean [leaf+"invalid wire for diff: {(spud wir)}"]~) + ?+ i.wir + (mean [leaf+"invalid wire for diff: {(spud wir)}"]~) + :: + :: %circles + %circles + ?> ?=(%circles -.rum) + =/ cis + ?: add.rum + (~(put in circles.str.sta) cir.rum) + (~(del in circles.str.sta) cir.rum) + =/ str + %= str.sta + circles cis + peers + ?: add.rum + (~(put by peers.str.sta) [our.bol cir.rum] ~) + (~(del by peers.str.sta) [our.bol cir.rum]) + == + :- (send-chat-update [[%circles cis] str]) + this(str.sta str) + :: + :: + :: %circle: fill remote configs with message data + :: + %circle + ?> ?=(%circle -.rum) + =* sto rum.rum + ?+ -.sto + [~ this] + :: + :: %gram: + :: + %gram + ?> ?=(%gram -.sto) + =* messages messages.str.sta + =/ circle/circle:hall [`@p`(slav %p &2:wir) &3:wir] + =/ unes/(unit (list envelope:hall)) (~(get by messages) circle) + ?~ unes + [~ this] + =/ nes u.unes + =/ str + %= str.sta + messages (~(put by messages) circle (snoc nes nev.sto)) + == + :- (send-chat-update [[%message circle nev.sto] str]) + this(str.sta str) + :: + :: %status: + :: + %status + ?> ?=(%status -.sto) + =/ upeers/(unit (set @p)) (~(get by peers.str.sta) cir.sto) + ?~ upeers + [~ this] + =/ peers/(set @p) + ?: =(%remove -.dif.sto) + (~(del in u.upeers) who.sto) + (~(put in u.upeers) who.sto) + =/ str + %= str.sta + peers (~(put by peers.str.sta) cir.sto peers) + == + :- (send-chat-update [[%peers cir.sto peers] str]) + this(str.sta str) + :: + :: %config: config has changed + :: + %config + =* circ cir.sto + :: + ?+ -.dif.sto + [~ this] + :: + :: %full: set all of config without side effects + :: + %full + =* conf cof.dif.sto + =/ str + %= str.sta + configs (~(put by configs.str.sta) circ `conf) + == + :- (send-chat-update [[%config circ conf] str]) + this(str.sta str) + :: + :: %read: the read count of one of our configs has changed + :: + %read + ?: =(circ [our.bol %inbox]) + :: ignore when circ is inbox + [~ this] + =/ uconf/(unit config:hall) (~(got by configs.str.sta) circ) + ?~ uconf + :: should we crash? + [~ this] + =/ conf/config:hall + %= u.uconf + red red.dif.sto + == + =/ str + %= str.sta + configs (~(put by configs.str.sta) circ `conf) + == + :- (send-chat-update [[%config circ conf] str]) + this(str.sta str) + :: + :: %source: the sources of our inbox have changed + :: + %source + ?. =(circ [our.bol %inbox]) + :: ignore when circ is not inbox + [~ this] + =* affectedcir cir.src.dif.sto + =/ newwir/wire + /circle/[(scot %p hos.affectedcir)]/[nom.affectedcir]/grams/0/config/group + =/ pat/path /circle/[nom.affectedcir]/grams/0/config/group + :: we've added a source to our inbox + :: + ?: add.dif.sto + =/ newinbox %= inbox.str.sta + src (~(put in src.inbox.str.sta) src.dif.sto) + == + =/ str + %= str.sta + inbox newinbox + :: + configs + ?: (~(has by configs.str.sta) affectedcir) + configs.str.sta + (~(put by configs.str.sta) affectedcir ~) + == + :: + :_ this(str.sta str) + %+ weld + [ost.bol %peer newwir [hos.affectedcir %hall] pat]~ + (send-chat-update [[%inbox newinbox] str]) + :: + =/ newinbox %= inbox.str.sta + src (~(del in src.inbox.str.sta) src.dif.sto) + == + :: we've removed a source from our inbox + :: + =/ str + %= str.sta + inbox newinbox + :: + configs (~(del by configs.str.sta) affectedcir) + messages (~(del by messages.str.sta) affectedcir) + peers (~(del by peers.str.sta) affectedcir) + == + =/ fakecir/circle:hall + :- our.bol + %- crip + %+ weld (trip 'hall-internal-') (trip nom.affectedcir) + :: + ?~ (~(get by configs.str) fakecir) + :: just forward the delete to our clients + :: + :_ this(str.sta str) + %+ weld + [ost.bol %pull newwir [hos.affectedcir %hall] ~]~ + %+ weld + (send-chat-update [[%inbox newinbox] str]) + (send-chat-update [[%delete affectedcir] str]) + :: if we get a delete from another ship, delete our fake circle copy + :: + =/ deletefake/poke + :- %hall-action + [%delete nom.fakecir ~] + :_ this(str.sta str) + %+ weld + [ost.bol %pull newwir [hos.affectedcir %hall] ~]~ + %+ weld + [ost.bol %poke /fake [our.bol %hall] deletefake]~ + %+ weld + (send-chat-update [[%inbox newinbox] str]) + (send-chat-update [[%delete affectedcir] str]) + :: + :: %remove: remove a circle + :: + %remove + =/ str + %= str.sta + configs (~(del by configs.str.sta) circ) + messages (~(del by messages.str.sta) circ) + peers (~(del by peers.str.sta) circ) + == + :- (send-chat-update [[%delete circ] str]) + this(str.sta str) + :: + == + :: end of branching on dif.sto type + == + :: end of branching on sto type + == + :: end of i.wir branching +:: +:: +lient arms +:: +:: +:: +bound: lient tells us we successfully bound our server to the ~chat url +:: +++ bound + |= [wir=wire success=? binding=binding:eyre] + ^- (quip move _this) + [~ this] +:: +:: +poke-handle-http-request: serve pages from file system based on URl path +:: +++ poke-handle-http-request + %- (require-authorization:app ost.bol move this) + |= =inbound-request:eyre + ^- (quip move _this) + :: + =+ request-line=(parse-request-line url.request.inbound-request) + =/ name=@t + =+ back-path=(flop site.request-line) + ?~ back-path + '' + i.back-path + ?: =(name 'tile') + [[ost.bol %http-response (js-response:app tile-js)]~ this] + ?+ site.request-line + :_ this + [ost.bol %http-response not-found:app]~ + :: + :: styling + :: + [%'~chat' %css %index ~] + :_ this + [ost.bol %http-response (css-response:app style)]~ + :: + :: javascript + :: + [%'~chat' %js %index ~] + :_ this + [ost.bol %http-response (js-response:app script)]~ + :: + :: images + :: + [%'~chat' %img *] + =/ img (as-octs:mimes:html (~(got by chat-png) `@ta`name)) + :_ this + [ost.bol %http-response (png-response:app img)]~ + :: + :: paginated message data + :: + [%'~chat' %scroll @t @t @t @t ~] + =/ cir/circle:hall [(slav %p &3:site.request-line) &4:site.request-line] + =/ start/@ud (need (rush &5:site.request-line dem)) + =/ parsedend/@ud (need (rush &6:site.request-line dem)) + =* messages messages.str.sta + =/ envs/(unit (list envelope:hall)) (~(get by messages) cir) + ?~ envs + [~ this] + ?: (gte start (lent u.envs)) + [~ this] + =/ end/@ + ?: (gte parsedend (lent u.envs)) + (dec (lent u.envs)) + parsedend + =/ offset (sub end start) + =/ jon/json %- msg-to-json + :* %messages + cir + start + end + (swag [start offset] u.envs) + == + :_ this + [ost.bol %http-response (json-response:app (json-to-octs jon))]~ + :: + :: + :: inbox page + :: + [%'~chat' *] + :_ this + [ost.bol %http-response (html-response:app index)]~ + == +:: +:: +:: +subscription-retry arms +:: +:: +:: +reap: recieve acknowledgement for peer, retry on failure +:: +++ reap + |= [wir=wire err=(unit tang)] + ^- (quip move _this) + ?~ err + [~ this] + ?~ wir + (mean [leaf+"invalid wire for diff: {(spud wir)}"]~) + ?+ i.wir + (mean [leaf+"invalid wire for diff: {(spud wir)}"]~) + :: + %circle + =/ shp/@p (slav %p &2:wir) + =/ pat /circle/[&3:wir]/config/group + ?: =(&3:wir 'inbox') + :_ this + [ost.bol %peer wir [shp %hall] pat]~ + ?: (~(has in src.inbox.str.sta) [[shp &3:wir] ~]) + :_ this + [ost.bol %peer wir [shp %hall] pat]~ + [~ this] + :: + %circles + :_ this + [ost.bol %peer wir [our.bol %hall] wir]~ + == +:: +:: +quit: subscription failed/quit at some point, retry +:: +++ quit + |= wir=wire + ^- (quip move _this) + ?~ wir + (mean [leaf+"invalid wire for diff: {(spud wir)}"]~) + ?+ i.wir + (mean [leaf+"invalid wire for diff: {(spud wir)}"]~) + :: + %circle + =/ shp/@p (slav %p &2:wir) + =/ pat /circle/[&3:wir]/config/group + ?: =(&3:wir 'inbox') + :_ this + [ost.bol %peer wir [shp %hall] pat]~ + ?: (~(has in src.inbox.str.sta) [[shp &3:wir] ~]) + :_ this + [ost.bol %peer wir [shp %hall] pat]~ + [~ this] + :: + %circles + :_ this + [ost.bol %peer wir [our.bol %hall] wir]~ + == +:: +-- diff --git a/pkg/arvo/app/chat/css/index.css b/pkg/arvo/app/chat/css/index.css new file mode 100644 index 000000000..83068c326 --- /dev/null +++ b/pkg/arvo/app/chat/css/index.css @@ -0,0 +1,2 @@ +/*! TACHYONS v4.11.2 | http://tachyons.io */ +/*! normalize.css v8.0.0 | MIT License | github.com/necolas/normalize.css */html{line-height:1.15;-webkit-text-size-adjust:100%}body{margin:0}h1{font-size:2em;margin:.67em 0}hr{box-sizing:content-box;height:0;overflow:visible}pre{font-family:monospace,monospace;font-size:1em}a{background-color:transparent}abbr[title]{border-bottom:none;text-decoration:underline;-webkit-text-decoration:underline dotted;text-decoration:underline dotted}b,strong{font-weight:bolder}code,kbd,samp{font-family:monospace,monospace;font-size:1em}small{font-size:80%}sub,sup{font-size:75%;line-height:0;position:relative;vertical-align:baseline}sub{bottom:-.25em}sup{top:-.5em}img{border-style:none}button,input,optgroup,select,textarea{font-family:inherit;font-size:100%;line-height:1.15;margin:0}button,input{overflow:visible}button,select{text-transform:none}[type=button],[type=reset],[type=submit],button{-webkit-appearance:button}[type=button]::-moz-focus-inner,[type=reset]::-moz-focus-inner,[type=submit]::-moz-focus-inner,button::-moz-focus-inner{border-style:none;padding:0}[type=button]:-moz-focusring,[type=reset]:-moz-focusring,[type=submit]:-moz-focusring,button:-moz-focusring{outline:1px dotted ButtonText}fieldset{padding:.35em .75em .625em}legend{box-sizing:border-box;color:inherit;display:table;max-width:100%;padding:0;white-space:normal}progress{vertical-align:baseline}textarea{overflow:auto}[type=checkbox],[type=radio]{box-sizing:border-box;padding:0}[type=number]::-webkit-inner-spin-button,[type=number]::-webkit-outer-spin-button{height:auto}[type=search]{-webkit-appearance:textfield;outline-offset:-2px}[type=search]::-webkit-search-decoration{-webkit-appearance:none}::-webkit-file-upload-button{-webkit-appearance:button;font:inherit}details{display:block}summary{display:list-item}[hidden],template{display:none}.border-box,a,article,aside,blockquote,body,code,dd,div,dl,dt,fieldset,figcaption,figure,footer,form,h1,h2,h3,h4,h5,h6,header,html,input[type=email],input[type=number],input[type=password],input[type=tel],input[type=text],input[type=url],legend,li,main,nav,ol,p,pre,section,table,td,textarea,th,tr,ul{box-sizing:border-box}.aspect-ratio{height:0;position:relative}.aspect-ratio--16x9{padding-bottom:56.25%}.aspect-ratio--9x16{padding-bottom:177.77%}.aspect-ratio--4x3{padding-bottom:75%}.aspect-ratio--3x4{padding-bottom:133.33%}.aspect-ratio--6x4{padding-bottom:66.6%}.aspect-ratio--4x6{padding-bottom:150%}.aspect-ratio--8x5{padding-bottom:62.5%}.aspect-ratio--5x8{padding-bottom:160%}.aspect-ratio--7x5{padding-bottom:71.42%}.aspect-ratio--5x7{padding-bottom:140%}.aspect-ratio--1x1{padding-bottom:100%}.aspect-ratio--object{position:absolute;top:0;right:0;bottom:0;left:0;width:100%;height:100%;z-index:100}img{max-width:100%}.cover{background-size:cover!important}.contain{background-size:contain!important}.bg-center{background-position:50%}.bg-center,.bg-top{background-repeat:no-repeat}.bg-top{background-position:top}.bg-right{background-position:100%}.bg-bottom,.bg-right{background-repeat:no-repeat}.bg-bottom{background-position:bottom}.bg-left{background-repeat:no-repeat;background-position:0}.outline{outline:1px solid}.outline-transparent{outline:1px solid transparent}.outline-0{outline:0}.ba{border-style:solid;border-width:1px}.bt{border-top-style:solid;border-top-width:1px}.br{border-right-style:solid;border-right-width:1px}.bb{border-bottom-style:solid;border-bottom-width:1px}.bl{border-left-style:solid;border-left-width:1px}.bn{border-style:none;border-width:0}.b--black{border-color:#000}.b--near-black{border-color:#111}.b--dark-gray{border-color:#333}.b--mid-gray{border-color:#555}.b--gray{border-color:#777}.b--silver{border-color:#999}.b--light-silver{border-color:#aaa}.b--moon-gray{border-color:#ccc}.b--light-gray{border-color:#eee}.b--near-white{border-color:#f4f4f4}.b--white{border-color:#fff}.b--white-90{border-color:hsla(0,0%,100%,.9)}.b--white-80{border-color:hsla(0,0%,100%,.8)}.b--white-70{border-color:hsla(0,0%,100%,.7)}.b--white-60{border-color:hsla(0,0%,100%,.6)}.b--white-50{border-color:hsla(0,0%,100%,.5)}.b--white-40{border-color:hsla(0,0%,100%,.4)}.b--white-30{border-color:hsla(0,0%,100%,.3)}.b--white-20{border-color:hsla(0,0%,100%,.2)}.b--white-10{border-color:hsla(0,0%,100%,.1)}.b--white-05{border-color:hsla(0,0%,100%,.05)}.b--white-025{border-color:hsla(0,0%,100%,.025)}.b--white-0125{border-color:hsla(0,0%,100%,.0125)}.b--black-90{border-color:rgba(0,0,0,.9)}.b--black-80{border-color:rgba(0,0,0,.8)}.b--black-70{border-color:rgba(0,0,0,.7)}.b--black-60{border-color:rgba(0,0,0,.6)}.b--black-50{border-color:rgba(0,0,0,.5)}.b--black-40{border-color:rgba(0,0,0,.4)}.b--black-30{border-color:rgba(0,0,0,.3)}.b--black-20{border-color:rgba(0,0,0,.2)}.b--black-10{border-color:rgba(0,0,0,.1)}.b--black-05{border-color:rgba(0,0,0,.05)}.b--black-025{border-color:rgba(0,0,0,.025)}.b--black-0125{border-color:rgba(0,0,0,.0125)}.b--dark-red{border-color:#e7040f}.b--red{border-color:#ff4136}.b--light-red{border-color:#ff725c}.b--orange{border-color:#ff6300}.b--gold{border-color:#ffb700}.b--yellow{border-color:gold}.b--light-yellow{border-color:#fbf1a9}.b--purple{border-color:#5e2ca5}.b--light-purple{border-color:#a463f2}.b--dark-pink{border-color:#d5008f}.b--hot-pink{border-color:#ff41b4}.b--pink{border-color:#ff80cc}.b--light-pink{border-color:#ffa3d7}.b--dark-green{border-color:#137752}.b--green{border-color:#19a974}.b--light-green{border-color:#9eebcf}.b--navy{border-color:#001b44}.b--dark-blue{border-color:#00449e}.b--blue{border-color:#357edd}.b--light-blue{border-color:#96ccff}.b--lightest-blue{border-color:#cdecff}.b--washed-blue{border-color:#f6fffe}.b--washed-green{border-color:#e8fdf5}.b--washed-yellow{border-color:#fffceb}.b--washed-red{border-color:#ffdfdf}.b--transparent{border-color:transparent}.b--inherit{border-color:inherit}.br0{border-radius:0}.br1{border-radius:.125rem}.br2{border-radius:.25rem}.br3{border-radius:.5rem}.br4{border-radius:1rem}.br-100{border-radius:100%}.br-pill{border-radius:9999px}.br--bottom{border-top-left-radius:0;border-top-right-radius:0}.br--top{border-bottom-right-radius:0}.br--right,.br--top{border-bottom-left-radius:0}.br--right{border-top-left-radius:0}.br--left{border-top-right-radius:0;border-bottom-right-radius:0}.b--dotted{border-style:dotted}.b--dashed{border-style:dashed}.b--solid{border-style:solid}.b--none{border-style:none}.bw0{border-width:0}.bw1{border-width:.125rem}.bw2{border-width:.25rem}.bw3{border-width:.5rem}.bw4{border-width:1rem}.bw5{border-width:2rem}.bt-0{border-top-width:0}.br-0{border-right-width:0}.bb-0{border-bottom-width:0}.bl-0{border-left-width:0}.shadow-1{box-shadow:0 0 4px 2px rgba(0,0,0,.2)}.shadow-2{box-shadow:0 0 8px 2px rgba(0,0,0,.2)}.shadow-3{box-shadow:2px 2px 4px 2px rgba(0,0,0,.2)}.shadow-4{box-shadow:2px 2px 8px 0 rgba(0,0,0,.2)}.shadow-5{box-shadow:4px 4px 8px 0 rgba(0,0,0,.2)}.pre{overflow-x:auto;overflow-y:hidden;overflow:scroll}.top-0{top:0}.right-0{right:0}.bottom-0{bottom:0}.left-0{left:0}.top-1{top:1rem}.right-1{right:1rem}.bottom-1{bottom:1rem}.left-1{left:1rem}.top-2{top:2rem}.right-2{right:2rem}.bottom-2{bottom:2rem}.left-2{left:2rem}.top--1{top:-1rem}.right--1{right:-1rem}.bottom--1{bottom:-1rem}.left--1{left:-1rem}.top--2{top:-2rem}.right--2{right:-2rem}.bottom--2{bottom:-2rem}.left--2{left:-2rem}.absolute--fill{top:0;right:0;bottom:0;left:0}.cf:after,.cf:before{content:" ";display:table}.cf:after{clear:both}.cf{*zoom:1}.cl{clear:left}.cr{clear:right}.cb{clear:both}.cn{clear:none}.dn{display:none}.di{display:inline}.db{display:block}.dib{display:inline-block}.dit{display:inline-table}.dt{display:table}.dtc{display:table-cell}.dt-row{display:table-row}.dt-row-group{display:table-row-group}.dt-column{display:table-column}.dt-column-group{display:table-column-group}.dt--fixed{table-layout:fixed;width:100%}.flex{display:flex}.inline-flex{display:inline-flex}.flex-auto{flex:1 1 auto;min-width:0;min-height:0}.flex-none{flex:none}.flex-column{flex-direction:column}.flex-row{flex-direction:row}.flex-wrap{flex-wrap:wrap}.flex-nowrap{flex-wrap:nowrap}.flex-wrap-reverse{flex-wrap:wrap-reverse}.flex-column-reverse{flex-direction:column-reverse}.flex-row-reverse{flex-direction:row-reverse}.items-start{align-items:flex-start}.items-end{align-items:flex-end}.items-center{align-items:center}.items-baseline{align-items:baseline}.items-stretch{align-items:stretch}.self-start{align-self:flex-start}.self-end{align-self:flex-end}.self-center{align-self:center}.self-baseline{align-self:baseline}.self-stretch{align-self:stretch}.justify-start{justify-content:flex-start}.justify-end{justify-content:flex-end}.justify-center{justify-content:center}.justify-between{justify-content:space-between}.justify-around{justify-content:space-around}.content-start{align-content:flex-start}.content-end{align-content:flex-end}.content-center{align-content:center}.content-between{align-content:space-between}.content-around{align-content:space-around}.content-stretch{align-content:stretch}.order-0{order:0}.order-1{order:1}.order-2{order:2}.order-3{order:3}.order-4{order:4}.order-5{order:5}.order-6{order:6}.order-7{order:7}.order-8{order:8}.order-last{order:99999}.flex-grow-0{flex-grow:0}.flex-grow-1{flex-grow:1}.flex-shrink-0{flex-shrink:0}.flex-shrink-1{flex-shrink:1}.fl{float:left}.fl,.fr{_display:inline}.fr{float:right}.fn{float:none}.sans-serif{font-family:-apple-system,BlinkMacSystemFont,avenir next,avenir,helvetica neue,helvetica,ubuntu,roboto,noto,segoe ui,arial,sans-serif}.serif{font-family:georgia,times,serif}.system-sans-serif{font-family:sans-serif}.system-serif{font-family:serif}.code,code{font-family:Consolas,monaco,monospace}.courier{font-family:Courier Next,courier,monospace}.helvetica{font-family:helvetica neue,helvetica,sans-serif}.avenir{font-family:avenir next,avenir,sans-serif}.athelas{font-family:athelas,georgia,serif}.georgia{font-family:georgia,serif}.times{font-family:times,serif}.bodoni{font-family:Bodoni MT,serif}.calisto{font-family:Calisto MT,serif}.garamond{font-family:garamond,serif}.baskerville{font-family:baskerville,serif}.i{font-style:italic}.fs-normal{font-style:normal}.normal{font-weight:400}.b{font-weight:700}.fw1{font-weight:100}.fw2{font-weight:200}.fw3{font-weight:300}.fw4{font-weight:400}.fw5{font-weight:500}.fw6{font-weight:600}.fw7{font-weight:700}.fw8{font-weight:800}.fw9{font-weight:900}.input-reset{-webkit-appearance:none;-moz-appearance:none}.button-reset::-moz-focus-inner,.input-reset::-moz-focus-inner{border:0;padding:0}.h1{height:1rem}.h2{height:2rem}.h3{height:4rem}.h4{height:8rem}.h5{height:16rem}.h-25{height:25%}.h-50{height:50%}.h-75{height:75%}.h-100{height:100%}.min-h-100{min-height:100%}.vh-25{height:25vh}.vh-50{height:50vh}.vh-75{height:75vh}.vh-100{height:100vh}.min-vh-100{min-height:100vh}.h-auto{height:auto}.h-inherit{height:inherit}.tracked{letter-spacing:.1em}.tracked-tight{letter-spacing:-.05em}.tracked-mega{letter-spacing:.25em}.lh-solid{line-height:1}.lh-title{line-height:1.25}.lh-copy{line-height:1.5}.link{text-decoration:none}.link,.link:active,.link:focus,.link:hover,.link:link,.link:visited{transition:color .15s ease-in}.link:focus{outline:1px dotted currentColor}.list{list-style-type:none}.mw-100{max-width:100%}.mw1{max-width:1rem}.mw2{max-width:2rem}.mw3{max-width:4rem}.mw4{max-width:8rem}.mw5{max-width:16rem}.mw6{max-width:32rem}.mw7{max-width:48rem}.mw8{max-width:64rem}.mw9{max-width:96rem}.mw-none{max-width:none}.w1{width:1rem}.w2{width:2rem}.w3{width:4rem}.w4{width:8rem}.w5{width:16rem}.w-10{width:10%}.w-20{width:20%}.w-25{width:25%}.w-30{width:30%}.w-33{width:33%}.w-34{width:34%}.w-40{width:40%}.w-50{width:50%}.w-60{width:60%}.w-70{width:70%}.w-75{width:75%}.w-80{width:80%}.w-90{width:90%}.w-100{width:100%}.w-third{width:33.33333%}.w-two-thirds{width:66.66667%}.w-auto{width:auto}.overflow-visible{overflow:visible}.overflow-hidden{overflow:hidden}.overflow-scroll{overflow:scroll}.overflow-auto{overflow:auto}.overflow-x-visible{overflow-x:visible}.overflow-x-hidden{overflow-x:hidden}.overflow-x-scroll{overflow-x:scroll}.overflow-x-auto{overflow-x:auto}.overflow-y-visible{overflow-y:visible}.overflow-y-hidden{overflow-y:hidden}.overflow-y-scroll{overflow-y:scroll}.overflow-y-auto{overflow-y:auto}.static{position:static}.relative{position:relative}.absolute{position:absolute}.fixed{position:fixed}.o-100{opacity:1}.o-90{opacity:.9}.o-80{opacity:.8}.o-70{opacity:.7}.o-60{opacity:.6}.o-50{opacity:.5}.o-40{opacity:.4}.o-30{opacity:.3}.o-20{opacity:.2}.o-10{opacity:.1}.o-05{opacity:.05}.o-025{opacity:.025}.o-0{opacity:0}.rotate-45{transform:rotate(45deg)}.rotate-90{transform:rotate(90deg)}.rotate-135{transform:rotate(135deg)}.rotate-180{transform:rotate(180deg)}.rotate-225{transform:rotate(225deg)}.rotate-270{transform:rotate(270deg)}.rotate-315{transform:rotate(315deg)}.black-90{color:rgba(0,0,0,.9)}.black-80{color:rgba(0,0,0,.8)}.black-70{color:rgba(0,0,0,.7)}.black-60{color:rgba(0,0,0,.6)}.black-50{color:rgba(0,0,0,.5)}.black-40{color:rgba(0,0,0,.4)}.black-30{color:rgba(0,0,0,.3)}.black-20{color:rgba(0,0,0,.2)}.black-10{color:rgba(0,0,0,.1)}.black-05{color:rgba(0,0,0,.05)}.white-90{color:hsla(0,0%,100%,.9)}.white-80{color:hsla(0,0%,100%,.8)}.white-70{color:hsla(0,0%,100%,.7)}.white-60{color:hsla(0,0%,100%,.6)}.white-50{color:hsla(0,0%,100%,.5)}.white-40{color:hsla(0,0%,100%,.4)}.white-30{color:hsla(0,0%,100%,.3)}.white-20{color:hsla(0,0%,100%,.2)}.white-10{color:hsla(0,0%,100%,.1)}.black{color:#000}.near-black{color:#111}.dark-gray{color:#333}.mid-gray{color:#555}.gray{color:#777}.silver{color:#999}.light-silver{color:#aaa}.moon-gray{color:#ccc}.light-gray{color:#eee}.near-white{color:#f4f4f4}.white{color:#fff}.dark-red{color:#e7040f}.red{color:#ff4136}.light-red{color:#ff725c}.orange{color:#ff6300}.gold{color:#ffb700}.yellow{color:gold}.light-yellow{color:#fbf1a9}.purple{color:#5e2ca5}.light-purple{color:#a463f2}.dark-pink{color:#d5008f}.hot-pink{color:#ff41b4}.pink{color:#ff80cc}.light-pink{color:#ffa3d7}.dark-green{color:#137752}.green{color:#19a974}.light-green{color:#9eebcf}.navy{color:#001b44}.dark-blue{color:#00449e}.blue{color:#357edd}.light-blue{color:#96ccff}.lightest-blue{color:#cdecff}.washed-blue{color:#f6fffe}.washed-green{color:#e8fdf5}.washed-yellow{color:#fffceb}.washed-red{color:#ffdfdf}.color-inherit{color:inherit}.bg-black-90{background-color:rgba(0,0,0,.9)}.bg-black-80{background-color:rgba(0,0,0,.8)}.bg-black-70{background-color:rgba(0,0,0,.7)}.bg-black-60{background-color:rgba(0,0,0,.6)}.bg-black-50{background-color:rgba(0,0,0,.5)}.bg-black-40{background-color:rgba(0,0,0,.4)}.bg-black-30{background-color:rgba(0,0,0,.3)}.bg-black-20{background-color:rgba(0,0,0,.2)}.bg-black-10{background-color:rgba(0,0,0,.1)}.bg-black-05{background-color:rgba(0,0,0,.05)}.bg-white-90{background-color:hsla(0,0%,100%,.9)}.bg-white-80{background-color:hsla(0,0%,100%,.8)}.bg-white-70{background-color:hsla(0,0%,100%,.7)}.bg-white-60{background-color:hsla(0,0%,100%,.6)}.bg-white-50{background-color:hsla(0,0%,100%,.5)}.bg-white-40{background-color:hsla(0,0%,100%,.4)}.bg-white-30{background-color:hsla(0,0%,100%,.3)}.bg-white-20{background-color:hsla(0,0%,100%,.2)}.bg-white-10{background-color:hsla(0,0%,100%,.1)}.bg-black{background-color:#000}.bg-near-black{background-color:#111}.bg-dark-gray{background-color:#333}.bg-mid-gray{background-color:#555}.bg-gray{background-color:#777}.bg-silver{background-color:#999}.bg-light-silver{background-color:#aaa}.bg-moon-gray{background-color:#ccc}.bg-light-gray{background-color:#eee}.bg-near-white{background-color:#f4f4f4}.bg-white{background-color:#fff}.bg-transparent{background-color:transparent}.bg-dark-red{background-color:#e7040f}.bg-red{background-color:#ff4136}.bg-light-red{background-color:#ff725c}.bg-orange{background-color:#ff6300}.bg-gold{background-color:#ffb700}.bg-yellow{background-color:gold}.bg-light-yellow{background-color:#fbf1a9}.bg-purple{background-color:#5e2ca5}.bg-light-purple{background-color:#a463f2}.bg-dark-pink{background-color:#d5008f}.bg-hot-pink{background-color:#ff41b4}.bg-pink{background-color:#ff80cc}.bg-light-pink{background-color:#ffa3d7}.bg-dark-green{background-color:#137752}.bg-green{background-color:#19a974}.bg-light-green{background-color:#9eebcf}.bg-navy{background-color:#001b44}.bg-dark-blue{background-color:#00449e}.bg-blue{background-color:#357edd}.bg-light-blue{background-color:#96ccff}.bg-lightest-blue{background-color:#cdecff}.bg-washed-blue{background-color:#f6fffe}.bg-washed-green{background-color:#e8fdf5}.bg-washed-yellow{background-color:#fffceb}.bg-washed-red{background-color:#ffdfdf}.bg-inherit{background-color:inherit}.hover-black:focus,.hover-black:hover{color:#000}.hover-near-black:focus,.hover-near-black:hover{color:#111}.hover-dark-gray:focus,.hover-dark-gray:hover{color:#333}.hover-mid-gray:focus,.hover-mid-gray:hover{color:#555}.hover-gray:focus,.hover-gray:hover{color:#777}.hover-silver:focus,.hover-silver:hover{color:#999}.hover-light-silver:focus,.hover-light-silver:hover{color:#aaa}.hover-moon-gray:focus,.hover-moon-gray:hover{color:#ccc}.hover-light-gray:focus,.hover-light-gray:hover{color:#eee}.hover-near-white:focus,.hover-near-white:hover{color:#f4f4f4}.hover-white:focus,.hover-white:hover{color:#fff}.hover-black-90:focus,.hover-black-90:hover{color:rgba(0,0,0,.9)}.hover-black-80:focus,.hover-black-80:hover{color:rgba(0,0,0,.8)}.hover-black-70:focus,.hover-black-70:hover{color:rgba(0,0,0,.7)}.hover-black-60:focus,.hover-black-60:hover{color:rgba(0,0,0,.6)}.hover-black-50:focus,.hover-black-50:hover{color:rgba(0,0,0,.5)}.hover-black-40:focus,.hover-black-40:hover{color:rgba(0,0,0,.4)}.hover-black-30:focus,.hover-black-30:hover{color:rgba(0,0,0,.3)}.hover-black-20:focus,.hover-black-20:hover{color:rgba(0,0,0,.2)}.hover-black-10:focus,.hover-black-10:hover{color:rgba(0,0,0,.1)}.hover-white-90:focus,.hover-white-90:hover{color:hsla(0,0%,100%,.9)}.hover-white-80:focus,.hover-white-80:hover{color:hsla(0,0%,100%,.8)}.hover-white-70:focus,.hover-white-70:hover{color:hsla(0,0%,100%,.7)}.hover-white-60:focus,.hover-white-60:hover{color:hsla(0,0%,100%,.6)}.hover-white-50:focus,.hover-white-50:hover{color:hsla(0,0%,100%,.5)}.hover-white-40:focus,.hover-white-40:hover{color:hsla(0,0%,100%,.4)}.hover-white-30:focus,.hover-white-30:hover{color:hsla(0,0%,100%,.3)}.hover-white-20:focus,.hover-white-20:hover{color:hsla(0,0%,100%,.2)}.hover-white-10:focus,.hover-white-10:hover{color:hsla(0,0%,100%,.1)}.hover-inherit:focus,.hover-inherit:hover{color:inherit}.hover-bg-black:focus,.hover-bg-black:hover{background-color:#000}.hover-bg-near-black:focus,.hover-bg-near-black:hover{background-color:#111}.hover-bg-dark-gray:focus,.hover-bg-dark-gray:hover{background-color:#333}.hover-bg-mid-gray:focus,.hover-bg-mid-gray:hover{background-color:#555}.hover-bg-gray:focus,.hover-bg-gray:hover{background-color:#777}.hover-bg-silver:focus,.hover-bg-silver:hover{background-color:#999}.hover-bg-light-silver:focus,.hover-bg-light-silver:hover{background-color:#aaa}.hover-bg-moon-gray:focus,.hover-bg-moon-gray:hover{background-color:#ccc}.hover-bg-light-gray:focus,.hover-bg-light-gray:hover{background-color:#eee}.hover-bg-near-white:focus,.hover-bg-near-white:hover{background-color:#f4f4f4}.hover-bg-white:focus,.hover-bg-white:hover{background-color:#fff}.hover-bg-transparent:focus,.hover-bg-transparent:hover{background-color:transparent}.hover-bg-black-90:focus,.hover-bg-black-90:hover{background-color:rgba(0,0,0,.9)}.hover-bg-black-80:focus,.hover-bg-black-80:hover{background-color:rgba(0,0,0,.8)}.hover-bg-black-70:focus,.hover-bg-black-70:hover{background-color:rgba(0,0,0,.7)}.hover-bg-black-60:focus,.hover-bg-black-60:hover{background-color:rgba(0,0,0,.6)}.hover-bg-black-50:focus,.hover-bg-black-50:hover{background-color:rgba(0,0,0,.5)}.hover-bg-black-40:focus,.hover-bg-black-40:hover{background-color:rgba(0,0,0,.4)}.hover-bg-black-30:focus,.hover-bg-black-30:hover{background-color:rgba(0,0,0,.3)}.hover-bg-black-20:focus,.hover-bg-black-20:hover{background-color:rgba(0,0,0,.2)}.hover-bg-black-10:focus,.hover-bg-black-10:hover{background-color:rgba(0,0,0,.1)}.hover-bg-white-90:focus,.hover-bg-white-90:hover{background-color:hsla(0,0%,100%,.9)}.hover-bg-white-80:focus,.hover-bg-white-80:hover{background-color:hsla(0,0%,100%,.8)}.hover-bg-white-70:focus,.hover-bg-white-70:hover{background-color:hsla(0,0%,100%,.7)}.hover-bg-white-60:focus,.hover-bg-white-60:hover{background-color:hsla(0,0%,100%,.6)}.hover-bg-white-50:focus,.hover-bg-white-50:hover{background-color:hsla(0,0%,100%,.5)}.hover-bg-white-40:focus,.hover-bg-white-40:hover{background-color:hsla(0,0%,100%,.4)}.hover-bg-white-30:focus,.hover-bg-white-30:hover{background-color:hsla(0,0%,100%,.3)}.hover-bg-white-20:focus,.hover-bg-white-20:hover{background-color:hsla(0,0%,100%,.2)}.hover-bg-white-10:focus,.hover-bg-white-10:hover{background-color:hsla(0,0%,100%,.1)}.hover-dark-red:focus,.hover-dark-red:hover{color:#e7040f}.hover-red:focus,.hover-red:hover{color:#ff4136}.hover-light-red:focus,.hover-light-red:hover{color:#ff725c}.hover-orange:focus,.hover-orange:hover{color:#ff6300}.hover-gold:focus,.hover-gold:hover{color:#ffb700}.hover-yellow:focus,.hover-yellow:hover{color:gold}.hover-light-yellow:focus,.hover-light-yellow:hover{color:#fbf1a9}.hover-purple:focus,.hover-purple:hover{color:#5e2ca5}.hover-light-purple:focus,.hover-light-purple:hover{color:#a463f2}.hover-dark-pink:focus,.hover-dark-pink:hover{color:#d5008f}.hover-hot-pink:focus,.hover-hot-pink:hover{color:#ff41b4}.hover-pink:focus,.hover-pink:hover{color:#ff80cc}.hover-light-pink:focus,.hover-light-pink:hover{color:#ffa3d7}.hover-dark-green:focus,.hover-dark-green:hover{color:#137752}.hover-green:focus,.hover-green:hover{color:#19a974}.hover-light-green:focus,.hover-light-green:hover{color:#9eebcf}.hover-navy:focus,.hover-navy:hover{color:#001b44}.hover-dark-blue:focus,.hover-dark-blue:hover{color:#00449e}.hover-blue:focus,.hover-blue:hover{color:#357edd}.hover-light-blue:focus,.hover-light-blue:hover{color:#96ccff}.hover-lightest-blue:focus,.hover-lightest-blue:hover{color:#cdecff}.hover-washed-blue:focus,.hover-washed-blue:hover{color:#f6fffe}.hover-washed-green:focus,.hover-washed-green:hover{color:#e8fdf5}.hover-washed-yellow:focus,.hover-washed-yellow:hover{color:#fffceb}.hover-washed-red:focus,.hover-washed-red:hover{color:#ffdfdf}.hover-bg-dark-red:focus,.hover-bg-dark-red:hover{background-color:#e7040f}.hover-bg-red:focus,.hover-bg-red:hover{background-color:#ff4136}.hover-bg-light-red:focus,.hover-bg-light-red:hover{background-color:#ff725c}.hover-bg-orange:focus,.hover-bg-orange:hover{background-color:#ff6300}.hover-bg-gold:focus,.hover-bg-gold:hover{background-color:#ffb700}.hover-bg-yellow:focus,.hover-bg-yellow:hover{background-color:gold}.hover-bg-light-yellow:focus,.hover-bg-light-yellow:hover{background-color:#fbf1a9}.hover-bg-purple:focus,.hover-bg-purple:hover{background-color:#5e2ca5}.hover-bg-light-purple:focus,.hover-bg-light-purple:hover{background-color:#a463f2}.hover-bg-dark-pink:focus,.hover-bg-dark-pink:hover{background-color:#d5008f}.hover-bg-hot-pink:focus,.hover-bg-hot-pink:hover{background-color:#ff41b4}.hover-bg-pink:focus,.hover-bg-pink:hover{background-color:#ff80cc}.hover-bg-light-pink:focus,.hover-bg-light-pink:hover{background-color:#ffa3d7}.hover-bg-dark-green:focus,.hover-bg-dark-green:hover{background-color:#137752}.hover-bg-green:focus,.hover-bg-green:hover{background-color:#19a974}.hover-bg-light-green:focus,.hover-bg-light-green:hover{background-color:#9eebcf}.hover-bg-navy:focus,.hover-bg-navy:hover{background-color:#001b44}.hover-bg-dark-blue:focus,.hover-bg-dark-blue:hover{background-color:#00449e}.hover-bg-blue:focus,.hover-bg-blue:hover{background-color:#357edd}.hover-bg-light-blue:focus,.hover-bg-light-blue:hover{background-color:#96ccff}.hover-bg-lightest-blue:focus,.hover-bg-lightest-blue:hover{background-color:#cdecff}.hover-bg-washed-blue:focus,.hover-bg-washed-blue:hover{background-color:#f6fffe}.hover-bg-washed-green:focus,.hover-bg-washed-green:hover{background-color:#e8fdf5}.hover-bg-washed-yellow:focus,.hover-bg-washed-yellow:hover{background-color:#fffceb}.hover-bg-washed-red:focus,.hover-bg-washed-red:hover{background-color:#ffdfdf}.hover-bg-inherit:focus,.hover-bg-inherit:hover{background-color:inherit}.pa0{padding:0}.pa1{padding:.25rem}.pa2{padding:.5rem}.pa3{padding:1rem}.pa4{padding:2rem}.pa5{padding:4rem}.pa6{padding:8rem}.pa7{padding:16rem}.pl0{padding-left:0}.pl1{padding-left:.25rem}.pl2{padding-left:.5rem}.pl3{padding-left:1rem}.pl4{padding-left:2rem}.pl5{padding-left:4rem}.pl6{padding-left:8rem}.pl7{padding-left:16rem}.pr0{padding-right:0}.pr1{padding-right:.25rem}.pr2{padding-right:.5rem}.pr3{padding-right:1rem}.pr4{padding-right:2rem}.pr5{padding-right:4rem}.pr6{padding-right:8rem}.pr7{padding-right:16rem}.pb0{padding-bottom:0}.pb1{padding-bottom:.25rem}.pb2{padding-bottom:.5rem}.pb3{padding-bottom:1rem}.pb4{padding-bottom:2rem}.pb5{padding-bottom:4rem}.pb6{padding-bottom:8rem}.pb7{padding-bottom:16rem}.pt0{padding-top:0}.pt1{padding-top:.25rem}.pt2{padding-top:.5rem}.pt3{padding-top:1rem}.pt4{padding-top:2rem}.pt5{padding-top:4rem}.pt6{padding-top:8rem}.pt7{padding-top:16rem}.pv0{padding-top:0;padding-bottom:0}.pv1{padding-top:.25rem;padding-bottom:.25rem}.pv2{padding-top:.5rem;padding-bottom:.5rem}.pv3{padding-top:1rem;padding-bottom:1rem}.pv4{padding-top:2rem;padding-bottom:2rem}.pv5{padding-top:4rem;padding-bottom:4rem}.pv6{padding-top:8rem;padding-bottom:8rem}.pv7{padding-top:16rem;padding-bottom:16rem}.ph0{padding-left:0;padding-right:0}.ph1{padding-left:.25rem;padding-right:.25rem}.ph2{padding-left:.5rem;padding-right:.5rem}.ph3{padding-left:1rem;padding-right:1rem}.ph4{padding-left:2rem;padding-right:2rem}.ph5{padding-left:4rem;padding-right:4rem}.ph6{padding-left:8rem;padding-right:8rem}.ph7{padding-left:16rem;padding-right:16rem}.ma0{margin:0}.ma1{margin:.25rem}.ma2{margin:.5rem}.ma3{margin:1rem}.ma4{margin:2rem}.ma5{margin:4rem}.ma6{margin:8rem}.ma7{margin:16rem}.ml0{margin-left:0}.ml1{margin-left:.25rem}.ml2{margin-left:.5rem}.ml3{margin-left:1rem}.ml4{margin-left:2rem}.ml5{margin-left:4rem}.ml6{margin-left:8rem}.ml7{margin-left:16rem}.mr0{margin-right:0}.mr1{margin-right:.25rem}.mr2{margin-right:.5rem}.mr3{margin-right:1rem}.mr4{margin-right:2rem}.mr5{margin-right:4rem}.mr6{margin-right:8rem}.mr7{margin-right:16rem}.mb0{margin-bottom:0}.mb1{margin-bottom:.25rem}.mb2{margin-bottom:.5rem}.mb3{margin-bottom:1rem}.mb4{margin-bottom:2rem}.mb5{margin-bottom:4rem}.mb6{margin-bottom:8rem}.mb7{margin-bottom:16rem}.mt0{margin-top:0}.mt1{margin-top:.25rem}.mt2{margin-top:.5rem}.mt3{margin-top:1rem}.mt4{margin-top:2rem}.mt5{margin-top:4rem}.mt6{margin-top:8rem}.mt7{margin-top:16rem}.mv0{margin-top:0;margin-bottom:0}.mv1{margin-top:.25rem;margin-bottom:.25rem}.mv2{margin-top:.5rem;margin-bottom:.5rem}.mv3{margin-top:1rem;margin-bottom:1rem}.mv4{margin-top:2rem;margin-bottom:2rem}.mv5{margin-top:4rem;margin-bottom:4rem}.mv6{margin-top:8rem;margin-bottom:8rem}.mv7{margin-top:16rem;margin-bottom:16rem}.mh0{margin-left:0;margin-right:0}.mh1{margin-left:.25rem;margin-right:.25rem}.mh2{margin-left:.5rem;margin-right:.5rem}.mh3{margin-left:1rem;margin-right:1rem}.mh4{margin-left:2rem;margin-right:2rem}.mh5{margin-left:4rem;margin-right:4rem}.mh6{margin-left:8rem;margin-right:8rem}.mh7{margin-left:16rem;margin-right:16rem}.na1{margin:-.25rem}.na2{margin:-.5rem}.na3{margin:-1rem}.na4{margin:-2rem}.na5{margin:-4rem}.na6{margin:-8rem}.na7{margin:-16rem}.nl1{margin-left:-.25rem}.nl2{margin-left:-.5rem}.nl3{margin-left:-1rem}.nl4{margin-left:-2rem}.nl5{margin-left:-4rem}.nl6{margin-left:-8rem}.nl7{margin-left:-16rem}.nr1{margin-right:-.25rem}.nr2{margin-right:-.5rem}.nr3{margin-right:-1rem}.nr4{margin-right:-2rem}.nr5{margin-right:-4rem}.nr6{margin-right:-8rem}.nr7{margin-right:-16rem}.nb1{margin-bottom:-.25rem}.nb2{margin-bottom:-.5rem}.nb3{margin-bottom:-1rem}.nb4{margin-bottom:-2rem}.nb5{margin-bottom:-4rem}.nb6{margin-bottom:-8rem}.nb7{margin-bottom:-16rem}.nt1{margin-top:-.25rem}.nt2{margin-top:-.5rem}.nt3{margin-top:-1rem}.nt4{margin-top:-2rem}.nt5{margin-top:-4rem}.nt6{margin-top:-8rem}.nt7{margin-top:-16rem}.collapse{border-collapse:collapse;border-spacing:0}.striped--light-silver:nth-child(odd){background-color:#aaa}.striped--moon-gray:nth-child(odd){background-color:#ccc}.striped--light-gray:nth-child(odd){background-color:#eee}.striped--near-white:nth-child(odd){background-color:#f4f4f4}.stripe-light:nth-child(odd){background-color:hsla(0,0%,100%,.1)}.stripe-dark:nth-child(odd){background-color:rgba(0,0,0,.1)}.strike{text-decoration:line-through}.underline{text-decoration:underline}.no-underline{text-decoration:none}.tl{text-align:left}.tr{text-align:right}.tc{text-align:center}.tj{text-align:justify}.ttc{text-transform:capitalize}.ttl{text-transform:lowercase}.ttu{text-transform:uppercase}.ttn{text-transform:none}.f-6,.f-headline{font-size:6rem}.f-5,.f-subheadline{font-size:5rem}.f1{font-size:3rem}.f2{font-size:2.25rem}.f3{font-size:1.5rem}.f4{font-size:1.25rem}.f5{font-size:1rem}.f6{font-size:.875rem}.f7{font-size:.75rem}.measure{max-width:30em}.measure-wide{max-width:34em}.measure-narrow{max-width:20em}.indent{text-indent:1em;margin-top:0;margin-bottom:0}.small-caps{font-variant:small-caps}.truncate{white-space:nowrap;overflow:hidden;text-overflow:ellipsis}.overflow-container{overflow-y:scroll}.center{margin-left:auto}.center,.mr-auto{margin-right:auto}.ml-auto{margin-left:auto}.clip{position:fixed!important;_position:absolute!important;clip:rect(1px 1px 1px 1px);clip:rect(1px,1px,1px,1px)}.ws-normal{white-space:normal}.nowrap{white-space:nowrap}.pre{white-space:pre}.v-base{vertical-align:baseline}.v-mid{vertical-align:middle}.v-top{vertical-align:top}.v-btm{vertical-align:bottom}.dim{opacity:1}.dim,.dim:focus,.dim:hover{transition:opacity .15s ease-in}.dim:focus,.dim:hover{opacity:.5}.dim:active{opacity:.8;transition:opacity .15s ease-out}.glow,.glow:focus,.glow:hover{transition:opacity .15s ease-in}.glow:focus,.glow:hover{opacity:1}.hide-child .child{opacity:0;transition:opacity .15s ease-in}.hide-child:active .child,.hide-child:focus .child,.hide-child:hover .child{opacity:1;transition:opacity .15s ease-in}.underline-hover:focus,.underline-hover:hover{text-decoration:underline}.grow{-moz-osx-font-smoothing:grayscale;-webkit-backface-visibility:hidden;backface-visibility:hidden;transform:translateZ(0);transition:transform .25s ease-out}.grow:focus,.grow:hover{transform:scale(1.05)}.grow:active{transform:scale(.9)}.grow-large{-moz-osx-font-smoothing:grayscale;-webkit-backface-visibility:hidden;backface-visibility:hidden;transform:translateZ(0);transition:transform .25s ease-in-out}.grow-large:focus,.grow-large:hover{transform:scale(1.2)}.grow-large:active{transform:scale(.95)}.pointer:hover,.shadow-hover{cursor:pointer}.shadow-hover{position:relative;transition:all .5s cubic-bezier(.165,.84,.44,1)}.shadow-hover:after{content:"";box-shadow:0 0 16px 2px rgba(0,0,0,.2);border-radius:inherit;opacity:0;position:absolute;top:0;left:0;width:100%;height:100%;z-index:-1;transition:opacity .5s cubic-bezier(.165,.84,.44,1)}.shadow-hover:focus:after,.shadow-hover:hover:after{opacity:1}.bg-animate,.bg-animate:focus,.bg-animate:hover{transition:background-color .15s ease-in-out}.z-0{z-index:0}.z-1{z-index:1}.z-2{z-index:2}.z-3{z-index:3}.z-4{z-index:4}.z-5{z-index:5}.z-999{z-index:999}.z-9999{z-index:9999}.z-max{z-index:2147483647}.z-inherit{z-index:inherit}.z-initial{z-index:auto}.z-unset{z-index:unset}.nested-copy-line-height ol,.nested-copy-line-height p,.nested-copy-line-height ul{line-height:1.5}.nested-headline-line-height h1,.nested-headline-line-height h2,.nested-headline-line-height h3,.nested-headline-line-height h4,.nested-headline-line-height h5,.nested-headline-line-height h6{line-height:1.25}.nested-list-reset ol,.nested-list-reset ul{padding-left:0;margin-left:0;list-style-type:none}.nested-copy-indent p+p{text-indent:1em;margin-top:0;margin-bottom:0}.nested-copy-separator p+p{margin-top:1.5em}.nested-img img{width:100%;max-width:100%;display:block}.nested-links a{color:#357edd;transition:color .15s ease-in}.nested-links a:focus,.nested-links a:hover{color:#96ccff;transition:color .15s ease-in}.debug *{outline:1px solid gold}.debug-white *{outline:1px solid #fff}.debug-black *{outline:1px solid #000}.debug-grid{background:transparent url(data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAICAYAAADED76LAAAAFElEQVR4AWPAC97/9x0eCsAEPgwAVLshdpENIxcAAAAASUVORK5CYII=) repeat 0 0}.debug-grid-16{background:transparent url(data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAMklEQVR4AWOgCLz/b0epAa6UGuBOqQHOQHLUgFEDnAbcBZ4UGwDOkiCnkIhdgNgNxAYAiYlD+8sEuo8AAAAASUVORK5CYII=) repeat 0 0}.debug-grid-8-solid{background:#fff url(data:image/gif;base64,R0lGODdhCAAIAPEAAADw/wDx/////wAAACwAAAAACAAIAAACDZQvgaeb/lxbAIKA8y0AOw==) repeat 0 0}.debug-grid-16-solid{background:#fff url(data:image/gif;base64,R0lGODdhEAAQAPEAAADw/wDx/xXy/////ywAAAAAEAAQAAACIZyPKckYDQFsb6ZqD85jZ2+BkwiRFKehhqQCQgDHcgwEBQA7) repeat 0 0}@media screen and (min-width:30em){.aspect-ratio-ns{height:0;position:relative}.aspect-ratio--16x9-ns{padding-bottom:56.25%}.aspect-ratio--9x16-ns{padding-bottom:177.77%}.aspect-ratio--4x3-ns{padding-bottom:75%}.aspect-ratio--3x4-ns{padding-bottom:133.33%}.aspect-ratio--6x4-ns{padding-bottom:66.6%}.aspect-ratio--4x6-ns{padding-bottom:150%}.aspect-ratio--8x5-ns{padding-bottom:62.5%}.aspect-ratio--5x8-ns{padding-bottom:160%}.aspect-ratio--7x5-ns{padding-bottom:71.42%}.aspect-ratio--5x7-ns{padding-bottom:140%}.aspect-ratio--1x1-ns{padding-bottom:100%}.aspect-ratio--object-ns{position:absolute;top:0;right:0;bottom:0;left:0;width:100%;height:100%;z-index:100}.cover-ns{background-size:cover!important}.contain-ns{background-size:contain!important}.bg-center-ns{background-position:50%}.bg-center-ns,.bg-top-ns{background-repeat:no-repeat}.bg-top-ns{background-position:top}.bg-right-ns{background-position:100%}.bg-bottom-ns,.bg-right-ns{background-repeat:no-repeat}.bg-bottom-ns{background-position:bottom}.bg-left-ns{background-repeat:no-repeat;background-position:0}.outline-ns{outline:1px solid}.outline-transparent-ns{outline:1px solid transparent}.outline-0-ns{outline:0}.ba-ns{border-style:solid;border-width:1px}.bt-ns{border-top-style:solid;border-top-width:1px}.br-ns{border-right-style:solid;border-right-width:1px}.bb-ns{border-bottom-style:solid;border-bottom-width:1px}.bl-ns{border-left-style:solid;border-left-width:1px}.bn-ns{border-style:none;border-width:0}.br0-ns{border-radius:0}.br1-ns{border-radius:.125rem}.br2-ns{border-radius:.25rem}.br3-ns{border-radius:.5rem}.br4-ns{border-radius:1rem}.br-100-ns{border-radius:100%}.br-pill-ns{border-radius:9999px}.br--bottom-ns{border-top-left-radius:0;border-top-right-radius:0}.br--top-ns{border-bottom-right-radius:0}.br--right-ns,.br--top-ns{border-bottom-left-radius:0}.br--right-ns{border-top-left-radius:0}.br--left-ns{border-top-right-radius:0;border-bottom-right-radius:0}.b--dotted-ns{border-style:dotted}.b--dashed-ns{border-style:dashed}.b--solid-ns{border-style:solid}.b--none-ns{border-style:none}.bw0-ns{border-width:0}.bw1-ns{border-width:.125rem}.bw2-ns{border-width:.25rem}.bw3-ns{border-width:.5rem}.bw4-ns{border-width:1rem}.bw5-ns{border-width:2rem}.bt-0-ns{border-top-width:0}.br-0-ns{border-right-width:0}.bb-0-ns{border-bottom-width:0}.bl-0-ns{border-left-width:0}.shadow-1-ns{box-shadow:0 0 4px 2px rgba(0,0,0,.2)}.shadow-2-ns{box-shadow:0 0 8px 2px rgba(0,0,0,.2)}.shadow-3-ns{box-shadow:2px 2px 4px 2px rgba(0,0,0,.2)}.shadow-4-ns{box-shadow:2px 2px 8px 0 rgba(0,0,0,.2)}.shadow-5-ns{box-shadow:4px 4px 8px 0 rgba(0,0,0,.2)}.top-0-ns{top:0}.left-0-ns{left:0}.right-0-ns{right:0}.bottom-0-ns{bottom:0}.top-1-ns{top:1rem}.left-1-ns{left:1rem}.right-1-ns{right:1rem}.bottom-1-ns{bottom:1rem}.top-2-ns{top:2rem}.left-2-ns{left:2rem}.right-2-ns{right:2rem}.bottom-2-ns{bottom:2rem}.top--1-ns{top:-1rem}.right--1-ns{right:-1rem}.bottom--1-ns{bottom:-1rem}.left--1-ns{left:-1rem}.top--2-ns{top:-2rem}.right--2-ns{right:-2rem}.bottom--2-ns{bottom:-2rem}.left--2-ns{left:-2rem}.absolute--fill-ns{top:0;right:0;bottom:0;left:0}.cl-ns{clear:left}.cr-ns{clear:right}.cb-ns{clear:both}.cn-ns{clear:none}.dn-ns{display:none}.di-ns{display:inline}.db-ns{display:block}.dib-ns{display:inline-block}.dit-ns{display:inline-table}.dt-ns{display:table}.dtc-ns{display:table-cell}.dt-row-ns{display:table-row}.dt-row-group-ns{display:table-row-group}.dt-column-ns{display:table-column}.dt-column-group-ns{display:table-column-group}.dt--fixed-ns{table-layout:fixed;width:100%}.flex-ns{display:flex}.inline-flex-ns{display:inline-flex}.flex-auto-ns{flex:1 1 auto;min-width:0;min-height:0}.flex-none-ns{flex:none}.flex-column-ns{flex-direction:column}.flex-row-ns{flex-direction:row}.flex-wrap-ns{flex-wrap:wrap}.flex-nowrap-ns{flex-wrap:nowrap}.flex-wrap-reverse-ns{flex-wrap:wrap-reverse}.flex-column-reverse-ns{flex-direction:column-reverse}.flex-row-reverse-ns{flex-direction:row-reverse}.items-start-ns{align-items:flex-start}.items-end-ns{align-items:flex-end}.items-center-ns{align-items:center}.items-baseline-ns{align-items:baseline}.items-stretch-ns{align-items:stretch}.self-start-ns{align-self:flex-start}.self-end-ns{align-self:flex-end}.self-center-ns{align-self:center}.self-baseline-ns{align-self:baseline}.self-stretch-ns{align-self:stretch}.justify-start-ns{justify-content:flex-start}.justify-end-ns{justify-content:flex-end}.justify-center-ns{justify-content:center}.justify-between-ns{justify-content:space-between}.justify-around-ns{justify-content:space-around}.content-start-ns{align-content:flex-start}.content-end-ns{align-content:flex-end}.content-center-ns{align-content:center}.content-between-ns{align-content:space-between}.content-around-ns{align-content:space-around}.content-stretch-ns{align-content:stretch}.order-0-ns{order:0}.order-1-ns{order:1}.order-2-ns{order:2}.order-3-ns{order:3}.order-4-ns{order:4}.order-5-ns{order:5}.order-6-ns{order:6}.order-7-ns{order:7}.order-8-ns{order:8}.order-last-ns{order:99999}.flex-grow-0-ns{flex-grow:0}.flex-grow-1-ns{flex-grow:1}.flex-shrink-0-ns{flex-shrink:0}.flex-shrink-1-ns{flex-shrink:1}.fl-ns{float:left}.fl-ns,.fr-ns{_display:inline}.fr-ns{float:right}.fn-ns{float:none}.i-ns{font-style:italic}.fs-normal-ns{font-style:normal}.normal-ns{font-weight:400}.b-ns{font-weight:700}.fw1-ns{font-weight:100}.fw2-ns{font-weight:200}.fw3-ns{font-weight:300}.fw4-ns{font-weight:400}.fw5-ns{font-weight:500}.fw6-ns{font-weight:600}.fw7-ns{font-weight:700}.fw8-ns{font-weight:800}.fw9-ns{font-weight:900}.h1-ns{height:1rem}.h2-ns{height:2rem}.h3-ns{height:4rem}.h4-ns{height:8rem}.h5-ns{height:16rem}.h-25-ns{height:25%}.h-50-ns{height:50%}.h-75-ns{height:75%}.h-100-ns{height:100%}.min-h-100-ns{min-height:100%}.vh-25-ns{height:25vh}.vh-50-ns{height:50vh}.vh-75-ns{height:75vh}.vh-100-ns{height:100vh}.min-vh-100-ns{min-height:100vh}.h-auto-ns{height:auto}.h-inherit-ns{height:inherit}.tracked-ns{letter-spacing:.1em}.tracked-tight-ns{letter-spacing:-.05em}.tracked-mega-ns{letter-spacing:.25em}.lh-solid-ns{line-height:1}.lh-title-ns{line-height:1.25}.lh-copy-ns{line-height:1.5}.mw-100-ns{max-width:100%}.mw1-ns{max-width:1rem}.mw2-ns{max-width:2rem}.mw3-ns{max-width:4rem}.mw4-ns{max-width:8rem}.mw5-ns{max-width:16rem}.mw6-ns{max-width:32rem}.mw7-ns{max-width:48rem}.mw8-ns{max-width:64rem}.mw9-ns{max-width:96rem}.mw-none-ns{max-width:none}.w1-ns{width:1rem}.w2-ns{width:2rem}.w3-ns{width:4rem}.w4-ns{width:8rem}.w5-ns{width:16rem}.w-10-ns{width:10%}.w-20-ns{width:20%}.w-25-ns{width:25%}.w-30-ns{width:30%}.w-33-ns{width:33%}.w-34-ns{width:34%}.w-40-ns{width:40%}.w-50-ns{width:50%}.w-60-ns{width:60%}.w-70-ns{width:70%}.w-75-ns{width:75%}.w-80-ns{width:80%}.w-90-ns{width:90%}.w-100-ns{width:100%}.w-third-ns{width:33.33333%}.w-two-thirds-ns{width:66.66667%}.w-auto-ns{width:auto}.overflow-visible-ns{overflow:visible}.overflow-hidden-ns{overflow:hidden}.overflow-scroll-ns{overflow:scroll}.overflow-auto-ns{overflow:auto}.overflow-x-visible-ns{overflow-x:visible}.overflow-x-hidden-ns{overflow-x:hidden}.overflow-x-scroll-ns{overflow-x:scroll}.overflow-x-auto-ns{overflow-x:auto}.overflow-y-visible-ns{overflow-y:visible}.overflow-y-hidden-ns{overflow-y:hidden}.overflow-y-scroll-ns{overflow-y:scroll}.overflow-y-auto-ns{overflow-y:auto}.static-ns{position:static}.relative-ns{position:relative}.absolute-ns{position:absolute}.fixed-ns{position:fixed}.rotate-45-ns{transform:rotate(45deg)}.rotate-90-ns{transform:rotate(90deg)}.rotate-135-ns{transform:rotate(135deg)}.rotate-180-ns{transform:rotate(180deg)}.rotate-225-ns{transform:rotate(225deg)}.rotate-270-ns{transform:rotate(270deg)}.rotate-315-ns{transform:rotate(315deg)}.pa0-ns{padding:0}.pa1-ns{padding:.25rem}.pa2-ns{padding:.5rem}.pa3-ns{padding:1rem}.pa4-ns{padding:2rem}.pa5-ns{padding:4rem}.pa6-ns{padding:8rem}.pa7-ns{padding:16rem}.pl0-ns{padding-left:0}.pl1-ns{padding-left:.25rem}.pl2-ns{padding-left:.5rem}.pl3-ns{padding-left:1rem}.pl4-ns{padding-left:2rem}.pl5-ns{padding-left:4rem}.pl6-ns{padding-left:8rem}.pl7-ns{padding-left:16rem}.pr0-ns{padding-right:0}.pr1-ns{padding-right:.25rem}.pr2-ns{padding-right:.5rem}.pr3-ns{padding-right:1rem}.pr4-ns{padding-right:2rem}.pr5-ns{padding-right:4rem}.pr6-ns{padding-right:8rem}.pr7-ns{padding-right:16rem}.pb0-ns{padding-bottom:0}.pb1-ns{padding-bottom:.25rem}.pb2-ns{padding-bottom:.5rem}.pb3-ns{padding-bottom:1rem}.pb4-ns{padding-bottom:2rem}.pb5-ns{padding-bottom:4rem}.pb6-ns{padding-bottom:8rem}.pb7-ns{padding-bottom:16rem}.pt0-ns{padding-top:0}.pt1-ns{padding-top:.25rem}.pt2-ns{padding-top:.5rem}.pt3-ns{padding-top:1rem}.pt4-ns{padding-top:2rem}.pt5-ns{padding-top:4rem}.pt6-ns{padding-top:8rem}.pt7-ns{padding-top:16rem}.pv0-ns{padding-top:0;padding-bottom:0}.pv1-ns{padding-top:.25rem;padding-bottom:.25rem}.pv2-ns{padding-top:.5rem;padding-bottom:.5rem}.pv3-ns{padding-top:1rem;padding-bottom:1rem}.pv4-ns{padding-top:2rem;padding-bottom:2rem}.pv5-ns{padding-top:4rem;padding-bottom:4rem}.pv6-ns{padding-top:8rem;padding-bottom:8rem}.pv7-ns{padding-top:16rem;padding-bottom:16rem}.ph0-ns{padding-left:0;padding-right:0}.ph1-ns{padding-left:.25rem;padding-right:.25rem}.ph2-ns{padding-left:.5rem;padding-right:.5rem}.ph3-ns{padding-left:1rem;padding-right:1rem}.ph4-ns{padding-left:2rem;padding-right:2rem}.ph5-ns{padding-left:4rem;padding-right:4rem}.ph6-ns{padding-left:8rem;padding-right:8rem}.ph7-ns{padding-left:16rem;padding-right:16rem}.ma0-ns{margin:0}.ma1-ns{margin:.25rem}.ma2-ns{margin:.5rem}.ma3-ns{margin:1rem}.ma4-ns{margin:2rem}.ma5-ns{margin:4rem}.ma6-ns{margin:8rem}.ma7-ns{margin:16rem}.ml0-ns{margin-left:0}.ml1-ns{margin-left:.25rem}.ml2-ns{margin-left:.5rem}.ml3-ns{margin-left:1rem}.ml4-ns{margin-left:2rem}.ml5-ns{margin-left:4rem}.ml6-ns{margin-left:8rem}.ml7-ns{margin-left:16rem}.mr0-ns{margin-right:0}.mr1-ns{margin-right:.25rem}.mr2-ns{margin-right:.5rem}.mr3-ns{margin-right:1rem}.mr4-ns{margin-right:2rem}.mr5-ns{margin-right:4rem}.mr6-ns{margin-right:8rem}.mr7-ns{margin-right:16rem}.mb0-ns{margin-bottom:0}.mb1-ns{margin-bottom:.25rem}.mb2-ns{margin-bottom:.5rem}.mb3-ns{margin-bottom:1rem}.mb4-ns{margin-bottom:2rem}.mb5-ns{margin-bottom:4rem}.mb6-ns{margin-bottom:8rem}.mb7-ns{margin-bottom:16rem}.mt0-ns{margin-top:0}.mt1-ns{margin-top:.25rem}.mt2-ns{margin-top:.5rem}.mt3-ns{margin-top:1rem}.mt4-ns{margin-top:2rem}.mt5-ns{margin-top:4rem}.mt6-ns{margin-top:8rem}.mt7-ns{margin-top:16rem}.mv0-ns{margin-top:0;margin-bottom:0}.mv1-ns{margin-top:.25rem;margin-bottom:.25rem}.mv2-ns{margin-top:.5rem;margin-bottom:.5rem}.mv3-ns{margin-top:1rem;margin-bottom:1rem}.mv4-ns{margin-top:2rem;margin-bottom:2rem}.mv5-ns{margin-top:4rem;margin-bottom:4rem}.mv6-ns{margin-top:8rem;margin-bottom:8rem}.mv7-ns{margin-top:16rem;margin-bottom:16rem}.mh0-ns{margin-left:0;margin-right:0}.mh1-ns{margin-left:.25rem;margin-right:.25rem}.mh2-ns{margin-left:.5rem;margin-right:.5rem}.mh3-ns{margin-left:1rem;margin-right:1rem}.mh4-ns{margin-left:2rem;margin-right:2rem}.mh5-ns{margin-left:4rem;margin-right:4rem}.mh6-ns{margin-left:8rem;margin-right:8rem}.mh7-ns{margin-left:16rem;margin-right:16rem}.na1-ns{margin:-.25rem}.na2-ns{margin:-.5rem}.na3-ns{margin:-1rem}.na4-ns{margin:-2rem}.na5-ns{margin:-4rem}.na6-ns{margin:-8rem}.na7-ns{margin:-16rem}.nl1-ns{margin-left:-.25rem}.nl2-ns{margin-left:-.5rem}.nl3-ns{margin-left:-1rem}.nl4-ns{margin-left:-2rem}.nl5-ns{margin-left:-4rem}.nl6-ns{margin-left:-8rem}.nl7-ns{margin-left:-16rem}.nr1-ns{margin-right:-.25rem}.nr2-ns{margin-right:-.5rem}.nr3-ns{margin-right:-1rem}.nr4-ns{margin-right:-2rem}.nr5-ns{margin-right:-4rem}.nr6-ns{margin-right:-8rem}.nr7-ns{margin-right:-16rem}.nb1-ns{margin-bottom:-.25rem}.nb2-ns{margin-bottom:-.5rem}.nb3-ns{margin-bottom:-1rem}.nb4-ns{margin-bottom:-2rem}.nb5-ns{margin-bottom:-4rem}.nb6-ns{margin-bottom:-8rem}.nb7-ns{margin-bottom:-16rem}.nt1-ns{margin-top:-.25rem}.nt2-ns{margin-top:-.5rem}.nt3-ns{margin-top:-1rem}.nt4-ns{margin-top:-2rem}.nt5-ns{margin-top:-4rem}.nt6-ns{margin-top:-8rem}.nt7-ns{margin-top:-16rem}.strike-ns{text-decoration:line-through}.underline-ns{text-decoration:underline}.no-underline-ns{text-decoration:none}.tl-ns{text-align:left}.tr-ns{text-align:right}.tc-ns{text-align:center}.tj-ns{text-align:justify}.ttc-ns{text-transform:capitalize}.ttl-ns{text-transform:lowercase}.ttu-ns{text-transform:uppercase}.ttn-ns{text-transform:none}.f-6-ns,.f-headline-ns{font-size:6rem}.f-5-ns,.f-subheadline-ns{font-size:5rem}.f1-ns{font-size:3rem}.f2-ns{font-size:2.25rem}.f3-ns{font-size:1.5rem}.f4-ns{font-size:1.25rem}.f5-ns{font-size:1rem}.f6-ns{font-size:.875rem}.f7-ns{font-size:.75rem}.measure-ns{max-width:30em}.measure-wide-ns{max-width:34em}.measure-narrow-ns{max-width:20em}.indent-ns{text-indent:1em;margin-top:0;margin-bottom:0}.small-caps-ns{font-variant:small-caps}.truncate-ns{white-space:nowrap;overflow:hidden;text-overflow:ellipsis}.center-ns{margin-left:auto}.center-ns,.mr-auto-ns{margin-right:auto}.ml-auto-ns{margin-left:auto}.clip-ns{position:fixed!important;_position:absolute!important;clip:rect(1px 1px 1px 1px);clip:rect(1px,1px,1px,1px)}.ws-normal-ns{white-space:normal}.nowrap-ns{white-space:nowrap}.pre-ns{white-space:pre}.v-base-ns{vertical-align:baseline}.v-mid-ns{vertical-align:middle}.v-top-ns{vertical-align:top}.v-btm-ns{vertical-align:bottom}}@media screen and (min-width:30em) and (max-width:60em){.aspect-ratio-m{height:0;position:relative}.aspect-ratio--16x9-m{padding-bottom:56.25%}.aspect-ratio--9x16-m{padding-bottom:177.77%}.aspect-ratio--4x3-m{padding-bottom:75%}.aspect-ratio--3x4-m{padding-bottom:133.33%}.aspect-ratio--6x4-m{padding-bottom:66.6%}.aspect-ratio--4x6-m{padding-bottom:150%}.aspect-ratio--8x5-m{padding-bottom:62.5%}.aspect-ratio--5x8-m{padding-bottom:160%}.aspect-ratio--7x5-m{padding-bottom:71.42%}.aspect-ratio--5x7-m{padding-bottom:140%}.aspect-ratio--1x1-m{padding-bottom:100%}.aspect-ratio--object-m{position:absolute;top:0;right:0;bottom:0;left:0;width:100%;height:100%;z-index:100}.cover-m{background-size:cover!important}.contain-m{background-size:contain!important}.bg-center-m{background-position:50%}.bg-center-m,.bg-top-m{background-repeat:no-repeat}.bg-top-m{background-position:top}.bg-right-m{background-position:100%}.bg-bottom-m,.bg-right-m{background-repeat:no-repeat}.bg-bottom-m{background-position:bottom}.bg-left-m{background-repeat:no-repeat;background-position:0}.outline-m{outline:1px solid}.outline-transparent-m{outline:1px solid transparent}.outline-0-m{outline:0}.ba-m{border-style:solid;border-width:1px}.bt-m{border-top-style:solid;border-top-width:1px}.br-m{border-right-style:solid;border-right-width:1px}.bb-m{border-bottom-style:solid;border-bottom-width:1px}.bl-m{border-left-style:solid;border-left-width:1px}.bn-m{border-style:none;border-width:0}.br0-m{border-radius:0}.br1-m{border-radius:.125rem}.br2-m{border-radius:.25rem}.br3-m{border-radius:.5rem}.br4-m{border-radius:1rem}.br-100-m{border-radius:100%}.br-pill-m{border-radius:9999px}.br--bottom-m{border-top-left-radius:0;border-top-right-radius:0}.br--top-m{border-bottom-right-radius:0}.br--right-m,.br--top-m{border-bottom-left-radius:0}.br--right-m{border-top-left-radius:0}.br--left-m{border-top-right-radius:0;border-bottom-right-radius:0}.b--dotted-m{border-style:dotted}.b--dashed-m{border-style:dashed}.b--solid-m{border-style:solid}.b--none-m{border-style:none}.bw0-m{border-width:0}.bw1-m{border-width:.125rem}.bw2-m{border-width:.25rem}.bw3-m{border-width:.5rem}.bw4-m{border-width:1rem}.bw5-m{border-width:2rem}.bt-0-m{border-top-width:0}.br-0-m{border-right-width:0}.bb-0-m{border-bottom-width:0}.bl-0-m{border-left-width:0}.shadow-1-m{box-shadow:0 0 4px 2px rgba(0,0,0,.2)}.shadow-2-m{box-shadow:0 0 8px 2px rgba(0,0,0,.2)}.shadow-3-m{box-shadow:2px 2px 4px 2px rgba(0,0,0,.2)}.shadow-4-m{box-shadow:2px 2px 8px 0 rgba(0,0,0,.2)}.shadow-5-m{box-shadow:4px 4px 8px 0 rgba(0,0,0,.2)}.top-0-m{top:0}.left-0-m{left:0}.right-0-m{right:0}.bottom-0-m{bottom:0}.top-1-m{top:1rem}.left-1-m{left:1rem}.right-1-m{right:1rem}.bottom-1-m{bottom:1rem}.top-2-m{top:2rem}.left-2-m{left:2rem}.right-2-m{right:2rem}.bottom-2-m{bottom:2rem}.top--1-m{top:-1rem}.right--1-m{right:-1rem}.bottom--1-m{bottom:-1rem}.left--1-m{left:-1rem}.top--2-m{top:-2rem}.right--2-m{right:-2rem}.bottom--2-m{bottom:-2rem}.left--2-m{left:-2rem}.absolute--fill-m{top:0;right:0;bottom:0;left:0}.cl-m{clear:left}.cr-m{clear:right}.cb-m{clear:both}.cn-m{clear:none}.dn-m{display:none}.di-m{display:inline}.db-m{display:block}.dib-m{display:inline-block}.dit-m{display:inline-table}.dt-m{display:table}.dtc-m{display:table-cell}.dt-row-m{display:table-row}.dt-row-group-m{display:table-row-group}.dt-column-m{display:table-column}.dt-column-group-m{display:table-column-group}.dt--fixed-m{table-layout:fixed;width:100%}.flex-m{display:flex}.inline-flex-m{display:inline-flex}.flex-auto-m{flex:1 1 auto;min-width:0;min-height:0}.flex-none-m{flex:none}.flex-column-m{flex-direction:column}.flex-row-m{flex-direction:row}.flex-wrap-m{flex-wrap:wrap}.flex-nowrap-m{flex-wrap:nowrap}.flex-wrap-reverse-m{flex-wrap:wrap-reverse}.flex-column-reverse-m{flex-direction:column-reverse}.flex-row-reverse-m{flex-direction:row-reverse}.items-start-m{align-items:flex-start}.items-end-m{align-items:flex-end}.items-center-m{align-items:center}.items-baseline-m{align-items:baseline}.items-stretch-m{align-items:stretch}.self-start-m{align-self:flex-start}.self-end-m{align-self:flex-end}.self-center-m{align-self:center}.self-baseline-m{align-self:baseline}.self-stretch-m{align-self:stretch}.justify-start-m{justify-content:flex-start}.justify-end-m{justify-content:flex-end}.justify-center-m{justify-content:center}.justify-between-m{justify-content:space-between}.justify-around-m{justify-content:space-around}.content-start-m{align-content:flex-start}.content-end-m{align-content:flex-end}.content-center-m{align-content:center}.content-between-m{align-content:space-between}.content-around-m{align-content:space-around}.content-stretch-m{align-content:stretch}.order-0-m{order:0}.order-1-m{order:1}.order-2-m{order:2}.order-3-m{order:3}.order-4-m{order:4}.order-5-m{order:5}.order-6-m{order:6}.order-7-m{order:7}.order-8-m{order:8}.order-last-m{order:99999}.flex-grow-0-m{flex-grow:0}.flex-grow-1-m{flex-grow:1}.flex-shrink-0-m{flex-shrink:0}.flex-shrink-1-m{flex-shrink:1}.fl-m{float:left}.fl-m,.fr-m{_display:inline}.fr-m{float:right}.fn-m{float:none}.i-m{font-style:italic}.fs-normal-m{font-style:normal}.normal-m{font-weight:400}.b-m{font-weight:700}.fw1-m{font-weight:100}.fw2-m{font-weight:200}.fw3-m{font-weight:300}.fw4-m{font-weight:400}.fw5-m{font-weight:500}.fw6-m{font-weight:600}.fw7-m{font-weight:700}.fw8-m{font-weight:800}.fw9-m{font-weight:900}.h1-m{height:1rem}.h2-m{height:2rem}.h3-m{height:4rem}.h4-m{height:8rem}.h5-m{height:16rem}.h-25-m{height:25%}.h-50-m{height:50%}.h-75-m{height:75%}.h-100-m{height:100%}.min-h-100-m{min-height:100%}.vh-25-m{height:25vh}.vh-50-m{height:50vh}.vh-75-m{height:75vh}.vh-100-m{height:100vh}.min-vh-100-m{min-height:100vh}.h-auto-m{height:auto}.h-inherit-m{height:inherit}.tracked-m{letter-spacing:.1em}.tracked-tight-m{letter-spacing:-.05em}.tracked-mega-m{letter-spacing:.25em}.lh-solid-m{line-height:1}.lh-title-m{line-height:1.25}.lh-copy-m{line-height:1.5}.mw-100-m{max-width:100%}.mw1-m{max-width:1rem}.mw2-m{max-width:2rem}.mw3-m{max-width:4rem}.mw4-m{max-width:8rem}.mw5-m{max-width:16rem}.mw6-m{max-width:32rem}.mw7-m{max-width:48rem}.mw8-m{max-width:64rem}.mw9-m{max-width:96rem}.mw-none-m{max-width:none}.w1-m{width:1rem}.w2-m{width:2rem}.w3-m{width:4rem}.w4-m{width:8rem}.w5-m{width:16rem}.w-10-m{width:10%}.w-20-m{width:20%}.w-25-m{width:25%}.w-30-m{width:30%}.w-33-m{width:33%}.w-34-m{width:34%}.w-40-m{width:40%}.w-50-m{width:50%}.w-60-m{width:60%}.w-70-m{width:70%}.w-75-m{width:75%}.w-80-m{width:80%}.w-90-m{width:90%}.w-100-m{width:100%}.w-third-m{width:33.33333%}.w-two-thirds-m{width:66.66667%}.w-auto-m{width:auto}.overflow-visible-m{overflow:visible}.overflow-hidden-m{overflow:hidden}.overflow-scroll-m{overflow:scroll}.overflow-auto-m{overflow:auto}.overflow-x-visible-m{overflow-x:visible}.overflow-x-hidden-m{overflow-x:hidden}.overflow-x-scroll-m{overflow-x:scroll}.overflow-x-auto-m{overflow-x:auto}.overflow-y-visible-m{overflow-y:visible}.overflow-y-hidden-m{overflow-y:hidden}.overflow-y-scroll-m{overflow-y:scroll}.overflow-y-auto-m{overflow-y:auto}.static-m{position:static}.relative-m{position:relative}.absolute-m{position:absolute}.fixed-m{position:fixed}.rotate-45-m{transform:rotate(45deg)}.rotate-90-m{transform:rotate(90deg)}.rotate-135-m{transform:rotate(135deg)}.rotate-180-m{transform:rotate(180deg)}.rotate-225-m{transform:rotate(225deg)}.rotate-270-m{transform:rotate(270deg)}.rotate-315-m{transform:rotate(315deg)}.pa0-m{padding:0}.pa1-m{padding:.25rem}.pa2-m{padding:.5rem}.pa3-m{padding:1rem}.pa4-m{padding:2rem}.pa5-m{padding:4rem}.pa6-m{padding:8rem}.pa7-m{padding:16rem}.pl0-m{padding-left:0}.pl1-m{padding-left:.25rem}.pl2-m{padding-left:.5rem}.pl3-m{padding-left:1rem}.pl4-m{padding-left:2rem}.pl5-m{padding-left:4rem}.pl6-m{padding-left:8rem}.pl7-m{padding-left:16rem}.pr0-m{padding-right:0}.pr1-m{padding-right:.25rem}.pr2-m{padding-right:.5rem}.pr3-m{padding-right:1rem}.pr4-m{padding-right:2rem}.pr5-m{padding-right:4rem}.pr6-m{padding-right:8rem}.pr7-m{padding-right:16rem}.pb0-m{padding-bottom:0}.pb1-m{padding-bottom:.25rem}.pb2-m{padding-bottom:.5rem}.pb3-m{padding-bottom:1rem}.pb4-m{padding-bottom:2rem}.pb5-m{padding-bottom:4rem}.pb6-m{padding-bottom:8rem}.pb7-m{padding-bottom:16rem}.pt0-m{padding-top:0}.pt1-m{padding-top:.25rem}.pt2-m{padding-top:.5rem}.pt3-m{padding-top:1rem}.pt4-m{padding-top:2rem}.pt5-m{padding-top:4rem}.pt6-m{padding-top:8rem}.pt7-m{padding-top:16rem}.pv0-m{padding-top:0;padding-bottom:0}.pv1-m{padding-top:.25rem;padding-bottom:.25rem}.pv2-m{padding-top:.5rem;padding-bottom:.5rem}.pv3-m{padding-top:1rem;padding-bottom:1rem}.pv4-m{padding-top:2rem;padding-bottom:2rem}.pv5-m{padding-top:4rem;padding-bottom:4rem}.pv6-m{padding-top:8rem;padding-bottom:8rem}.pv7-m{padding-top:16rem;padding-bottom:16rem}.ph0-m{padding-left:0;padding-right:0}.ph1-m{padding-left:.25rem;padding-right:.25rem}.ph2-m{padding-left:.5rem;padding-right:.5rem}.ph3-m{padding-left:1rem;padding-right:1rem}.ph4-m{padding-left:2rem;padding-right:2rem}.ph5-m{padding-left:4rem;padding-right:4rem}.ph6-m{padding-left:8rem;padding-right:8rem}.ph7-m{padding-left:16rem;padding-right:16rem}.ma0-m{margin:0}.ma1-m{margin:.25rem}.ma2-m{margin:.5rem}.ma3-m{margin:1rem}.ma4-m{margin:2rem}.ma5-m{margin:4rem}.ma6-m{margin:8rem}.ma7-m{margin:16rem}.ml0-m{margin-left:0}.ml1-m{margin-left:.25rem}.ml2-m{margin-left:.5rem}.ml3-m{margin-left:1rem}.ml4-m{margin-left:2rem}.ml5-m{margin-left:4rem}.ml6-m{margin-left:8rem}.ml7-m{margin-left:16rem}.mr0-m{margin-right:0}.mr1-m{margin-right:.25rem}.mr2-m{margin-right:.5rem}.mr3-m{margin-right:1rem}.mr4-m{margin-right:2rem}.mr5-m{margin-right:4rem}.mr6-m{margin-right:8rem}.mr7-m{margin-right:16rem}.mb0-m{margin-bottom:0}.mb1-m{margin-bottom:.25rem}.mb2-m{margin-bottom:.5rem}.mb3-m{margin-bottom:1rem}.mb4-m{margin-bottom:2rem}.mb5-m{margin-bottom:4rem}.mb6-m{margin-bottom:8rem}.mb7-m{margin-bottom:16rem}.mt0-m{margin-top:0}.mt1-m{margin-top:.25rem}.mt2-m{margin-top:.5rem}.mt3-m{margin-top:1rem}.mt4-m{margin-top:2rem}.mt5-m{margin-top:4rem}.mt6-m{margin-top:8rem}.mt7-m{margin-top:16rem}.mv0-m{margin-top:0;margin-bottom:0}.mv1-m{margin-top:.25rem;margin-bottom:.25rem}.mv2-m{margin-top:.5rem;margin-bottom:.5rem}.mv3-m{margin-top:1rem;margin-bottom:1rem}.mv4-m{margin-top:2rem;margin-bottom:2rem}.mv5-m{margin-top:4rem;margin-bottom:4rem}.mv6-m{margin-top:8rem;margin-bottom:8rem}.mv7-m{margin-top:16rem;margin-bottom:16rem}.mh0-m{margin-left:0;margin-right:0}.mh1-m{margin-left:.25rem;margin-right:.25rem}.mh2-m{margin-left:.5rem;margin-right:.5rem}.mh3-m{margin-left:1rem;margin-right:1rem}.mh4-m{margin-left:2rem;margin-right:2rem}.mh5-m{margin-left:4rem;margin-right:4rem}.mh6-m{margin-left:8rem;margin-right:8rem}.mh7-m{margin-left:16rem;margin-right:16rem}.na1-m{margin:-.25rem}.na2-m{margin:-.5rem}.na3-m{margin:-1rem}.na4-m{margin:-2rem}.na5-m{margin:-4rem}.na6-m{margin:-8rem}.na7-m{margin:-16rem}.nl1-m{margin-left:-.25rem}.nl2-m{margin-left:-.5rem}.nl3-m{margin-left:-1rem}.nl4-m{margin-left:-2rem}.nl5-m{margin-left:-4rem}.nl6-m{margin-left:-8rem}.nl7-m{margin-left:-16rem}.nr1-m{margin-right:-.25rem}.nr2-m{margin-right:-.5rem}.nr3-m{margin-right:-1rem}.nr4-m{margin-right:-2rem}.nr5-m{margin-right:-4rem}.nr6-m{margin-right:-8rem}.nr7-m{margin-right:-16rem}.nb1-m{margin-bottom:-.25rem}.nb2-m{margin-bottom:-.5rem}.nb3-m{margin-bottom:-1rem}.nb4-m{margin-bottom:-2rem}.nb5-m{margin-bottom:-4rem}.nb6-m{margin-bottom:-8rem}.nb7-m{margin-bottom:-16rem}.nt1-m{margin-top:-.25rem}.nt2-m{margin-top:-.5rem}.nt3-m{margin-top:-1rem}.nt4-m{margin-top:-2rem}.nt5-m{margin-top:-4rem}.nt6-m{margin-top:-8rem}.nt7-m{margin-top:-16rem}.strike-m{text-decoration:line-through}.underline-m{text-decoration:underline}.no-underline-m{text-decoration:none}.tl-m{text-align:left}.tr-m{text-align:right}.tc-m{text-align:center}.tj-m{text-align:justify}.ttc-m{text-transform:capitalize}.ttl-m{text-transform:lowercase}.ttu-m{text-transform:uppercase}.ttn-m{text-transform:none}.f-6-m,.f-headline-m{font-size:6rem}.f-5-m,.f-subheadline-m{font-size:5rem}.f1-m{font-size:3rem}.f2-m{font-size:2.25rem}.f3-m{font-size:1.5rem}.f4-m{font-size:1.25rem}.f5-m{font-size:1rem}.f6-m{font-size:.875rem}.f7-m{font-size:.75rem}.measure-m{max-width:30em}.measure-wide-m{max-width:34em}.measure-narrow-m{max-width:20em}.indent-m{text-indent:1em;margin-top:0;margin-bottom:0}.small-caps-m{font-variant:small-caps}.truncate-m{white-space:nowrap;overflow:hidden;text-overflow:ellipsis}.center-m{margin-left:auto}.center-m,.mr-auto-m{margin-right:auto}.ml-auto-m{margin-left:auto}.clip-m{position:fixed!important;_position:absolute!important;clip:rect(1px 1px 1px 1px);clip:rect(1px,1px,1px,1px)}.ws-normal-m{white-space:normal}.nowrap-m{white-space:nowrap}.pre-m{white-space:pre}.v-base-m{vertical-align:baseline}.v-mid-m{vertical-align:middle}.v-top-m{vertical-align:top}.v-btm-m{vertical-align:bottom}}@media screen and (min-width:60em){.aspect-ratio-l{height:0;position:relative}.aspect-ratio--16x9-l{padding-bottom:56.25%}.aspect-ratio--9x16-l{padding-bottom:177.77%}.aspect-ratio--4x3-l{padding-bottom:75%}.aspect-ratio--3x4-l{padding-bottom:133.33%}.aspect-ratio--6x4-l{padding-bottom:66.6%}.aspect-ratio--4x6-l{padding-bottom:150%}.aspect-ratio--8x5-l{padding-bottom:62.5%}.aspect-ratio--5x8-l{padding-bottom:160%}.aspect-ratio--7x5-l{padding-bottom:71.42%}.aspect-ratio--5x7-l{padding-bottom:140%}.aspect-ratio--1x1-l{padding-bottom:100%}.aspect-ratio--object-l{position:absolute;top:0;right:0;bottom:0;left:0;width:100%;height:100%;z-index:100}.cover-l{background-size:cover!important}.contain-l{background-size:contain!important}.bg-center-l{background-position:50%}.bg-center-l,.bg-top-l{background-repeat:no-repeat}.bg-top-l{background-position:top}.bg-right-l{background-position:100%}.bg-bottom-l,.bg-right-l{background-repeat:no-repeat}.bg-bottom-l{background-position:bottom}.bg-left-l{background-repeat:no-repeat;background-position:0}.outline-l{outline:1px solid}.outline-transparent-l{outline:1px solid transparent}.outline-0-l{outline:0}.ba-l{border-style:solid;border-width:1px}.bt-l{border-top-style:solid;border-top-width:1px}.br-l{border-right-style:solid;border-right-width:1px}.bb-l{border-bottom-style:solid;border-bottom-width:1px}.bl-l{border-left-style:solid;border-left-width:1px}.bn-l{border-style:none;border-width:0}.br0-l{border-radius:0}.br1-l{border-radius:.125rem}.br2-l{border-radius:.25rem}.br3-l{border-radius:.5rem}.br4-l{border-radius:1rem}.br-100-l{border-radius:100%}.br-pill-l{border-radius:9999px}.br--bottom-l{border-top-left-radius:0;border-top-right-radius:0}.br--top-l{border-bottom-right-radius:0}.br--right-l,.br--top-l{border-bottom-left-radius:0}.br--right-l{border-top-left-radius:0}.br--left-l{border-top-right-radius:0;border-bottom-right-radius:0}.b--dotted-l{border-style:dotted}.b--dashed-l{border-style:dashed}.b--solid-l{border-style:solid}.b--none-l{border-style:none}.bw0-l{border-width:0}.bw1-l{border-width:.125rem}.bw2-l{border-width:.25rem}.bw3-l{border-width:.5rem}.bw4-l{border-width:1rem}.bw5-l{border-width:2rem}.bt-0-l{border-top-width:0}.br-0-l{border-right-width:0}.bb-0-l{border-bottom-width:0}.bl-0-l{border-left-width:0}.shadow-1-l{box-shadow:0 0 4px 2px rgba(0,0,0,.2)}.shadow-2-l{box-shadow:0 0 8px 2px rgba(0,0,0,.2)}.shadow-3-l{box-shadow:2px 2px 4px 2px rgba(0,0,0,.2)}.shadow-4-l{box-shadow:2px 2px 8px 0 rgba(0,0,0,.2)}.shadow-5-l{box-shadow:4px 4px 8px 0 rgba(0,0,0,.2)}.top-0-l{top:0}.left-0-l{left:0}.right-0-l{right:0}.bottom-0-l{bottom:0}.top-1-l{top:1rem}.left-1-l{left:1rem}.right-1-l{right:1rem}.bottom-1-l{bottom:1rem}.top-2-l{top:2rem}.left-2-l{left:2rem}.right-2-l{right:2rem}.bottom-2-l{bottom:2rem}.top--1-l{top:-1rem}.right--1-l{right:-1rem}.bottom--1-l{bottom:-1rem}.left--1-l{left:-1rem}.top--2-l{top:-2rem}.right--2-l{right:-2rem}.bottom--2-l{bottom:-2rem}.left--2-l{left:-2rem}.absolute--fill-l{top:0;right:0;bottom:0;left:0}.cl-l{clear:left}.cr-l{clear:right}.cb-l{clear:both}.cn-l{clear:none}.dn-l{display:none}.di-l{display:inline}.db-l{display:block}.dib-l{display:inline-block}.dit-l{display:inline-table}.dt-l{display:table}.dtc-l{display:table-cell}.dt-row-l{display:table-row}.dt-row-group-l{display:table-row-group}.dt-column-l{display:table-column}.dt-column-group-l{display:table-column-group}.dt--fixed-l{table-layout:fixed;width:100%}.flex-l{display:flex}.inline-flex-l{display:inline-flex}.flex-auto-l{flex:1 1 auto;min-width:0;min-height:0}.flex-none-l{flex:none}.flex-column-l{flex-direction:column}.flex-row-l{flex-direction:row}.flex-wrap-l{flex-wrap:wrap}.flex-nowrap-l{flex-wrap:nowrap}.flex-wrap-reverse-l{flex-wrap:wrap-reverse}.flex-column-reverse-l{flex-direction:column-reverse}.flex-row-reverse-l{flex-direction:row-reverse}.items-start-l{align-items:flex-start}.items-end-l{align-items:flex-end}.items-center-l{align-items:center}.items-baseline-l{align-items:baseline}.items-stretch-l{align-items:stretch}.self-start-l{align-self:flex-start}.self-end-l{align-self:flex-end}.self-center-l{align-self:center}.self-baseline-l{align-self:baseline}.self-stretch-l{align-self:stretch}.justify-start-l{justify-content:flex-start}.justify-end-l{justify-content:flex-end}.justify-center-l{justify-content:center}.justify-between-l{justify-content:space-between}.justify-around-l{justify-content:space-around}.content-start-l{align-content:flex-start}.content-end-l{align-content:flex-end}.content-center-l{align-content:center}.content-between-l{align-content:space-between}.content-around-l{align-content:space-around}.content-stretch-l{align-content:stretch}.order-0-l{order:0}.order-1-l{order:1}.order-2-l{order:2}.order-3-l{order:3}.order-4-l{order:4}.order-5-l{order:5}.order-6-l{order:6}.order-7-l{order:7}.order-8-l{order:8}.order-last-l{order:99999}.flex-grow-0-l{flex-grow:0}.flex-grow-1-l{flex-grow:1}.flex-shrink-0-l{flex-shrink:0}.flex-shrink-1-l{flex-shrink:1}.fl-l{float:left}.fl-l,.fr-l{_display:inline}.fr-l{float:right}.fn-l{float:none}.i-l{font-style:italic}.fs-normal-l{font-style:normal}.normal-l{font-weight:400}.b-l{font-weight:700}.fw1-l{font-weight:100}.fw2-l{font-weight:200}.fw3-l{font-weight:300}.fw4-l{font-weight:400}.fw5-l{font-weight:500}.fw6-l{font-weight:600}.fw7-l{font-weight:700}.fw8-l{font-weight:800}.fw9-l{font-weight:900}.h1-l{height:1rem}.h2-l{height:2rem}.h3-l{height:4rem}.h4-l{height:8rem}.h5-l{height:16rem}.h-25-l{height:25%}.h-50-l{height:50%}.h-75-l{height:75%}.h-100-l{height:100%}.min-h-100-l{min-height:100%}.vh-25-l{height:25vh}.vh-50-l{height:50vh}.vh-75-l{height:75vh}.vh-100-l{height:100vh}.min-vh-100-l{min-height:100vh}.h-auto-l{height:auto}.h-inherit-l{height:inherit}.tracked-l{letter-spacing:.1em}.tracked-tight-l{letter-spacing:-.05em}.tracked-mega-l{letter-spacing:.25em}.lh-solid-l{line-height:1}.lh-title-l{line-height:1.25}.lh-copy-l{line-height:1.5}.mw-100-l{max-width:100%}.mw1-l{max-width:1rem}.mw2-l{max-width:2rem}.mw3-l{max-width:4rem}.mw4-l{max-width:8rem}.mw5-l{max-width:16rem}.mw6-l{max-width:32rem}.mw7-l{max-width:48rem}.mw8-l{max-width:64rem}.mw9-l{max-width:96rem}.mw-none-l{max-width:none}.w1-l{width:1rem}.w2-l{width:2rem}.w3-l{width:4rem}.w4-l{width:8rem}.w5-l{width:16rem}.w-10-l{width:10%}.w-20-l{width:20%}.w-25-l{width:25%}.w-30-l{width:30%}.w-33-l{width:33%}.w-34-l{width:34%}.w-40-l{width:40%}.w-50-l{width:50%}.w-60-l{width:60%}.w-70-l{width:70%}.w-75-l{width:75%}.w-80-l{width:80%}.w-90-l{width:90%}.w-100-l{width:100%}.w-third-l{width:33.33333%}.w-two-thirds-l{width:66.66667%}.w-auto-l{width:auto}.overflow-visible-l{overflow:visible}.overflow-hidden-l{overflow:hidden}.overflow-scroll-l{overflow:scroll}.overflow-auto-l{overflow:auto}.overflow-x-visible-l{overflow-x:visible}.overflow-x-hidden-l{overflow-x:hidden}.overflow-x-scroll-l{overflow-x:scroll}.overflow-x-auto-l{overflow-x:auto}.overflow-y-visible-l{overflow-y:visible}.overflow-y-hidden-l{overflow-y:hidden}.overflow-y-scroll-l{overflow-y:scroll}.overflow-y-auto-l{overflow-y:auto}.static-l{position:static}.relative-l{position:relative}.absolute-l{position:absolute}.fixed-l{position:fixed}.rotate-45-l{transform:rotate(45deg)}.rotate-90-l{transform:rotate(90deg)}.rotate-135-l{transform:rotate(135deg)}.rotate-180-l{transform:rotate(180deg)}.rotate-225-l{transform:rotate(225deg)}.rotate-270-l{transform:rotate(270deg)}.rotate-315-l{transform:rotate(315deg)}.pa0-l{padding:0}.pa1-l{padding:.25rem}.pa2-l{padding:.5rem}.pa3-l{padding:1rem}.pa4-l{padding:2rem}.pa5-l{padding:4rem}.pa6-l{padding:8rem}.pa7-l{padding:16rem}.pl0-l{padding-left:0}.pl1-l{padding-left:.25rem}.pl2-l{padding-left:.5rem}.pl3-l{padding-left:1rem}.pl4-l{padding-left:2rem}.pl5-l{padding-left:4rem}.pl6-l{padding-left:8rem}.pl7-l{padding-left:16rem}.pr0-l{padding-right:0}.pr1-l{padding-right:.25rem}.pr2-l{padding-right:.5rem}.pr3-l{padding-right:1rem}.pr4-l{padding-right:2rem}.pr5-l{padding-right:4rem}.pr6-l{padding-right:8rem}.pr7-l{padding-right:16rem}.pb0-l{padding-bottom:0}.pb1-l{padding-bottom:.25rem}.pb2-l{padding-bottom:.5rem}.pb3-l{padding-bottom:1rem}.pb4-l{padding-bottom:2rem}.pb5-l{padding-bottom:4rem}.pb6-l{padding-bottom:8rem}.pb7-l{padding-bottom:16rem}.pt0-l{padding-top:0}.pt1-l{padding-top:.25rem}.pt2-l{padding-top:.5rem}.pt3-l{padding-top:1rem}.pt4-l{padding-top:2rem}.pt5-l{padding-top:4rem}.pt6-l{padding-top:8rem}.pt7-l{padding-top:16rem}.pv0-l{padding-top:0;padding-bottom:0}.pv1-l{padding-top:.25rem;padding-bottom:.25rem}.pv2-l{padding-top:.5rem;padding-bottom:.5rem}.pv3-l{padding-top:1rem;padding-bottom:1rem}.pv4-l{padding-top:2rem;padding-bottom:2rem}.pv5-l{padding-top:4rem;padding-bottom:4rem}.pv6-l{padding-top:8rem;padding-bottom:8rem}.pv7-l{padding-top:16rem;padding-bottom:16rem}.ph0-l{padding-left:0;padding-right:0}.ph1-l{padding-left:.25rem;padding-right:.25rem}.ph2-l{padding-left:.5rem;padding-right:.5rem}.ph3-l{padding-left:1rem;padding-right:1rem}.ph4-l{padding-left:2rem;padding-right:2rem}.ph5-l{padding-left:4rem;padding-right:4rem}.ph6-l{padding-left:8rem;padding-right:8rem}.ph7-l{padding-left:16rem;padding-right:16rem}.ma0-l{margin:0}.ma1-l{margin:.25rem}.ma2-l{margin:.5rem}.ma3-l{margin:1rem}.ma4-l{margin:2rem}.ma5-l{margin:4rem}.ma6-l{margin:8rem}.ma7-l{margin:16rem}.ml0-l{margin-left:0}.ml1-l{margin-left:.25rem}.ml2-l{margin-left:.5rem}.ml3-l{margin-left:1rem}.ml4-l{margin-left:2rem}.ml5-l{margin-left:4rem}.ml6-l{margin-left:8rem}.ml7-l{margin-left:16rem}.mr0-l{margin-right:0}.mr1-l{margin-right:.25rem}.mr2-l{margin-right:.5rem}.mr3-l{margin-right:1rem}.mr4-l{margin-right:2rem}.mr5-l{margin-right:4rem}.mr6-l{margin-right:8rem}.mr7-l{margin-right:16rem}.mb0-l{margin-bottom:0}.mb1-l{margin-bottom:.25rem}.mb2-l{margin-bottom:.5rem}.mb3-l{margin-bottom:1rem}.mb4-l{margin-bottom:2rem}.mb5-l{margin-bottom:4rem}.mb6-l{margin-bottom:8rem}.mb7-l{margin-bottom:16rem}.mt0-l{margin-top:0}.mt1-l{margin-top:.25rem}.mt2-l{margin-top:.5rem}.mt3-l{margin-top:1rem}.mt4-l{margin-top:2rem}.mt5-l{margin-top:4rem}.mt6-l{margin-top:8rem}.mt7-l{margin-top:16rem}.mv0-l{margin-top:0;margin-bottom:0}.mv1-l{margin-top:.25rem;margin-bottom:.25rem}.mv2-l{margin-top:.5rem;margin-bottom:.5rem}.mv3-l{margin-top:1rem;margin-bottom:1rem}.mv4-l{margin-top:2rem;margin-bottom:2rem}.mv5-l{margin-top:4rem;margin-bottom:4rem}.mv6-l{margin-top:8rem;margin-bottom:8rem}.mv7-l{margin-top:16rem;margin-bottom:16rem}.mh0-l{margin-left:0;margin-right:0}.mh1-l{margin-left:.25rem;margin-right:.25rem}.mh2-l{margin-left:.5rem;margin-right:.5rem}.mh3-l{margin-left:1rem;margin-right:1rem}.mh4-l{margin-left:2rem;margin-right:2rem}.mh5-l{margin-left:4rem;margin-right:4rem}.mh6-l{margin-left:8rem;margin-right:8rem}.mh7-l{margin-left:16rem;margin-right:16rem}.na1-l{margin:-.25rem}.na2-l{margin:-.5rem}.na3-l{margin:-1rem}.na4-l{margin:-2rem}.na5-l{margin:-4rem}.na6-l{margin:-8rem}.na7-l{margin:-16rem}.nl1-l{margin-left:-.25rem}.nl2-l{margin-left:-.5rem}.nl3-l{margin-left:-1rem}.nl4-l{margin-left:-2rem}.nl5-l{margin-left:-4rem}.nl6-l{margin-left:-8rem}.nl7-l{margin-left:-16rem}.nr1-l{margin-right:-.25rem}.nr2-l{margin-right:-.5rem}.nr3-l{margin-right:-1rem}.nr4-l{margin-right:-2rem}.nr5-l{margin-right:-4rem}.nr6-l{margin-right:-8rem}.nr7-l{margin-right:-16rem}.nb1-l{margin-bottom:-.25rem}.nb2-l{margin-bottom:-.5rem}.nb3-l{margin-bottom:-1rem}.nb4-l{margin-bottom:-2rem}.nb5-l{margin-bottom:-4rem}.nb6-l{margin-bottom:-8rem}.nb7-l{margin-bottom:-16rem}.nt1-l{margin-top:-.25rem}.nt2-l{margin-top:-.5rem}.nt3-l{margin-top:-1rem}.nt4-l{margin-top:-2rem}.nt5-l{margin-top:-4rem}.nt6-l{margin-top:-8rem}.nt7-l{margin-top:-16rem}.strike-l{text-decoration:line-through}.underline-l{text-decoration:underline}.no-underline-l{text-decoration:none}.tl-l{text-align:left}.tr-l{text-align:right}.tc-l{text-align:center}.tj-l{text-align:justify}.ttc-l{text-transform:capitalize}.ttl-l{text-transform:lowercase}.ttu-l{text-transform:uppercase}.ttn-l{text-transform:none}.f-6-l,.f-headline-l{font-size:6rem}.f-5-l,.f-subheadline-l{font-size:5rem}.f1-l{font-size:3rem}.f2-l{font-size:2.25rem}.f3-l{font-size:1.5rem}.f4-l{font-size:1.25rem}.f5-l{font-size:1rem}.f6-l{font-size:.875rem}.f7-l{font-size:.75rem}.measure-l{max-width:30em}.measure-wide-l{max-width:34em}.measure-narrow-l{max-width:20em}.indent-l{text-indent:1em;margin-top:0;margin-bottom:0}.small-caps-l{font-variant:small-caps}.truncate-l{white-space:nowrap;overflow:hidden;text-overflow:ellipsis}.center-l{margin-left:auto}.center-l,.mr-auto-l{margin-right:auto}.ml-auto-l{margin-left:auto}.clip-l{position:fixed!important;_position:absolute!important;clip:rect(1px 1px 1px 1px);clip:rect(1px,1px,1px,1px)}.ws-normal-l{white-space:normal}.nowrap-l{white-space:nowrap}.pre-l{white-space:pre}.v-base-l{vertical-align:baseline}.v-mid-l{vertical-align:middle}.v-top-l{vertical-align:top}.v-btm-l{vertical-align:bottom}}@font-face{font-family:Inter;font-style:normal;font-weight:400;src:url(https://media.urbit.org/fonts/Inter-Regular.woff2) format("woff2")}@font-face{font-family:Inter;font-style:italic;font-weight:400;src:url(https://media.urbit.org/fonts/Inter-Italic.woff2) format("woff2")}@font-face{font-family:Inter;font-style:normal;font-weight:700;src:url(https://media.urbit.org/fonts/Inter-Bold.woff2) format("woff2")}@font-face{font-family:Inter;font-style:italic;font-weight:700;src:url(https://media.urbit.org/fonts/Inter-BoldItalic.woff2) format("woff2")}@font-face{font-family:Source Code Pro;src:url(https://storage.googleapis.com/media.urbit.org/fonts/scp-extralight.woff);font-weight:200}@font-face{font-family:Source Code Pro;src:url(https://storage.googleapis.com/media.urbit.org/fonts/scp-light.woff);font-weight:300}@font-face{font-family:Source Code Pro;src:url(https://storage.googleapis.com/media.urbit.org/fonts/scp-regular.woff);font-weight:400}@font-face{font-family:Source Code Pro;src:url(https://storage.googleapis.com/media.urbit.org/fonts/scp-medium.woff);font-weight:500}@font-face{font-family:Source Code Pro;src:url(https://storage.googleapis.com/media.urbit.org/fonts/scp-semibold.woff);font-weight:600}@font-face{font-family:Source Code Pro;src:url(https://storage.googleapis.com/media.urbit.org/fonts/scp-bold.woff);font-weight:700}.spinner-pending{position:relative;background-color:#fff}.spinner-pending,.spinner-pending:after{content:"";border-radius:100%;height:16px;width:16px}.spinner-pending:after{background-color:gray;position:absolute;clip:rect(0,16px,16px,8px);animation:a 1s cubic-bezier(.745,.045,.355,1) infinite}@keyframes a{0%{transform:rotate(0deg)}25%{transform:rotate(90deg)}50%{transform:rotate(180deg)}75%{transform:rotate(270deg)}to{transform:rotate(1turn)}}.spinner-nostart{width:8px;height:8px;border-radius:100%;content:"";background-color:#000}a,button,h1,h2,h3,h4,h5,h6,input,p,textarea{margin-block-end:unset;margin-block-start:unset;-webkit-margin-before:unset;-webkit-margin-after:unset;font-family:Inter,sans-serif}button,input,select,textarea{outline:none;-webkit-appearance:none;border:none;background-color:#fff}a{color:#000!important;font-weight:400!important}h2{font-size:32px;line-height:48px;font-weight:700}.body-regular{font-size:16px;line-height:24px;font-weight:600}.body-large{font-size:20px;line-height:24px}.label-regular{font-size:14px;line-height:24px}.label-small-mono{font-size:12px;line-height:24px;font-family:Source Code Pro,monospace}.body-regular-400{font-size:16px;line-height:24px;font-weight:400}.plus-font{font-size:48px;line-height:24px}.btn-font{font-size:14px;line-height:16px;font-weight:600}.fw-normal{font-weight:400}.fw-bold{font-weight:700}.bg-v-light-gray{background-color:#f9f9f9}.nice-green{color:#2aa779}.bg-nice-green{background:#2ed196}.nice-red{color:#ee5432}.inter{font-family:Inter,sans-serif} \ No newline at end of file diff --git a/pkg/arvo/app/chat/img/Home.png b/pkg/arvo/app/chat/img/Home.png new file mode 100644 index 0000000000000000000000000000000000000000..04b1e7b87022b502fffb58c9cd29c050c57272ba GIT binary patch literal 255 zcmeAS@N?(olHy`uVBq!ia0vp^4j|0I1|(Ny7TyC=oCO|{#S9E$svykh8Km+7D9BhG z6@1Tptf4tXn?Ebh_X^&*Q@}Yx2b}H9c)Scsq@0+iE zsQ>Zvjt|d&Y*aRpvQKL{_V{?$h0L1m9Ntp5{~5{Z@@Kx7^oYfykZFkpW6&K_b?aTn ttM@B^lW7!DcjyvUI69RdWDmoYBKDmgnHQ{&-B}9adb;|#taD0e0sub8Tkrq? literal 0 HcmV?d00001 diff --git a/pkg/arvo/app/chat/img/Icon-Home.png b/pkg/arvo/app/chat/img/Icon-Home.png new file mode 100644 index 0000000000000000000000000000000000000000..04b1e7b87022b502fffb58c9cd29c050c57272ba GIT binary patch literal 255 zcmeAS@N?(olHy`uVBq!ia0vp^4j|0I1|(Ny7TyC=oCO|{#S9E$svykh8Km+7D9BhG z6@1Tptf4tXn?Ebh_X^&*Q@}Yx2b}H9c)Scsq@0+iE zsQ>Zvjt|d&Y*aRpvQKL{_V{?$h0L1m9Ntp5{~5{Z@@Kx7^oYfykZFkpW6&K_b?aTn ttM@B^lW7!DcjyvUI69RdWDmoYBKDmgnHQ{&-B}9adb;|#taD0e0sub8Tkrq? literal 0 HcmV?d00001 diff --git a/pkg/arvo/app/chat/img/Send.png b/pkg/arvo/app/chat/img/Send.png new file mode 100644 index 0000000000000000000000000000000000000000..6c13772b945853f6044fa638dd8b5760e1ef439f GIT binary patch literal 1010 zcmV1BRn^QHip>FQIEX6~xr77Ep|@@8t46Xz$n3yZ zoSH2dt=8YbYjv#~D)S5$p|kL@{C9n z7`D7#B?^o~UT+eIw85wwT4pULCWf%9(l(uUapnNhk!OLH2)KEKp*sm$wuf5)whPZC zJ2Yetz;>azWrhaCfYrisOpKDP@*|2YF@V$IJwWpQ;{S!LN(6lEyOjh=EqqV}25{{9 zfniAA&E1+9jQ-<7h;%xgvMCSVYGEnQoC-?v;y6zC`#ndAL7BjiO93-^84M+ERe4h` zg;V7*l~~xAuvmSo+FPw=$mTmujA zwB_Vi;ci4EFoLHo2NIaw!0c(p5xL!%U+^>~qL+vK2Tvn@(o0_8XvQ7T#BX}Z1d_Z6 zp1Oo6sc-=-oDOm{*Io$|MPi}Pho`_%=2P}T?c)0Z6L{?eq7BR40bg zgI7JBMGfP3c&hk;8V4Oz3(2$#HNtf5tIZsM?E-Vl3=P=N(Ik+#P_i^_Vca5pZjmlpUDfnLmdggjNeH@DiC^%H-7b z9s&C`(n)b;&<))o%t@p6IKTkO9!3yC|HBB@u<$T~3G6}(`-HbgVu;JM>^;vh_fDaX gq1hubtaVHI2aH%-klwb~V*mgE07*qoM6N<$g6R9ye*gdg literal 0 HcmV?d00001 diff --git a/pkg/arvo/app/chat/img/Tile.png b/pkg/arvo/app/chat/img/Tile.png new file mode 100644 index 0000000000000000000000000000000000000000..58f4ccbea72caf0032dab97ade5420bf1ce2050a GIT binary patch literal 1125 zcmeAS@N?(olHy`uVBq!ia0vp^H-Pvw2OE&&Ns0w=I14-?iy0WiR6&^0Gf3qFP>``W z$lZxy-8q?;Kn_c~qpu?a!^VE@KZ&di49vegT^vIy7~kFv^n2_f(st1(Ni-$?gVih9 z15OF-iz`#(Q=}*RUGX*FG1=nC*W2$tSx##0_#~t`|6T9WkX?7<8e3m{^K#DP5>Pha z5RzcI`%V5vjv4E+O?UIWPy2v{IC+{_*c_Rf6&f8U98mB`5KtKq;a$2L6n5{uBp}Sw zG;40c?YG+w+yS~T>!0zBw9T3ZQ~y0nX&O-X0Rs;yq%Pz}cKrVR`_rdSK?_v7XC(0R z^FLbTxtYDJz=Y}I~T!YY=ujk8Q`U4HEKyD`@QDfV-+o)V;#|CF`2VjtX0w@sZ{}^E|4)8bcSg}c zj^{u#drGtn3LROG1DPS0fKCaxcpPZ@)V)CWb6Btd2}=;MQ&9ZLnNP|uHi+R%N*8i7 zW3HFBmP*=b3Mw8ZRzc>T>N-*N!=? zb1eV-y70G-< + + + Chat + + + + + +
+ + + + + diff --git a/pkg/arvo/app/chat/js/index.js b/pkg/arvo/app/chat/js/index.js new file mode 100644 index 000000000..68fb6127b --- /dev/null +++ b/pkg/arvo/app/chat/js/index.js @@ -0,0 +1 @@ +!function(e){"function"==typeof define&&define.amd?define("index",e):e()}(function(){"use strict";var e="undefined"!=typeof window?window:"undefined"!=typeof global?global:"undefined"!=typeof self?self:{};function t(){throw new Error("Dynamic requires are not currently supported by rollup-plugin-commonjs")}function n(e){return e&&e.__esModule&&Object.prototype.hasOwnProperty.call(e,"default")?e.default:e}function r(e,t){return e(t={exports:{}},t.exports),t.exports}var a=Object.getOwnPropertySymbols,i=Object.prototype.hasOwnProperty,o=Object.prototype.propertyIsEnumerable;var l=function(){try{if(!Object.assign)return!1;var e=new String("abc");if(e[5]="de","5"===Object.getOwnPropertyNames(e)[0])return!1;for(var t={},n=0;n<10;n++)t["_"+String.fromCharCode(n)]=n;if("0123456789"!==Object.getOwnPropertyNames(t).map(function(e){return t[e]}).join(""))return!1;var r={};return"abcdefghijklmnopqrst".split("").forEach(function(e){r[e]=e}),"abcdefghijklmnopqrst"===Object.keys(Object.assign({},r)).join("")}catch(e){return!1}}()?Object.assign:function(e,t){for(var n,r,l=function(e){if(null==e)throw new TypeError("Object.assign cannot be called with null or undefined");return Object(e)}(e),s=1;s2?n-2:0),a=2;a1?t-1:0),r=1;r2?n-2:0),a=2;a8)throw new Error("warningWithoutStack() currently supports at most 8 arguments.");if(!e){if("undefined"!=typeof console){var i=r.map(function(e){return""+e});i.unshift("Warning: "+t),Function.prototype.apply.call(console.error,console,i)}try{var o=0,l="Warning: "+t.replace(/%s/g,function(){return r[o++]});throw new Error(l)}catch(e){}}},D={};function E(e,t){var n=e.constructor,r=n&&(n.displayName||n.name)||"ReactClass",a=r+"."+t;D[a]||(C(!1,"Can't call %s on a component that is not yet mounted. This is a no-op, but it might indicate a bug in your application. Instead, assign to `this.state` directly or define a `state = {};` class property with the desired state in the %s component.",t,r),D[a]=!0)}var T={isMounted:function(e){return!1},enqueueForceUpdate:function(e,t,n){E(e,"forceUpdate")},enqueueReplaceState:function(e,t,n,r){E(e,"replaceState")},enqueueSetState:function(e,t,n,r){E(e,"setState")}},N={};function M(e,t,n){this.props=e,this.context=t,this.refs=N,this.updater=n||T}Object.freeze(N),M.prototype.isReactComponent={},M.prototype.setState=function(e,t){"object"!=typeof e&&"function"!=typeof e&&null!=e&&x(!1,"setState(...): takes an object of state variables to update or a function which returns an object of state variables."),this.updater.enqueueSetState(this,e,t,"setState")},M.prototype.forceUpdate=function(e){this.updater.enqueueForceUpdate(this,e,"forceUpdate")};var S={isMounted:["isMounted","Instead, make sure to clean up subscriptions and pending requests in componentWillUnmount to prevent memory leaks."],replaceState:["replaceState","Refactor your code to use setState instead (see https://github.com/facebook/react/issues/3236)."]},I=function(e,t){Object.defineProperty(M.prototype,e,{get:function(){k(!1,"%s(...) is deprecated in plain JavaScript React classes. %s",t[0],t[1])}})};for(var R in S)S.hasOwnProperty(R)&&I(R,S[R]);function O(){}function P(e,t,n){this.props=e,this.context=t,this.refs=N,this.updater=n||T}O.prototype=M.prototype;var L=P.prototype=new O;L.constructor=P,t(L,M.prototype),L.isPureReactComponent=!0;var B={current:null,currentDispatcher:null},A=/^(.*)[\\\/]/,j=1;function U(e){if(null==e)return null;if("number"==typeof e.tag&&C(!1,"Received an unexpected object in getComponentName(). This is likely a bug in React. Please file an issue."),"function"==typeof e)return e.displayName||e.name||null;if("string"==typeof e)return e;switch(e){case d:return"ConcurrentMode";case o:return"Fragment";case i:return"Portal";case u:return"Profiler";case s:return"StrictMode";case h:return"Suspense"}if("object"==typeof e)switch(e.$$typeof){case f:return"Context.Consumer";case c:return"Context.Provider";case p:return r=e,a=e.render,l="ForwardRef",g=a.displayName||a.name||"",r.displayName||(""!==g?l+"("+g+")":l);case m:return U(e.type);case b:var t=(n=e)._status===j?n._result:null;if(t)return U(t)}var n,r,a,l,g;return null}var z={},F=null;function W(e){F=e}z.getCurrentStack=null,z.getStackAddendum=function(){var e="";if(F){var t=U(F.type),n=F._owner;e+=function(e,t,n){var r="";if(t){var a=t.fileName,i=a.replace(A,"");if(/^index\./.test(i)){var o=a.match(A);if(o){var l=o[1];l&&(i=l.replace(A,"")+"/"+i)}}r=" (at "+i+":"+t.lineNumber+")"}else n&&(r=" (created by "+n+")");return"\n in "+(e||"Unknown")+r}(t,F._source,n&&U(n.type))}var r=z.getCurrentStack;return r&&(e+=r()||""),e};var Z={ReactCurrentOwner:B,assign:t};t(Z,{ReactDebugCurrentFrame:z,ReactComponentTreeHook:{}});var H=function(e,t){if(!e){for(var n=Z.ReactDebugCurrentFrame.getStackAddendum(),r=arguments.length,a=Array(r>2?r-2:0),i=2;i1){for(var c=Array(u),f=0;f.")}return t}(t);if(!ge[n]){ge[n]=!0;var r="";e&&e._owner&&e._owner!==B.current&&(r=" It was passed a child from "+U(e._owner.type)+"."),W(e),H(!1,'Each child in an array or iterator should have a unique "key" prop.%s%s See https://fb.me/react-warning-keys for more information.',n,r),W(null)}}}function ye(e,t){if("object"==typeof e)if(Array.isArray(e))for(var n=0;n",i=" Did you accidentally export a JSX literal instead of a component?"):s=typeof e,H(!1,"React.createElement: type is invalid -- expected a string (for built-in components) or a class/function (for composite components) but got: %s.%s",s,i)}var u=X.apply(this,arguments);if(null==u)return u;if(r)for(var c=2;c is not supported and will be removed in a future major release. Did you mean to render instead?")),n.Provider},set:function(e){n.Provider=e}},_currentValue:{get:function(){return n._currentValue},set:function(e){n._currentValue=e}},_currentValue2:{get:function(){return n._currentValue2},set:function(e){n._currentValue2=e}},_threadCount:{get:function(){return n._threadCount},set:function(e){n._threadCount=e}},Consumer:{get:function(){return r||(r=!0,H(!1,"Rendering is not supported and will be removed in a future major release. Did you mean to render instead?")),n.Consumer}}}),n.Consumer=i,n._currentRenderer=null,n._currentRenderer2=null,n},forwardRef:function(e){return null!=e&&e.$$typeof===m?C(!1,"forwardRef requires a render function but received a `memo` component. Instead of forwardRef(memo(...)), use memo(forwardRef(...))."):"function"!=typeof e?C(!1,"forwardRef requires a render function but was given %s.",null===e?"null":typeof e):0!==e.length&&2!==e.length&&C(!1,"forwardRef render functions accept exactly two parameters: props and ref. %s",1===e.length?"Did you forget to use the ref parameter?":"Any additional parameter will be undefined."),null!=e&&(null!=e.defaultProps||null!=e.propTypes)&&C(!1,"forwardRef render functions do not support propTypes or defaultProps. Did you accidentally pass a React component?"),{$$typeof:p,render:e}},lazy:function(e){return{$$typeof:b,_ctor:e,_status:-1,_result:null}},memo:function(e,t){return he(e)||C(!1,"memo: The first argument must be a component. Instead received: %s",null===e?"null":typeof e),{$$typeof:m,type:e,compare:void 0===t?null:t}},Fragment:o,StrictMode:s,Suspense:h,createElement:we,cloneElement:function(e,n,r){for(var a=function(e,n,r){null==e&&x(!1,"React.cloneElement(...): The argument must be a React element, but you passed %s.",e);var a=void 0,i=t({},e.props),o=e.key,l=e.ref,s=e._self,u=e._source,c=e._owner;if(null!=n){q(n)&&(l=n.ref,c=B.current),Q(n)&&(o=""+n.key);var f=void 0;for(a in e.type&&e.type.defaultProps&&(f=e.type.defaultProps),n)G.call(n,a)&&!Y.hasOwnProperty(a)&&(void 0===n[a]&&void 0!==f?i[a]=f[a]:i[a]=n[a])}var d=arguments.length-2;if(1===d)i.children=r;else if(d>1){for(var p=Array(d),h=0;h=t){n=e;break}e=e.next}while(e!==r);null===n?n=r:n===r&&(r=s,c()),(t=n.previous).next=n.previous=s,s.next=n,s.previous=t}}function d(){if(-1===o&&null!==r&&1===r.priorityLevel){s=!0;try{do{f()}while(null!==r&&1===r.priorityLevel)}finally{s=!1,null!==r?c():u=!1}}}function p(e){s=!0;var t=a;a=e;try{if(e)for(;null!==r;){var i=n.unstable_now();if(!(r.expirationTime<=i))break;do{f()}while(null!==r&&r.expirationTime<=i)}else if(null!==r)do{f()}while(null!==r&&!D())}finally{s=!1,a=t,null!==r?c():u=!1,d()}}var h,m,b=Date,g="function"==typeof setTimeout?setTimeout:void 0,v="function"==typeof clearTimeout?clearTimeout:void 0,y="function"==typeof requestAnimationFrame?requestAnimationFrame:void 0,_="function"==typeof cancelAnimationFrame?cancelAnimationFrame:void 0;function w(e){h=y(function(t){v(m),e(t)}),m=g(function(){_(h),e(n.unstable_now())},100)}if("object"==typeof performance&&"function"==typeof performance.now){var x=performance;n.unstable_now=function(){return x.now()}}else n.unstable_now=function(){return b.now()};var k,C,D,E=null;if("undefined"!=typeof window?E=window:void 0!==e&&(E=e),E&&E._schedMock){var T=E._schedMock;k=T[0],C=T[1],D=T[2],n.unstable_now=T[3]}else if("undefined"==typeof window||"function"!=typeof MessageChannel){var N=null,M=function(e){if(null!==N)try{N(e)}finally{N=null}};k=function(e){null!==N?setTimeout(k,0,e):(N=e,setTimeout(M,0,!1))},C=function(){N=null},D=function(){return!1}}else{"undefined"!=typeof console&&("function"!=typeof y&&console.error("This browser doesn't support requestAnimationFrame. Make sure that you load a polyfill in older browsers. https://fb.me/react-polyfills"),"function"!=typeof _&&console.error("This browser doesn't support cancelAnimationFrame. Make sure that you load a polyfill in older browsers. https://fb.me/react-polyfills"));var S=null,I=!1,R=-1,O=!1,P=!1,L=0,B=33,A=33;D=function(){return L<=n.unstable_now()};var j=new MessageChannel,U=j.port2;j.port1.onmessage=function(){I=!1;var e=S,t=R;S=null,R=-1;var r=n.unstable_now(),a=!1;if(0>=L-r){if(!(-1!==t&&t<=r))return O||(O=!0,w(z)),S=e,void(R=t);a=!0}if(null!==e){P=!0;try{e(a)}finally{P=!1}}};var z=function(e){if(null!==S){w(z);var t=e-L+A;tt&&(t=8),A=tt?U.postMessage(void 0):O||(O=!0,w(z))},C=function(){S=null,I=!1,R=-1}}n.unstable_ImmediatePriority=1,n.unstable_UserBlockingPriority=2,n.unstable_NormalPriority=3,n.unstable_IdlePriority=5,n.unstable_LowPriority=4,n.unstable_runWithPriority=function(e,t){switch(e){case 1:case 2:case 3:case 4:case 5:break;default:e=3}var r=i,a=o;i=e,o=n.unstable_now();try{return t()}finally{i=r,o=a,d()}},n.unstable_next=function(e){switch(i){case 1:case 2:case 3:var t=3;break;default:t=i}var r=i,a=o;i=t,o=n.unstable_now();try{return e()}finally{i=r,o=a,d()}},n.unstable_scheduleCallback=function(e,t){var a=-1!==o?o:n.unstable_now();if("object"==typeof t&&null!==t&&"number"==typeof t.timeout)t=a+t.timeout;else switch(i){case 1:t=a+-1;break;case 2:t=a+250;break;case 5:t=a+1073741823;break;case 4:t=a+1e4;break;default:t=a+5e3}if(e={callback:e,priorityLevel:i,expirationTime:t,next:null,previous:null},null===r)r=e.next=e.previous=e,c();else{a=null;var l=r;do{if(l.expirationTime>t){a=l;break}l=l.next}while(l!==r);null===a?a=r:a===r&&(r=e,c()),(t=a.previous).next=a.previous=e,e.next=a,e.previous=t}return e},n.unstable_cancelCallback=function(e){var t=e.next;if(null!==t){if(t===e)r=null;else{e===r&&(r=t);var n=e.previous;n.next=t,t.previous=n}e.next=e.previous=null}},n.unstable_wrapCallback=function(e){var t=i;return function(){var r=i,a=o;i=t,o=n.unstable_now();try{return e.apply(this,arguments)}finally{i=r,o=a,d()}}},n.unstable_getCurrentPriorityLevel=function(){return i},n.unstable_shouldYield=function(){return!a&&(null!==r&&r.expirationTime=i){c=f;break}f=f.next}while(f!==p);null===c?c=p:c===p&&(p=u,w());var d=c.previous;d.next=c.previous=u,u.next=c,u.previous=d}}}function k(){if(-1===b&&null!==p&&p.priorityLevel===r){v=!0;try{do{x()}while(null!==p&&p.priorityLevel===r)}finally{v=!1,null!==p?w():y=!1}}}function C(e){v=!0;var r=h;h=e;try{if(e)for(;null!==p&&!t;){var a=n.unstable_now();if(!(p.expirationTime<=a))break;do{x()}while(null!==p&&p.expirationTime<=a&&!t)}else if(null!==p)do{x()}while(null!==p&&!M())}finally{v=!1,h=r,null!==p?w():y=!1,k()}}var D,E,T,N,M,S=Date,I="function"==typeof setTimeout?setTimeout:void 0,R="function"==typeof clearTimeout?clearTimeout:void 0,O="function"==typeof requestAnimationFrame?requestAnimationFrame:void 0,P="function"==typeof cancelAnimationFrame?cancelAnimationFrame:void 0,L=function(e){D=O(function(t){R(E),e(t)}),E=I(function(){P(D),e(n.unstable_now())},100)};if(_){var B=performance;n.unstable_now=function(){return B.now()}}else n.unstable_now=function(){return S.now()};var A=null;if("undefined"!=typeof window?A=window:void 0!==e&&(A=e),A&&A._schedMock){var j=A._schedMock;T=j[0],N=j[1],M=j[2],n.unstable_now=j[3]}else if("undefined"==typeof window||"function"!=typeof MessageChannel){var U=null,z=function(e){if(null!==U)try{U(e)}finally{U=null}};T=function(e,t){null!==U?setTimeout(T,0,e):(U=e,setTimeout(z,0,!1))},N=function(){U=null},M=function(){return!1}}else{"undefined"!=typeof console&&("function"!=typeof O&&console.error("This browser doesn't support requestAnimationFrame. Make sure that you load a polyfill in older browsers. https://fb.me/react-polyfills"),"function"!=typeof P&&console.error("This browser doesn't support cancelAnimationFrame. Make sure that you load a polyfill in older browsers. https://fb.me/react-polyfills"));var F=null,W=!1,Z=-1,H=!1,G=!1,Y=0,V=33,$=33;M=function(){return Y<=n.unstable_now()};var q=new MessageChannel,Q=q.port2;q.port1.onmessage=function(e){W=!1;var t=F,r=Z;F=null,Z=-1;var a=n.unstable_now(),i=!1;if(Y-a<=0){if(!(-1!==r&&r<=a))return H||(H=!0,L(K)),F=t,void(Z=r);i=!0}if(null!==t){G=!0;try{t(i)}finally{G=!1}}};var K=function(e){if(null!==F){L(K);var t=e-Y+$;t<$&&V<$?(t<8&&(t=8),$=th){y=_;break}_=_.next}while(_!==p);null===y?y=p:y===p&&(p=v,w());var x=y.previous;x.next=y.previous=v,v.next=y,v.previous=x}return v},n.unstable_cancelCallback=function(e){var t=e.next;if(null!==t){if(t===e)p=null;else{e===p&&(p=t);var n=e.previous;n.next=t,t.previous=n}e.next=e.previous=null}},n.unstable_wrapCallback=function(e){var t=m;return function(){var r=m,a=b;m=t,b=n.unstable_now();try{return e.apply(this,arguments)}finally{m=r,b=a,k()}}},n.unstable_getCurrentPriorityLevel=function(){return m},n.unstable_shouldYield=function(){return!h&&(null!==p&&p.expirationTimethis.eventPool.length&&this.eventPool.push(e)}function Se(e){e.eventPool=[],e.getPooled=Ne,e.release=Me}l(Te.prototype,{preventDefault:function(){this.defaultPrevented=!0;var e=this.nativeEvent;e&&(e.preventDefault?e.preventDefault():"unknown"!=typeof e.returnValue&&(e.returnValue=!1),this.isDefaultPrevented=De)},stopPropagation:function(){var e=this.nativeEvent;e&&(e.stopPropagation?e.stopPropagation():"unknown"!=typeof e.cancelBubble&&(e.cancelBubble=!0),this.isPropagationStopped=De)},persist:function(){this.isPersistent=De},isPersistent:Ee,destructor:function(){var e,t=this.constructor.Interface;for(e in t)this[e]=null;this.nativeEvent=this._targetInst=this.dispatchConfig=null,this.isPropagationStopped=this.isDefaultPrevented=Ee,this._dispatchInstances=this._dispatchListeners=null}}),Te.Interface={type:null,target:null,currentTarget:function(){return null},eventPhase:null,bubbles:null,cancelable:null,timeStamp:function(e){return e.timeStamp||Date.now()},defaultPrevented:null,isTrusted:null},Te.extend=function(e){function t(){}function n(){return r.apply(this,arguments)}var r=this;t.prototype=r.prototype;var a=new t;return l(a,n.prototype),n.prototype=a,n.prototype.constructor=n,n.Interface=l({},r.Interface,e),n.extend=r.extend,Se(n),n},Se(Te);var Ie=Te.extend({data:null}),Re=Te.extend({data:null}),Oe=[9,13,27,32],Pe=ce&&"CompositionEvent"in window,Le=null;ce&&"documentMode"in document&&(Le=document.documentMode);var Be=ce&&"TextEvent"in window&&!Le,Ae=ce&&(!Pe||Le&&8=Le),je=String.fromCharCode(32),Ue={beforeInput:{phasedRegistrationNames:{bubbled:"onBeforeInput",captured:"onBeforeInputCapture"},dependencies:["compositionend","keypress","textInput","paste"]},compositionEnd:{phasedRegistrationNames:{bubbled:"onCompositionEnd",captured:"onCompositionEndCapture"},dependencies:"blur compositionend keydown keypress keyup mousedown".split(" ")},compositionStart:{phasedRegistrationNames:{bubbled:"onCompositionStart",captured:"onCompositionStartCapture"},dependencies:"blur compositionstart keydown keypress keyup mousedown".split(" ")},compositionUpdate:{phasedRegistrationNames:{bubbled:"onCompositionUpdate",captured:"onCompositionUpdateCapture"},dependencies:"blur compositionupdate keydown keypress keyup mousedown".split(" ")}},ze=!1;function Fe(e,t){switch(e){case"keyup":return-1!==Oe.indexOf(t.keyCode);case"keydown":return 229!==t.keyCode;case"keypress":case"mousedown":case"blur":return!0;default:return!1}}function We(e){return"object"==typeof(e=e.detail)&&"data"in e?e.data:null}var Ze=!1;var He={eventTypes:Ue,extractEvents:function(e,t,n,r){var a=void 0,i=void 0;if(Pe)e:{switch(e){case"compositionstart":a=Ue.compositionStart;break e;case"compositionend":a=Ue.compositionEnd;break e;case"compositionupdate":a=Ue.compositionUpdate;break e}a=void 0}else Ze?Fe(e,n)&&(a=Ue.compositionEnd):"keydown"===e&&229===n.keyCode&&(a=Ue.compositionStart);return a?(Ae&&"ko"!==n.locale&&(Ze||a!==Ue.compositionStart?a===Ue.compositionEnd&&Ze&&(i=Ce()):(xe="value"in(we=r)?we.value:we.textContent,Ze=!0)),a=Ie.getPooled(a,t,n,r),i?a.data=i:null!==(i=We(n))&&(a.data=i),ue(a),i=a):i=null,(e=Be?function(e,t){switch(e){case"compositionend":return We(t);case"keypress":return 32!==t.which?null:(ze=!0,je);case"textInput":return(e=t.data)===je&&ze?null:e;default:return null}}(e,n):function(e,t){if(Ze)return"compositionend"===e||!Pe&&Fe(e,t)?(e=Ce(),ke=xe=we=null,Ze=!1,e):null;switch(e){case"paste":return null;case"keypress":if(!(t.ctrlKey||t.altKey||t.metaKey)||t.ctrlKey&&t.altKey){if(t.char&&1