From 3a579e2dd45453f231d3cc8426a28b4803feaa9f Mon Sep 17 00:00:00 2001 From: Thomas Scholtes Date: Fri, 14 Dec 2018 16:35:28 +0100 Subject: [PATCH] Add IPFS machine backend * Add a `MachineBackend` implementation based on IPFS * Extend `test/machine-backends.rad` to test IPFS backend against real IPFS daemon * Add commands `rad-ipfs`, `rad-ipfs-daemon`, and `rad-ipfs-machine-create` Follow-up * Replace `Wreq` with `servant-client` and `ipfs-api` from https://github.com/oscoin/ipfs/tree/master/ipfs-api --- bin/rad-ipfs | 6 + bin/rad-ipfs-daemon | 27 ++ bin/rad-ipfs-machine-create | 17 ++ cloudbuild.yaml | 19 +- exe/RadicleExe.hs | 5 +- package.yaml | 8 +- rad/prelude/chain.rad | 36 ++- rad/prelude/test.rad | 2 +- rad/tests/stub-primitives.rad | 11 - snapshot.yaml | 15 +- src/Radicle/Internal/MachineBackend/Ipfs.hs | 318 ++++++++++++++++++++ src/Radicle/Internal/PrimFns.hs | 6 + stack.yaml | 1 + test/machine-backends.rad | 87 ++++++ test/server.rad | 78 ----- test/spec/Radicle/Tests.hs | 2 +- 16 files changed, 527 insertions(+), 111 deletions(-) create mode 100755 bin/rad-ipfs create mode 100755 bin/rad-ipfs-daemon create mode 100755 bin/rad-ipfs-machine-create create mode 100644 src/Radicle/Internal/MachineBackend/Ipfs.hs create mode 100644 test/machine-backends.rad delete mode 100644 test/server.rad diff --git a/bin/rad-ipfs b/bin/rad-ipfs new file mode 100755 index 000000000..8a1f687b6 --- /dev/null +++ b/bin/rad-ipfs @@ -0,0 +1,6 @@ +#!/usr/bin/env bash +# +# Wrapper for the 'ipfs' command that talks to the IPFS daemon instance +# for the Radicle network. + +IPFS_PATH=${IPFS_PATH:-"$HOME/.local/share/radicle/ipfs"} ipfs --api "/ip4/127.0.0.1/tcp/9301" "$@" diff --git a/bin/rad-ipfs-daemon b/bin/rad-ipfs-daemon new file mode 100755 index 000000000..01ccea87e --- /dev/null +++ b/bin/rad-ipfs-daemon @@ -0,0 +1,27 @@ +#!/usr/bin/env bash +# +# Run the IPFS daemon with configuration for the Radicle network. + +set -euo pipefail + +export IPFS_PATH=${IPFS_PATH:-"$HOME/.local/share/radicle/ipfs"} +if [[ ! -d "$IPFS_PATH" ]]; then + mkdir -p "$IPFS_PATH" + ipfs init + cat >"$IPFS_PATH/swarm.key" </dev/null +echo "$ipns_id" diff --git a/cloudbuild.yaml b/cloudbuild.yaml index 043a4df99..4613960ee 100644 --- a/cloudbuild.yaml +++ b/cloudbuild.yaml @@ -121,7 +121,7 @@ steps: docker push "$image_name:$tag" fi - - id: "Start and expose radicle-server" + - id: "Start radicle-server and IPFS daemon" name: 'docker/compose:1.23.2' waitFor: - "Build radicle-server image" @@ -129,15 +129,26 @@ steps: args: - "-c" - | + set -euxo pipefail cd images/radicle-server docker-compose up -d postgres sleep 5 # Wait for the DB to be ready docker-compose up -d + docker run \ + --name ipfs-test-network \ + --detach \ + --publish 9301:5001 \ + --network cloudbuild \ + eu.gcr.io/opensourcecoin/ipfs-test-network docker network connect cloudbuild radicle-server_radicle-server_1 --alias radicle-server + sleep 3 # Wait for service to be booted + # Add the empty entry to the IPFS test network. Radicle requires it + echo '{"radicle": true}' | docker exec -i ipfs-test-network ipfs dag put --pin + docker container inspect ipfs-test-network - - id: "radicle-server integration test" + - id: "Integration tests" waitFor: - - "Start and expose radicle-server" + - "Start radicle-server and IPFS daemon" name: 'haskell:8.6.3' env: ['STACK_ROOT=/workspace/.stack'] entrypoint: 'bash' @@ -146,7 +157,7 @@ steps: - | set -euxo pipefail stack exec -- radicle - <<<'(load! "rad/examples/counter.rad") (counter/run-test)' - stack exec -- radicle test/server.rad radicle-server + IPFS_API_URL=http://ipfs-test-network:5001 stack exec -- radicle test/machine-backends.rad radicle-server - id: "Save cache" waitFor: diff --git a/exe/RadicleExe.hs b/exe/RadicleExe.hs index c62fb8b83..913024814 100644 --- a/exe/RadicleExe.hs +++ b/exe/RadicleExe.hs @@ -10,6 +10,7 @@ import System.Directory (doesFileExist) import Radicle import Radicle.Internal.Effects (exitCode) import Radicle.Internal.MachineBackend.EvalServer +import Radicle.Internal.MachineBackend.Ipfs (ipfsPrimFns) import Radicle.Internal.Pretty (putPrettyAnsi) main :: IO () @@ -88,5 +89,5 @@ opts = Opts createBindings :: (MonadIO m, ReplM m) => [Text] -> IO (Bindings (PrimFns m)) createBindings scriptArgs' = do - machineBackendPrimFns <- createEvalServerBackendPrimFns - pure $ addPrimFns (replPrimFns scriptArgs' <> machineBackendPrimFns) pureEnv + evalServerPackendPrimFns <- createEvalServerBackendPrimFns + pure $ addPrimFns (replPrimFns scriptArgs' <> evalServerPackendPrimFns <> ipfsPrimFns) pureEnv diff --git a/package.yaml b/package.yaml index 173e2b64d..7572c1648 100644 --- a/package.yaml +++ b/package.yaml @@ -30,21 +30,25 @@ library: - generics-eot - haskeline - http-client + - ipld-cid - megaparsec + - microlens - mtl - pointed - prettyprinter - prettyprinter-ansi-terminal - process - - servant - - servant-client + - safe-exceptions - scientific - serialise + - servant + - servant-client - template-haskell - text - time - unordered-containers - uuid + - wreq tests: spec: diff --git a/rad/prelude/chain.rad b/rad/prelude/chain.rad index 212ae94c7..966af7d7f 100644 --- a/rad/prelude/chain.rad +++ b/rad/prelude/chain.rad @@ -10,29 +10,43 @@ (import prelude/basic :unqualified) (import prelude/io :unqualified) (import prelude/patterns :unqualified) +(import prelude/strings :unqualified) +(import prelude/seq :unqualified) + +(def base-send! + "See documentation of `send!`" + (fn [id inputs] + (match id + (/prefix "ipfs://" 'rest) (machine/ipfs/update! rest inputs) + (/prefix "http://" _) (machine/eval-server/update! id inputs) + _ (throw 'unknown-machine-type (string-append "Cannot handle machine ID " id))) + )) -;; Chains: Functions for dealing with chains. - -;; A chain is conceptually: -;; - A known starting state (i.e. environment, and the assumption that `eval -;; == base-eval') -;; - A sequence of inputs. - +(def primitive-stub-ref/send! (ref base-send!)) (def send! "Update a machine with the vector of `inputs` to evaluate. Returns an index that identifies that last input. This index can be passed to `receive!`" - (fn [machine-id inputs] - (machine/eval-server/update! machine-id inputs))) + (fn [machine-id inputs] ((read-ref primitive-stub-ref/send!) machine-id inputs))) + +(def base-receive! + "See documentation of `receive!`" + (fn [id index] + (match id + (/prefix "ipfs://" 'rest) (machine/ipfs/get-log! rest index) + (/prefix "http://" _) (machine/eval-server/get-log! id index) + _ (throw 'unknown-machine-type (string-append "Cannot handle machine ID " id))) + )) +(def primitive-stub-ref/receive! (ref base-receive!)) (def receive! "Get inputs from a machine. Returns a `[index inputs]` pair where `inputs` is a vector of expressions and `index` is the index of the last input in `inputs`. The `index` argument is either `:nothing` in which case all inputs are fetched or `[:just i]` in which case all inputs following after the index `i` are fetched." - (fn [machine-id index] - (machine/eval-server/get-log! machine-id index))) + (fn [machine-id index] ((read-ref primitive-stub-ref/receive!) machine-id index))) + (def env-var "A lens for variables in envs." diff --git a/rad/prelude/test.rad b/rad/prelude/test.rad index e2a81ed15..8e16ca1ce 100644 --- a/rad/prelude/test.rad +++ b/rad/prelude/test.rad @@ -126,7 +126,7 @@ #t ) [:error 'msg] (do - (put-str! (string-append "not ok " (show index) " - " name)) + (put-str! (string-append "not ok " (show index) " - " name "\n" (show msg))) #f ) ))))) diff --git a/rad/tests/stub-primitives.rad b/rad/tests/stub-primitives.rad index 1b448b24b..c802c3037 100644 --- a/rad/tests/stub-primitives.rad +++ b/rad/tests/stub-primitives.rad @@ -9,17 +9,6 @@ ;; ;; See `prelude/chain/install-remote-chain-fake` for how to use primitve stubs. -;; send! -(def primitive-stub-ref/send! (ref machine/eval-server/update!)) -(def machine/eval-server/update! - (fn [a b] ((read-ref primitive-stub-ref/send!) a b))) - -;; receive! -(def primitive-stub-ref/receive! (ref machine/eval-server/get-log!)) -(def machine/eval-server/get-log! - (fn [a b] ((read-ref primitive-stub-ref/receive!) a b))) - - ;; now! (def primitive-stub-ref/now! (ref now!)) (def now! diff --git a/snapshot.yaml b/snapshot.yaml index e07c151a2..5cf3afe6c 100644 --- a/snapshot.yaml +++ b/snapshot.yaml @@ -9,6 +9,19 @@ name: radicle-deps-13.2 resolver: lts-13.2 packages: +- base58-bytestring-0.1.0@sha256:a1da72ee89d5450bac1c792d9fcbe95ed7154ab7246f2172b57bd4fd9b5eab79 - cborg-0.2.1.0 -- serialise-0.2.1.0 - github-0.20 +- sandi-0.4.3@sha256:2ada9c759424f243095ab28b55687cdec4e9d16bac3589f9d200280207c50216 +- serialise-0.2.1.0 +- git: https://github.com/oscoin/ipfs.git + commit: 19b25fa4d0003b5c2027c8cc1b8a3c36ac2f9f60 + subdirs: + - ipld-cid + - binary-varint + - multibase + - multihash-cryptonite + +flags: + sandi: + with-conduit: false diff --git a/src/Radicle/Internal/MachineBackend/Ipfs.hs b/src/Radicle/Internal/MachineBackend/Ipfs.hs new file mode 100644 index 000000000..5b651fda4 --- /dev/null +++ b/src/Radicle/Internal/MachineBackend/Ipfs.hs @@ -0,0 +1,318 @@ +-- | This module implements an IPFS machine backend. +-- +-- Radicle Machines are identified by IPNS IDs. The IPNS ID of a +-- machine points to a linked listed of expressions encoded as content +-- addressed IPLD documents and stored in IPFS’s DAG API. The nodes of +-- linked lists are represented by 'MachineEntry'. The corresponding +-- IPLD documents have the following shape. +-- @ +-- { +-- "expressions": [ +-- "(def foo :hey)", +-- "(get-value)" +-- ], +-- "previous": { "/": "QmA..." } +-- } +-- @ +-- +module Radicle.Internal.MachineBackend.Ipfs + ( ipfsPrimFns + ) where + +import Protolude hiding (TypeError, catch, try) + +import Control.Exception.Safe +import Control.Monad.Fail +import Data.Aeson (FromJSON, ToJSON, (.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.IPLD.CID +import qualified Data.Text as T +import Lens.Micro ((.~), (^.)) +import Network.HTTP.Client + (HttpException(..), HttpExceptionContent(..)) +import qualified Network.Wreq as Wreq +import System.Environment (lookupEnv) + +import Radicle +import Radicle.Internal.Core +import Radicle.Internal.MachineBackend.Interface +import qualified Radicle.Internal.PrimFns as PrimFns + +-- | Primitive functions for the IPFS machine backend and the primitive +-- function @machine/ipfs/create!@. +ipfsPrimFns :: MonadIO m => PrimFns m +ipfsPrimFns = + PrimFns.addPrimFn (unsafeToIdent createFnName) createFnDoc fn $ + buildMachineBackendPrimFns ipfsMachineBackend + where + createFnName = "machine/ipfs/create!" + createFnDoc = + "Create an IPFS machine and return its ID. Takes a local alias\ + \ for the machine as an argument. To avoid conflicts this should\ + \ be a UUID in production use." + fn = PrimFns.oneArg createFnName $ \case + String name -> + liftIO (ipfsMachineCreate name) >>= \case + Left err -> throwErrorHere $ OtherError err + Right machineId -> pure $ String machineId + v -> throwErrorHere $ TypeError createFnName 0 TString v + + +-- | Create a Radicle machine and return its identifier. The argument +-- is the name to store with the returned key on the local. It is not +-- portable. To avoid conflicts it is recommended to use a UUID. +ipfsMachineCreate :: Text -> IO (Either Text IpnsId) +ipfsMachineCreate name = do + res <- liftIO $ tryAny $ do + IpfsKeyGenResponse machineId <- ipfsKeyGen name + namePublish machineId $ IpfsAddressIpfs emtpyMachineCid + pure machineId + pure $ first (toS . displayException) res + + +data IpfsException + = IpfsException Text + -- | JSON response from the IPFS Api cannot be parsed. First + -- argument is the request path, second argument the JSON parsing + -- error + | IpfsExceptionInvalidResponse Text Text + -- | The IPFS daemon is not running. + | IpfsExceptionNoDaemon + deriving (Show, Eq) + +instance Exception IpfsException where + displayException (IpfsException msg) = "ipfs: " <> toS msg + displayException IpfsExceptionNoDaemon = "ipfs: Daemon not reachable, run 'rad ipfs daemon" + displayException (IpfsExceptionInvalidResponse url _) = "ipfs: Cannot parse IPFS daemon response for " <> toS url + + +newtype MachineEntryIndex = MachineEntryIndex CID + deriving (Show, Eq) + +instance (CPA t) => ToRad t MachineEntryIndex where + toRad (MachineEntryIndex cid) = String $ cidToText cid + +instance (CPA t) => FromRad t MachineEntryIndex where + fromRad (String cid) = + case cidFromText cid of + Left err -> Left $ toS err + Right cid' -> Right $ MachineEntryIndex cid' + fromRad _ = Left "IPFS entry index must be a string" + + +ipfsMachineBackend :: MonadIO m => MachineBackend MachineEntryIndex m +ipfsMachineBackend = + MachineBackend + { machineType = "ipfs" + , machineUpdate = + \id values -> do + res <- liftIO $ tryAny $ sendIpfs id values + pure $ first (toS . displayException) res + , machineGetLog = + \id maybeFrom -> do + res <- liftIO $ tryAny $ receiveIpfs id maybeFrom + pure $ first (toS . displayException) res + } + +sendIpfs :: Text -> Seq Value -> IO MachineEntryIndex +sendIpfs ipnsId values = do + IpfsNameResolveResponse cid <- nameResolve ipnsId + IpfsDagPutResponse newEntryCid <- dagPut $ MachineEntry (toList values) cid + namePublish ipnsId $ IpfsAddressIpfs newEntryCid + pure $ MachineEntryIndex newEntryCid + +receiveIpfs :: IpnsId -> Maybe MachineEntryIndex -> IO (MachineEntryIndex, [Value]) +receiveIpfs ipnsId maybeFrom = do + let MachineEntryIndex fromCid = fromMaybe (MachineEntryIndex emtpyMachineCid) maybeFrom + IpfsNameResolveResponse cid <- nameResolve ipnsId + blocks <- getBlocks cid fromCid + pure $ (MachineEntryIndex cid, blocks) + where + getBlocks :: CID -> CID -> IO [Value] + getBlocks cid fromCid = do + if cid == fromCid || cid == emtpyMachineCid + then pure [] + else do + entry <- dagGet (IpfsAddressIpfs cid) + rest <- getBlocks (entryPrevious entry) fromCid + pure $ rest <> entryExpressions entry + +-- | If a machine points to this ID then its log is considered empty. +-- The first entry in a machine log also points to this entry. +-- +-- This is the CID produced by the document @{"radicle": true}@. +emtpyMachineCid :: CID +emtpyMachineCid = + case cidFromText "zdpuAyyGtvC37aeZid2zh7LAGKCbFTn9MzdqoPpbNQm3BCwWT" of + Left e -> panic $ toS e + Right cid -> cid + +-- | A node in the linked list of expressions of a machine. +data MachineEntry = MachineEntry + { entryExpressions :: [Value] + , entryPrevious :: CID + } deriving (Eq, Show, Read, Generic) + +instance FromJSON MachineEntry where + parseJSON = Aeson.withObject "MachineEntry" $ \o -> do + expressionCode <- o .: "expression" + let src = "[ipfs]" + entryExpressions <- + case parseValues src expressionCode of + Left err -> fail $ "failed to parse Radicle expression: " <> show err + Right v -> pure v + entryPrevious <- parseIpldLink =<< o .: "previous" + pure MachineEntry {..} + +instance ToJSON MachineEntry where + toJSON MachineEntry{..} = + let code = T.intercalate "\n" $ map renderCompactPretty entryExpressions + in Aeson.object + [ "expression" .= code + , "previous" .= ipldLink entryPrevious + ] + +-- | Given a CID @"abc...def"@ it returns a IPLD link JSON object +-- @{"/": "abc...def"}@. +ipldLink :: CID -> Aeson.Value +ipldLink cid = Aeson.object [ "/" .= cidToText cid ] + +-- | Parses JSON values of the form @{"/": "abc...def"}@ where +-- @"abc...def"@ is a valid CID. +parseIpldLink :: Aeson.Value -> Aeson.Parser CID +parseIpldLink = + Aeson.withObject "IPLD link" $ \o -> do + cidText <- o .: "/" + case cidFromText cidText of + Left e -> fail $ "Invalid CID: " <> e + Right cid -> pure cid + +-------------------------------------------------------------------------- +-- * IPFS types +-------------------------------------------------------------------------- + +type IpnsId = Text + +-- | Addresses either an IPFS content ID or an IPNS ID. +data IpfsAddress + = IpfsAddressIpfs CID + | IpfsAddressIpns IpnsId + deriving (Eq, Show, Read, Generic) + +-- This is the same representation of IPFS paths as used by the IPFS CLI and +-- daemon. Either @"/ipfs/abc...def"@ or @"/ipns/abc...def"@. +ipfsAddressToText :: IpfsAddress -> Text +ipfsAddressToText (IpfsAddressIpfs cid) = "/ipfs/" <> cidToText cid +ipfsAddressToText (IpfsAddressIpns ipnsId) = "/ipns/" <> ipnsId + +-- | Partial inverse of 'ipfsAddressToText'. +ipfsAddressFromText :: Text -> Maybe IpfsAddress +ipfsAddressFromText t = + (IpfsAddressIpfs <$> maybeIpfsAddress) + <|> (IpfsAddressIpns <$> T.stripPrefix "/ipns/" t) + where + maybeIpfsAddress = do + cidText <- T.stripPrefix "/ipfs/" t + case cidFromText cidText of + Left _ -> Nothing + Right cid -> Just cid + + +-------------------------------------------------------------------------- +-- * IPFS node API +-------------------------------------------------------------------------- + +newtype IpfsKeyGenResponse = IpfsKeyGenResponse IpnsId + +ipfsKeyGen :: Text -> IO IpfsKeyGenResponse +ipfsKeyGen name = ipfsHttpGet "key/gen" [("arg", name), ("type", "ed25519")] + +instance FromJSON IpfsKeyGenResponse where + parseJSON = Aeson.withObject "ipfs key/gen" $ \o -> + IpfsKeyGenResponse <$> o .: "Id" + + +newtype IpfsDagPutResponse + = IpfsDagPutResponse CID + +dagPut :: ToJSON a => a -> IO IpfsDagPutResponse +dagPut obj = ipfsHttpPost "dag/put?pin=true" "arg" (Aeson.encode obj) + +instance FromJSON IpfsDagPutResponse where + parseJSON = Aeson.withObject "v0/dag/put response" $ \o -> do + cidObject <- o .: "Cid" + cidText <- cidObject .: "/" + case cidFromText cidText of + Left _ -> fail "invalid CID" + Right cid -> pure $ IpfsDagPutResponse cid + + +dagGet :: FromJSON a => IpfsAddress -> IO a +dagGet addr = do + result <- ipfsHttpGet "dag/get" [("arg", ipfsAddressToText addr)] + case Aeson.fromJSON result of + Aeson.Error _ -> throw $ IpfsException $ "Invalid machine log entry at " <> ipfsAddressToText addr + Aeson.Success a -> pure a + +namePublish :: IpnsId -> IpfsAddress -> IO () +namePublish ipnsId addr = do + _ :: Aeson.Value <- ipfsHttpGet "name/publish" [("arg", ipfsAddressToText addr), ("key", ipnsId)] + pure () + + +newtype IpfsNameResolveResponse + = IpfsNameResolveResponse CID + +nameResolve :: IpnsId -> IO IpfsNameResolveResponse +nameResolve ipnsId = ipfsHttpGet "name/resolve" [("arg", ipnsId), ("recursive", "true")] + +instance FromJSON IpfsNameResolveResponse where + parseJSON = Aeson.withObject "v0/name/resolve response" $ \o -> do + path <- o .: "Path" + case ipfsAddressFromText path of + Nothing -> fail "invalid IPFS path" + Just (IpfsAddressIpfs cid) -> pure $ IpfsNameResolveResponse cid + Just _ -> fail "expected /ipfs path" + + +-------------------------------------------------------------------------- +-- * IPFS Internal +-------------------------------------------------------------------------- + +ipfsHttpGet + :: FromJSON a + => Text -- ^ Path of the endpoint under "/api/v0/" + -> [(Text, Text)] -- ^ URL query parameters + -> IO a +ipfsHttpGet path params = do + let opts = Wreq.defaults & Wreq.params .~ params + url <- ipfsApiUrl path + res <- Wreq.getWith opts (toS url) `catch` handleRequestException + jsonRes <- Wreq.asJSON res `catch` handleParseException path + pure $ jsonRes ^. Wreq.responseBody + +ipfsHttpPost + :: FromJSON a + => Text -- ^ Path of the endpoint under "/api/v0/" + -> Text -- ^ Name of the argument for payload + -> LByteString -- ^ Payload argument + -> IO a +ipfsHttpPost path payloadArgName payload = do + url <- ipfsApiUrl path + res <- Wreq.post (toS url) (Wreq.partLBS payloadArgName payload) `catch` handleRequestException + jsonRes <- Wreq.asJSON res `catch` handleParseException path + pure $ jsonRes ^. Wreq.responseBody + +ipfsApiUrl :: Text -> IO Text +ipfsApiUrl path = do + baseUrl <- fromMaybe "http://localhost:9301" <$> lookupEnv "IPFS_API_URL" + pure $ toS baseUrl <> "/api/v0/" <> path + +handleRequestException :: MonadThrow m => HttpException -> m a +handleRequestException (HttpExceptionRequest _ (ConnectionFailure _)) = + throw IpfsExceptionNoDaemon +handleRequestException ex = throw ex + +handleParseException :: MonadCatch m => Text -> Wreq.JSONError -> m a +handleParseException path (Wreq.JSONError msg) = throw $ IpfsExceptionInvalidResponse path (toS msg) diff --git a/src/Radicle/Internal/PrimFns.hs b/src/Radicle/Internal/PrimFns.hs index 9dc88df4a..d4e21c55e 100644 --- a/src/Radicle/Internal/PrimFns.hs +++ b/src/Radicle/Internal/PrimFns.hs @@ -54,6 +54,12 @@ addPrimFns primFns bindings = [ (pfn, Doc.Docd d (PrimFn pfn)) | (pfn, Doc.Docd d _) <- Map.toList (getPrimFns primFns)] +addPrimFn :: Ident -> Text -> ([Value] -> Lang m Value) -> PrimFns m -> PrimFns m +addPrimFn name doc run (PrimFns primFns) = PrimFns primFns' + where + primFns' = Map.insert name (Doc.Docd (Just doc) run) primFns + + -- | The universal primops. These are available in chain evaluation. purePrimFns :: forall m. (Monad m) => PrimFns m purePrimFns = fromList $ allDocs $ diff --git a/stack.yaml b/stack.yaml index a95243ab8..ab212376d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,6 +49,7 @@ docker: # The default "host" does not work if the host version of stack is # not statically linked, which is the case on Arch. stack-exe: download + repo: fpco/stack-build:lts-12.9 # Extra package databases containing global packages # extra-package-dbs: [] diff --git a/test/machine-backends.rad b/test/machine-backends.rad new file mode 100644 index 000000000..ed79c9ff2 --- /dev/null +++ b/test/machine-backends.rad @@ -0,0 +1,87 @@ +#!/usr/bin/env radicle +;; +;; Test correctness of the IPFS and eval-server machine backends. +;; +;; This script tests that the HTTP server and IPFS implement the +;; machine backend protocol with `machine/eval-server/update!` and +;; `machine/eval-server/get-log!` properly. +;; +;; The script accepts the hostname of the server as an optional argument. The +;; hostname defaults to `localhost`. We always use port 8000. +;; + + +(load! "rad/prelude.rad") + +(import prelude/patterns '[/cons] :unqualified) +(import prelude/test '[assert-equal] :unqualified) +(import prelude/test :as 'test) + +(def host + (match (get-args!) + (/cons 'h _) h + /nil "localhost" + )) + +(def exprs-1 [ :e1 :e2 ]) +(def exprs-2 [ :f1 :f2 :f3 ]) + +(def server-backend { + :update! machine/eval-server/update! + :get-log! machine/eval-server/get-log! + :create! (fn [] (string-append "http://" host ":8000/chains/" (uuid!))) + }) + +(def ipfs-backend { + :update! machine/ipfs/update! + :get-log! machine/ipfs/get-log! + :create! (fn [] (machine/ipfs/create! (uuid!))) + }) + +(def tests + (fn [name backend] + (def update! (lookup :update! backend)) + (def create! (lookup :create! backend)) + (def get-log! (lookup :get-log! backend)) + (test/make-suite name { + "receive-all" + ;; Passing `:nothing` to `get-log!` returns all expressions + (fn [] + (def machine-id (create!)) + (update! machine-id exprs-1) + (update! machine-id exprs-2) + (def all-exprs (<> exprs-1 exprs-2)) + (match (get-log! machine-id :nothing) + [_ 'received-exprs] (assert-equal received-exprs all-exprs)) + ) + + "receive-last-index" + ;; Passing the last index from `update!` to `get-log!` returns no expressions + (fn [] + (def machine-id (create!)) + (def index (update! machine-id exprs-1)) + (match (get-log! machine-id [:just index]) + [_ 'received-exprs] (assert-equal received-exprs [])) + ) + "receive-with-index" + ;; Passing an index from `update!` to `get-log!` returns no expressions + (fn [] + (def machine-id (create!)) + (def index (update! machine-id exprs-1)) + (update! machine-id exprs-2) + (match (get-log! machine-id [:just index]) + [_ 'received-exprs] (assert-equal received-exprs exprs-2)) + ) + "receive-returns-sent-index" + ;; `get-log!` returns the last sent index + (fn [] + (def machine-id (create!)) + (def index-send (update! machine-id exprs-1)) + (match (get-log! machine-id :nothing) + ['index-receive _] (assert-equal index-receive index-send)) + ) + }) + )) + +(def tests-ok (test/run-all (<> (tests "server" server-backend) (tests "ipfs" ipfs-backend)))) +(if tests-ok (exit! 0) (exit! 1)) diff --git a/test/server.rad b/test/server.rad deleted file mode 100644 index 8a5758a83..000000000 --- a/test/server.rad +++ /dev/null @@ -1,78 +0,0 @@ -#!/usr/bin/env radicle -;; -;; Test correctness of the storage interface provided by the server. -;; -;; This script tests that the HTTP server implements the storage protocol with -;; `machine/eval-server/update!` and `machine/eval-server/get-log!` properly. -;; -;; The script accepts the hostname of the server as an optional argument. The -;; hostname defaults to `localhost`. We always use port 8000. -;; - - -(load! "rad/prelude.rad") - -(import prelude/patterns '[/cons] :unqualified) -(import prelude/test '[assert-equal] :unqualified) -(import prelude/test :as 'test) - -(def host - (match (get-args!) - (/cons 'h _) h - /nil "localhost" - )) - -(def create-machine - (fn [] - (string-append "http://" host ":8000/chains/" (uuid!)) - )) - -(def exprs-1 [ :e1 :e2 ]) -(def exprs-2 [ :f1 :f2 :f3 ]) - -(def test/receive-all - "Passing `:nothing` to `machine/eval-server/get-log!` returns all expressions" - (fn [] - (def machine-id (create-machine)) - (machine/eval-server/update! machine-id exprs-1) - (machine/eval-server/update! machine-id exprs-2) - (def all-exprs (<> exprs-1 exprs-2)) - (match (machine/eval-server/get-log! machine-id :nothing) - [_ 'received-exprs] (assert-equal received-exprs all-exprs)) - )) - -(def test/receive-last-index - (fn [] - "Passing the last index from `machine/eval-server/update!` to `machine/eval-server/get-log!` returns no expressions" - (def machine-id (create-machine)) - (def index (machine/eval-server/update! machine-id exprs-1)) - (match (machine/eval-server/get-log! machine-id [:just index]) - [_ 'received-exprs] (assert-equal received-exprs [])) - )) - -(def test/receive-with-index - (fn [] - "Passing an index from `machine/eval-server/update!` to `machine/eval-server/get-log!` returns no expressions" - (def machine-id (create-machine)) - (def index (machine/eval-server/update! machine-id exprs-1)) - (machine/eval-server/update! machine-id exprs-2) - (match (machine/eval-server/get-log! machine-id [:just index]) - [_ 'received-exprs] (assert-equal received-exprs exprs-2)) - )) - -(def test/receive-returns-sent-index - "`machine/eval-server/get-log!` returns the last sent index" - (fn [] - (def machine-id (create-machine)) - (def index-send (machine/eval-server/update! machine-id exprs-1)) - (match (machine/eval-server/get-log! machine-id :nothing) - ['index-receive _] (assert-equal index-receive index-send)) - )) - - -(test/run-all (test/make-suite "server-machine-backend" { - "receive-all" test/receive-all - "receive-last-index" test/receive-last-index - "receive-with-index" test/receive-with-index - "receive-returns-sent-index" test/receive-returns-sent-index - })) diff --git a/test/spec/Radicle/Tests.hs b/test/spec/Radicle/Tests.hs index e3a9273c8..3cc68a6fb 100644 --- a/test/spec/Radicle/Tests.hs +++ b/test/spec/Radicle/Tests.hs @@ -838,7 +838,7 @@ test_macros :: [TestTree] test_macros = [ testCase ":enter-chain keeps old bindings" $ do let input = [ "(def x 0)" - , "(:enter-chain \"blah\")" + , "(:enter-chain \"http://blah\")" , "(def x 1)" , ":quit" , "x"