phino 0.0.117 → 0.0.118

raw patch · 8 files changed

+986/−274 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +126/−54
• phino.cabal +1/−1
• src/Atoms.hs +356/−136
• src/CLI/Parsers.hs +1/−1
• src/CLI/Runners.hs +19/−8
• test/AtomsSpec.hs +379/−54
• test/CLISpec.hs +12/−1
• test/Fixtures.hs +92/−19

@@ -104,72 +104,128 @@  Which λ functions exist is a property of the object model being dataized, not of the calculus, so `phino` implements none of them. They come from a JSON-registry given with `--atoms`, keyed by λ name:+registry given with `--atoms`, keyed by regular expressions over λ names:  ```json {   "L_number_plus": {     "rt": "node",-    "script": "const fs = require('fs'); ..."+    "script": "const readline = require('readline'); ..."   } } ``` -The `rt` field names the executable the `script` is run under. Only `node` is-supported for now; a registry naming any other runtime is refused when the file-is read, before dataization starts.+The `rt` field names the interpreter the `script` is run under. Only `node` is+supported for now; a registry naming any other interpreter is refused when the+file is read, before dataization starts.  When 𝔼 reaches a λ function the registry carries, `phino` writes its `script`-to a temporary file and runs it as a POSIX process under that interpreter, with-the λ name as the first command-line argument:+to a temporary file and runs it as a POSIX process under that interpreter:  ```text-node /tmp/phino-atom-4f2a.js L_number_plus+node /tmp/phino-atom-4f2a.js ``` -The name matters: one script may be registered under several λ names and branch-on it, which is where `node` puts it — `process.argv[2]`. The script is then-fed one JSON object on `stdin`:+An atom that is already a program needs no interpreter and no staging. Such an+entry says `exec` and gives a `path` instead of a `script`:  ```json {-  "b": "⟦ x ↦ Φ.number( as-bytes ↦ … ), ρ ↦ ⟦ … ⟧ ⟧",-  "s": "⟦ bytes ↦ ⟦ … ⟧, number ↦ ⟦ … ⟧, φ ↦ … ⟧"+  "L_number_plus": {+    "rt": "exec",+    "path": "/opt/eo/atoms/number-plus"+  } } ``` -Here `b` is the formation being evaluated, with its λ binding removed so that-the script may dispatch on it, and `s` is the universe Φ. Both are canonical-𝜑-calculus on a single line — no syntax sugar, whatever `--sweet` says about-the output of the run — so a script never has to know about `phino`'s sugar in-order to find a datum: every byte array is spelled out as a Δ binding.+`phino` spawns that file directly, as the executable binary it is, with no+arguments. A `path` that names no file, or a file nobody may run, is refused+where the registry is read, together with the unknown runtimes. -The script writes one JSON object to `stdout`:+Whichever way it is run, the program is talked to over `stdin` and `stdout`,+one JSON object per line, in the letters of the evaluation rule of the+[𝜑-calculus paper](https://github.com/objectionary/calculus-paper),+𝔼(𝑏, 𝑒, 𝑠) = 𝑛, where 𝑏 is the formation, 𝑒 the universe and 𝑛 the normal+form the atom answers with: -```json-{ "n": "11" }+```text+{"𝑒": "⟦ bytes ↦ ⟦ … ⟧, number ↦ ⟦ … ⟧, φ ↦ … ⟧"}+{"id": 1, "λ": "L_number_plus", "𝑏": "⟦ x ↦ Φ.number( … ), ρ ↦ ⟦ … ⟧ ⟧"}+{"id": 1, "𝑛": "11"} ``` -The `n` field is the 𝜑-expression the atom answers with, in any syntax-`phino`'s parser reads — syntax sugar included, so the `11` above and the-`Φ.number( … )` it stands for are the same answer. `phino` parses it back-and hands it to 𝔼 as the atom's raw result, normalizing it exactly as it-normalizes anything else, so `--evaluations`, `--partial` and `--max-steps`-keep working unchanged. A non-zero exit, output that is not JSON, a missing-`n` or an `n` that does not parse fails the run, with the script's own-`stderr` in the message.+The first two lines are `phino`'s, the third is the program's. The universe Φ+goes under `𝑒`, in a line of its own, before the first request. Then comes the+request: an `id`, the λ name under `λ` — one program may be registered under+several names and branch on it — and, under `𝑏`, the formation being+evaluated, with its λ binding removed. Both payloads are canonical 𝜑-calculus+on a single line — no syntax sugar, whatever `--sweet` says about the output of+the run — so a program never has to know about `phino`'s sugar in order to find+a datum: every byte array is spelled out as a Δ binding. -A λ name the registry does not carry has no λ function at all, so 𝔼 gets stuck-on it. Without `--atoms` the registry is empty and every atom gets stuck.+The program answers with one line carrying the same `id` and, under `𝑛`, the+𝜑-expression the atom answers with, in any syntax `phino`'s parser reads —+syntax sugar included, so the `11` above and the `Φ.number( … )` it stands for+are the same answer. `phino` parses it back and hands it to 𝔼 as the atom's+raw result, normalizing it exactly as it normalizes anything else, so+`--evaluations`, `--partial` and `--max-steps` keep working unchanged. +A program started for the fire is asked one request, always `id` 1, and its+`stdin` is closed behind it, so it may read its input whole or line by line, as+it pleases. It is waited for once it has answered, and a non-zero exit fails+the run. So does a reply that is not JSON, carries no `𝑛`, answers another+`id`, or an `𝑛` that does not parse, or a program that quits without+answering — always with the program's own `stderr` in the message.++Each key of the registry is a regular expression, and it must match the whole+λ name, so a plain name such as `L_number_plus` means that one atom and nothing+else, while `L_number_.*` stands for every atom of `number`. When 𝔼 reaches a+λ function, the keys are tried top to bottom, in the order the file lists them,+and the first one that matches is the entry fired, so a key placed above+another hides whatever the two have in common. A key that is not a regular+expression is refused where the registry is read.++A λ name no key matches has no λ function at all, so 𝔼 gets stuck on it.+Without `--atoms` the registry is empty and every atom gets stuck.++One process per fire is where a program that is slow to start — a JVM, say —+spends most of the run. An entry saying `serve` has `phino` start its program+once, on the first fire, and keep it for the rest of the run, whether it is a+`script` or a `path`. Together with a key that matches many names, this is how+one program stands for a whole object model without being spelled once per+atom:++```json+{+  "L_bytes_eq": {+    "rt": "node",+    "script": "const readline = require('readline'); ..."+  },+  ".*": {+    "rt": "exec",+    "path": "/opt/eo/atoms/resident",+    "serve": true+  }+}+```++Every λ name registered on the same program, under one key or under several,+is served by the same process, so there is one of it, however many atoms it+stands for. The lines are the same:+the program reads request after request off its `stdin`, each with the next+`id`, and answers each in turn. The universe is told again only when a fire+comes with a different one; the program keeps the last one it was told. When+the run is over, whatever it ended with, `phino` closes the program's `stdin`,+which is its cue to quit, and terminates it if it has not quit within a second.+ ### Reducing the operands of an atom -A script gets at the parts of `b` by calling `phino` again, so no API has to be-exposed for it. The `--inside` option is how it asks: the expression it names-is bound to a fresh synthetic attribute of the input expression, which the run-takes as the universe, normalized there, and then dataized. This is the same-trick `phino` plays internally whenever it has to reduce a sub-expression the-program does not contain:+A program gets at the parts of `𝑏` by calling `phino` again, so no API has to+be exposed for it. The `--inside` option is how it asks: the expression it+names is bound to a fresh synthetic attribute of the input expression, which+the run takes as the universe, normalized there, and then dataized. This is the+same trick `phino` plays internally whenever it has to reduce a sub-expression+the program does not contain:  ```bash $ phino dataize --atoms=atoms.json --inside='5.plus( 6 )' universe.phi@@ -177,33 +233,49 @@ ```  Here `universe.phi` is the 𝜑-program the atom is being fired inside — the very-text the script was handed as `s`, which it feeds back on `stdin`.+text the program was told under `𝑒`, which it feeds back on `stdin`.  So a `L_number_plus` that reduces its own operands reads like this:  ```js-const fs = require('fs');+const readline = require('readline'); const { execFileSync } = require('child_process');-const atom = process.argv[2];-if (atom !== 'L_number_plus') {-  throw new Error(`unsupported atom ${atom}`);-}-const { b, s } = JSON.parse(fs.readFileSync(0, 'utf8'));+let universe; const dataized = (expr) => execFileSync(   'phino',   ['dataize', '--atoms=atoms.json', `--inside=${expr}`],-  { input: s, encoding: 'utf8' }+  { input: universe, encoding: 'utf8' } ).trim();-const number = (expr) => Buffer.from(dataized(expr).replace(/-/g, ''), 'hex').readDoubleBE(0);-const sum = Buffer.alloc(8);-sum.writeDoubleBE(number(`${b}.ρ`) + number(`${b}.x`));-const hex = [...sum]-  .map((octet) => octet.toString(16).toUpperCase().padStart(2, '0'))-  .join('-');-process.stdout.write(JSON.stringify({-  n: `Φ.number( as-bytes ↦ Φ.bytes( data ↦ ⟦ Δ ⤍ ${hex} ⟧ ) )`-}));+const number = (expr) => Buffer+  .from(dataized(expr).replace(/-/g, ''), 'hex')+  .readDoubleBE(0);+const hex = (value) => {+  const bytes = Buffer.alloc(8);+  bytes.writeDoubleBE(value);+  return [...bytes]+    .map((octet) => octet.toString(16).toUpperCase().padStart(2, '0'))+    .join('-');+};+readline.createInterface({ input: process.stdin }).on('line', (line) => {+  const message = JSON.parse(line);+  if ('𝑒' in message) {+    universe = message['𝑒'];+    return;+  }+  if (message['λ'] !== 'L_number_plus') {+    throw new Error(`unsupported atom ${message['λ']}`);+  }+  const b = message['𝑏'];+  const sum = hex(number(`${b}.ρ`) + number(`${b}.x`));+  process.stdout.write(`${JSON.stringify({+    id: message.id,+    '𝑛': `Φ.number( as-bytes ↦ Φ.bytes( data ↦ ⟦ Δ ⤍ ${sum} ⟧ ) )`,+  })}\n`);+}); ```++Written this way, reading until its `stdin` closes, the same program runs once+per fire and serves the whole run alike; only the registry entry decides.  The `--inside` option cannot be combined with `--locator`, since it aims the run at the binding it mints itself. Both `dataize` and `morph` take `--atoms`

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino-version: 0.0.117+version: 0.0.118 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>

@@ -9,24 +9,44 @@ -- Which λ functions exist is a property of the object model being dataized, -- not of the calculus. phino therefore implements none of them: it reads a -- registry of them from a JSON file given with '--atoms' and fires each one as--- a POSIX process. The registry maps a λ name to the runtime that runs it and--- the script it runs:+-- a POSIX process. Each key of the registry is a regular expression over λ+-- names, tried top to bottom, and the first one matching the whole name of the+-- atom being fired wins; its entry names the runtime that runs a script, or+-- 'exec' and the path of a file that runs on its own, and says with 'serve'+-- whether the program is to be started once and kept for the run: -- -- > { -- >   "L_bytes_eq": { -- >     "rt": "node",--- >     "script": "const fs = require('fs'); ..."+-- >     "script": "const readline = require('readline'); ..."+-- >   },+-- >   "L_number_plus": {+-- >     "rt": "exec",+-- >     "path": "/opt/eo/atoms/number-plus"+-- >   },+-- >   ".*": {+-- >     "rt": "exec",+-- >     "path": "/opt/eo/atoms/resident",+-- >     "serve": true -- >   } -- > } ----- A name absent from the registry has no λ function at all: 𝔼 gets stuck on--- it, exactly as it does for a name no one ever declared (see 'Stuck' in--- 'Dataize').+-- Whichever way it is run, a program speaks one protocol, in the letters of the+-- evaluation rule of the calculus paper, 𝔼(𝑏, 𝑒, 𝑠) = 𝑛: one JSON object per+-- line, the universe under '𝑒', then a request with an 'id', the λ name under+-- 'λ' and the formation under '𝑏', answered by a line with the same 'id' and+-- the 𝜑-expression under '𝑛'.+--+-- A name no key matches has no λ function at all: 𝔼 gets stuck on it, exactly+-- as it does for a name no one ever declared (see 'Stuck' in 'Dataize'). module Atoms   ( Atom (..)   , AtomException (..)+  , Program (..)   , Registry   , Runtime (..)+  , Session (_program)+  , closeRegistry   , emptyRegistry   , fireAtom   , readRegistry@@ -36,11 +56,18 @@ where  import AST-import Control.Exception (Exception, bracket, catch, throwIO)-import Control.Monad (unless)-import Data.Aeson (FromJSON (parseJSON), eitherDecodeStrict', object, withObject, withText, (.:), (.=))+import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar)+import Control.Exception (Exception, SomeException, catch, onException, throwIO, try)+import Control.Monad (foldM, unless)+import Data.Aeson (FromJSON (parseJSON), eitherDecodeStrict', object, withObject, withText, (.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as A+import Data.Aeson.Decoding (toEitherValue)+import Data.Aeson.Decoding.ByteString (bsToTokens)+import Data.Aeson.Decoding.Tokens (TkRecord (TkPair, TkRecordEnd, TkRecordErr), Tokens (TkErr, TkRecordOpen))+import qualified Data.Aeson.Key as Key+import Data.Aeson.Types (JSONPathElement (Key), parseEither, (<?>)) import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BSL import Data.List (find, intercalate) import Data.Map.Strict (Map)@@ -54,38 +81,94 @@ import Parser (parseExpression) import Printer (printExpression') import Sugar (SugarType (SALTY))-import System.Directory (getTemporaryDirectory, removePathForcibly)+import System.Directory (doesFileExist, executable, getPermissions, getTemporaryDirectory, removePathForcibly) import System.Exit (ExitCode (ExitFailure, ExitSuccess))-import System.IO (Handle, IOMode (WriteMode), hClose, hSetBinaryMode, openBinaryTempFile, withBinaryFile)-import System.Process (CreateProcess (std_err, std_in, std_out), ProcessHandle, StdStream (CreatePipe, UseHandle), createProcess, proc, waitForProcess)+import System.IO (Handle, hClose, hFlush, hSetBinaryMode, openBinaryTempFile)+import System.Process (CreateProcess (std_err, std_in, std_out), ProcessHandle, StdStream (CreatePipe, UseHandle), createProcess, proc, terminateProcess, waitForProcess)+import System.Timeout (timeout) import Text.Printf (printf)+import Text.Regex.PCRE (matchTest)+import Text.Regex.PCRE.ByteString (Regex, compUTF8, compile, execBlank)  -- The interpreter a script is run under, named after the executable itself: -- only 'node' for now. A registry naming any other runtime is rejected when it -- is read, before dataization starts, so a run never gets half-way through a -- program to discover that one of its atoms cannot be run at all. data Runtime = RtNode+  deriving stock (Eq, Ord, Show)++-- How the program of an atom is started: as a script under the interpreter of+-- its runtime, which phino stages in a temporary file, or as an executable+-- file, which phino runs as it is, since the object model brought its own+-- binary and there is nothing to stage.+data Program+  = Scripted Runtime T.Text+  | Executable FilePath+  deriving stock (Eq, Ord, Show)++-- One λ function phino may fire: its program, either started afresh for every+-- fire and gone once it has answered, or kept in a session for the run, so+-- that one process answers every fire — which is what an entry saying 'serve'+-- asks for, and what a program that is slow to start needs.+data Atom+  = Transient Program+  | Resident Session   deriving stock (Eq, Show) --- One entry of the registry: the runtime and the source of the script.-data Atom = Atom-  { _runtime :: Runtime-  , _script :: T.Text+-- A program to be kept for the run, together with the process phino has+-- started of it, if it has: none until the first fire, since a run that never+-- reaches the atom should not pay for it. Every entry naming the same program+-- shares one session, so one process serves all the λ names it is registered+-- under.+data Session = Session+  { _program :: Program+  , _running :: MVar (Maybe Running)   }-  deriving stock (Eq, Show) --- Every λ function phino may fire, keyed by name.-type Registry = Map T.Text Atom+-- Two sessions are the same when they keep the same program, whatever their+-- processes are up to.+instance Eq Session where+  Session left _ == Session right _ = left == right +instance Show Session where+  show (Session program _) = show program++-- A program while it runs: its streams, the file its complaints go to, the+-- file its script is staged in, if it is a script, the universe it was told+-- last, so it is told again only when the universe changes, and how many+-- requests it has been asked, which numbers the next one.+data Running = Running+  { _input :: Handle+  , _output :: Handle+  , _process :: ProcessHandle+  , _complaints :: FilePath+  , _staged :: Maybe FilePath+  , _told :: Maybe Expression+  , _requests :: Int+  }++-- One entry of the registry, as the file spells it: the program and whether+-- it is to be kept for the run.+data Entry = Entry Program Bool++-- Every λ function phino may fire, in the order the registry file lists them:+-- each key of the file, a regular expression over λ names, paired with the+-- atom its entry describes. A lookup tries them top to bottom and the first+-- key matching the whole name wins, so one entry may stand for many atoms,+-- while a plain name, being a regular expression matching itself, keeps+-- meaning that one atom.+newtype Registry = Registry [(Regex, Atom)]+ data AtomException   = -- The '--atoms' file is not a JSON registry of λ functions.     BrokenRegistry FilePath String-  | -- The interpreter of a runtime is not installed, so no script of it can run.+  | -- The program of an atom cannot be run: the interpreter of its runtime is+    -- not installed, or its executable file is missing or not executable.     NoRuntime T.Text String String-  | -- The script exited with a non-zero status; the message carries its stderr.+  | -- The program exited with a non-zero status; the message carries its stderr.     AtomBroke T.Text Int String-  | -- The script exited successfully but said nothing phino can use: its stdout-    -- is not a JSON object, carries no 'n' field, or the 𝜑-expression under it+  | -- The program said nothing phino can use: its reply is not a JSON object,+    -- carries no 𝜑-expression, answers another request, or the 𝜑-expression     -- does not parse.     AtomMute T.Text String String   deriving anyclass (Exception)@@ -117,145 +200,282 @@ runtimes :: [Runtime] runtimes = [RtNode] +-- The 'rt' of an atom that is a file rather than a script: it names no+-- interpreter, because the file runs on its own.+execName :: String+execName = "exec"++-- Every name the 'rt' field of a registry entry may take. runtimeNames :: [String]-runtimeNames = map runtimeName runtimes+runtimeNames = map runtimeName runtimes ++ [execName]  instance FromJSON Runtime where   parseJSON = withText "runtime" $ \name -> case find ((== T.unpack name) . runtimeName) runtimes of     Just runtime -> pure runtime     Nothing -> fail (printf "unknown runtime '%s', expected one of: %s" (T.unpack name) (intercalate ", " runtimeNames)) -instance FromJSON Atom where-  parseJSON = withObject "atom" $ \entry -> Atom <$> entry .: "rt" <*> entry .: "script"+instance FromJSON Program where+  parseJSON = withObject "atom" $ \entry -> do+    named <- entry .: "rt"+    if named == execName+      then Executable <$> entry .: "path"+      else Scripted <$> parseJSON (A.String (T.pack named)) <*> entry .: "script" --- What the script writes to stdout: one JSON object whose 'n' field is the--- 𝜑-expression the atom answers with.-newtype Answer = Answer T.Text+-- The 'serve' field is optional and off by default: a program is started for+-- every fire unless the entry says otherwise.+instance FromJSON Entry where+  parseJSON value = Entry <$> parseJSON value <*> withObject "atom" (\entry -> entry .:? "serve" .!= False) value -instance FromJSON Answer where-  parseJSON = withObject "answer" $ \answer -> Answer <$> answer .: "n"+-- What a program writes back for one request: the 'id' of the request it+-- answers and, under '𝑛', the 𝜑-expression the atom answers with.+data Reply = Reply Int T.Text +instance FromJSON Reply where+  parseJSON = withObject "reply" $ \reply -> do+    number <- reply .: "id"+    raw <- reply .:? "𝑛"+    maybe (fail "there is no '𝑛' in it") (pure . Reply number) raw+ -- No λ function at all: every atom gets stuck. This is what a run without -- '--atoms' fires against. emptyRegistry :: Registry-emptyRegistry = Map.empty+emptyRegistry = Registry [] --- The λ function registered under this name, if any.+-- The λ function of the first key that matches the whole name, if any. registeredAtom :: Registry -> T.Text -> Maybe Atom-registeredAtom registry func = Map.lookup func registry+registeredAtom (Registry rules) func = snd <$> find (\(pattern, _) -> matchTest pattern (encodeUtf8 func)) rules --- Read the registry of λ functions from a JSON file. An unknown runtime, a--- missing 'script' or malformed JSON fails here, before any dataization--- starts.+-- Read the registry of λ functions from a JSON file. A key that is no regular+-- expression, an unknown runtime, a missing 'script', a 'path' that names no+-- executable file or malformed JSON fails here, before any dataization starts.+-- The entries that are to keep the same program are given one session between+-- them, so that one resident process answers for every key it is registered+-- under. readRegistry :: FilePath -> IO Registry readRegistry path = do   content <- BS.readFile path `catch` unreadable-  case eitherDecodeStrict' content of-    Left failure -> throwIO (BrokenRegistry path failure)-    Right registry -> do-      logDebug (printf "Loaded %d atom(s) from '%s'" (Map.size registry) path)-      pure registry+  entries <- either (throwIO . BrokenRegistry path) pure (listed content)+  mapM_ (uncurry runnable) entries+  (rules, _) <- foldM admitted ([], Map.empty) entries+  logDebug (printf "Loaded %d atom(s) from '%s'" (length rules) path)+  pure (Registry (reverse rules))   where     unreadable :: IOError -> IO BS.ByteString     unreadable failure = throwIO (BrokenRegistry path (show failure))+    -- The entries of the file in the order it lists them, which is the order+    -- the keys are tried in and which the object aeson would decode the file+    -- to forgets, so the file is walked token by token instead.+    listed :: BS.ByteString -> Either String [(T.Text, Entry)]+    listed content = case bsToTokens content of+      TkRecordOpen record -> paired record+      TkErr failure -> Left failure+      _ -> Left "the file is not a JSON object"+    paired :: TkRecord BS.ByteString String -> Either String [(T.Text, Entry)]+    paired (TkPair key tokens) = do+      (value, rest) <- toEitherValue tokens+      entry <- parseEither (\raw -> parseJSON raw <?> Key key) value+      ((Key.toText key, entry) :) <$> paired rest+    paired (TkRecordEnd rest)+      | BS.all (`BS.elem` " \t\r\n") rest = Right []+      | otherwise = Left "there is more in the file than the JSON object"+    paired (TkRecordErr failure) = Left failure+    -- The key as the regular expression it is, made to match the whole name,+    -- so that a plain name means that one atom and not every name it is a+    -- part of.+    compiled :: T.Text -> IO Regex+    compiled key = compile compUTF8 execBlank (encodeUtf8 ("^(?:" <> key <> ")$")) >>= either broken pure+      where+        broken :: (a, String) -> IO Regex+        broken (_, failure) = throwIO (BrokenRegistry path (printf "the key '%s' is not a regular expression: %s" (T.unpack key) failure))+    -- The file of an executable atom is the only thing phino knows about it,+    -- and it staged none of it, so the file is looked at here, while the+    -- registry is being read, rather than half-way through a program that+    -- turns out to name that atom.+    runnable :: T.Text -> Entry -> IO ()+    runnable func (Entry (Executable file) _) = do+      there <- doesFileExist file+      unless there (throwIO (NoRuntime func file "there is no such file"))+      allowed <- executable <$> getPermissions file+      unless allowed (throwIO (NoRuntime func file "the file is not executable"))+    runnable _ _ = pure ()+    -- Turn an entry into the atom phino fires, keyed by its pattern and, when+    -- it is to keep its program, sharing a session with the entries keeping+    -- the same one; the rules come out newest first.+    admitted :: ([(Regex, Atom)], Map Program Session) -> (T.Text, Entry) -> IO ([(Regex, Atom)], Map Program Session)+    admitted (rules, sessions) (key, Entry program serve) = do+      pattern <- compiled key+      (atom, kept) <- if serve then resident program sessions else pure (Transient program, sessions)+      pure ((pattern, atom) : rules, kept)+    resident :: Program -> Map Program Session -> IO (Atom, Map Program Session)+    resident program sessions = do+      session <- maybe (Session program <$> newMVar Nothing) pure (Map.lookup program sessions)+      pure (Resident session, Map.insert program session sessions) --- Fire the λ function 'func' by running its script as a POSIX process under--- the interpreter of its runtime, with the λ name as the first command-line--- argument — one script may be registered under several names and branch on--- it. The script is fed a JSON object on stdin (see 'payload') and answers--- with one on stdout; the 𝜑-expression under 'n' becomes the atom's raw--- result, which 𝔼 normalizes exactly as it normalized the answer of a built-in--- one. A non-zero exit, unparsable output or a missing 'n' fails the run.+-- Stop every resident program the registry has started: its stdin is closed,+-- which is its cue to quit, and a program that has not quit within a second is+-- terminated. The runners call this when the run is over, whatever it ended+-- with, so that no process outlives the phino that started it.+closeRegistry :: Registry -> IO ()+closeRegistry (Registry rules) = mapM_ (dismissed . snd) rules+  where+    dismissed :: Atom -> IO ()+    dismissed (Resident Session{..}) = modifyMVar_ _running (maybe (pure Nothing) (\running -> Nothing <$ stopped briefly running))+    dismissed _ = pure ()++-- Fire the λ function 'func' by asking its program. A transient program is+-- started for the fire and waited for once it has answered, so that its exit+-- status has its say; a resident one is started on the first fire and stays+-- for the run, kept whatever the fire ended with, so that 'closeRegistry'+-- finds it. Whichever way, the 𝜑-expression the program answers with becomes+-- the atom's raw result, which 𝔼 normalizes exactly as it normalized the+-- answer of a built-in one. fireAtom :: T.Text -> Atom -> Expression -> Expression -> IO Expression-fireAtom func Atom{..} form univ =-  withTemp (printf "phino-atom-.%s" (extension _runtime)) (encodeUtf8 _script) $ \script ->-    withTemp "phino-atom-.err" "" $ \errors -> do-      logDebug (printf "Firing atom '%s' as '%s %s %s'" (T.unpack func) (interpreter _runtime) script (T.unpack func))-      (status, answer) <- executed script errors-      complaint <- readErrors errors-      unless (null complaint) (logDebug (printf "Atom '%s' wrote to stderr: %s" (T.unpack func) complaint))-      case status of-        ExitFailure code -> throwIO (AtomBroke func code complaint)-        ExitSuccess -> answered answer+fireAtom func (Transient program) form univ = do+  running <- started func program+  (_, answer) <- asked func running form univ hClose `onException` stopped patiently running+  (status, complaint) <- stopped patiently running+  unless (null complaint) (logDebug (printf "Atom '%s' wrote to stderr: %s" (T.unpack func) complaint))+  case status of+    ExitFailure code -> throwIO (AtomBroke func code complaint)+    ExitSuccess -> pure answer+fireAtom func (Resident Session{..}) form univ = do+  outcome <- modifyMVar _running $ \current -> do+    running <- maybe (started func _program) pure current+    attempt <- try (asked func running form univ hFlush) :: IO (Either SomeException (Running, Expression))+    pure (Just (either (const running) fst attempt), snd <$> attempt)+  either throwIO pure outcome++-- Start the program, with its input and its output on pipes and its complaints+-- in a file that lives as long as the process does: a script is staged in a+-- temporary file first and handed to the interpreter of its runtime, an+-- executable file is run as it is. Every stream is bytes: a 𝜑 expression+-- carries characters no single-byte locale can spell, so nothing is left to+-- the locale.+started :: T.Text -> Program -> IO Running+started func program = do+  dir <- getTemporaryDirectory+  (complaints, handle) <- openBinaryTempFile dir "phino-atom-.err"+  (executable, arguments, staged) <- commanded dir+  logDebug (printf "Starting atom '%s' as '%s'" (T.unpack func) (unwords (executable : arguments)))+  (input, output, process) <- spawned executable arguments handle `onException` discarded complaints staged+  pure (Running input output process complaints staged Nothing 0)   where-    -- Run the interpreter with its input and its output on pipes and its-    -- complaints in a file. The input is written and closed before the output is-    -- read, so the parent never has two streams to drain at once — which would-    -- need threads to be safe — and the script's own stderr, which may be-    -- anything at all, cannot fill a pipe nobody is reading. Every stream is-    -- bytes: a 𝜑 expression carries characters no single-byte locale can spell,-    -- so nothing is left to the locale.-    executed :: FilePath -> FilePath -> IO (ExitCode, BS.ByteString)-    executed script errors =-      withBinaryFile errors WriteMode $ \stderr' -> do-        (stdin', stdout', process) <- spawned script stderr'-        hSetBinaryMode stdin' True-        hSetBinaryMode stdout' True-        -- A script that dies before reading its input leaves this write with-        -- nobody to drain it. The failure worth reporting is the one the script-        -- made, so a broken pipe is swallowed here and the exit status decides.-        BS.hPut stdin' (payload form univ) `catch` unheard-        hClose stdin' `catch` unheard-        answer <- BS.hGetContents stdout'-        status <- waitForProcess process-        pure (status, answer)-    spawned :: FilePath -> Handle -> IO (Handle, Handle, ProcessHandle)-    spawned script stderr' = do-      spawn <- createProcess started `catch` missing+    -- The command line the program is started with, and the file staged for+    -- it, if it is a script.+    commanded :: FilePath -> IO (String, [String], Maybe FilePath)+    commanded dir = case program of+      Executable file -> pure (file, [], Nothing)+      Scripted runtime script -> do+        (path, handle) <- openBinaryTempFile dir (printf "phino-atom-.%s" (extension runtime))+        BS.hPut handle (encodeUtf8 script)+        hClose handle+        pure (interpreter runtime, [path], Just path)+    spawned :: String -> [String] -> Handle -> IO (Handle, Handle, ProcessHandle)+    spawned executable arguments stderr' = do+      spawn <- createProcess (proc executable arguments){std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle stderr'} `catch` missing executable       case spawn of-        (Just stdin', Just stdout', _, process) -> pure (stdin', stdout', process)-        _ -> throwIO (AtomMute func "" "the interpreter gave phino no streams to talk over")-      where-        started :: CreateProcess-        started =-          (proc (interpreter _runtime) [script, T.unpack func])-            { std_in = CreatePipe-            , std_out = CreatePipe-            , std_err = UseHandle stderr'-            }-    missing :: IOError -> IO a-    missing failure = throwIO (NoRuntime func (interpreter _runtime) (show failure))-    unheard :: IOError -> IO ()-    unheard _ = pure ()-    -- Whatever the script complained about, decoded leniently: the stream is-    -- the script's, so it may hold anything at all.-    readErrors :: FilePath -> IO String-    readErrors errors = T.unpack . T.strip . decodeUtf8Lenient <$> BS.readFile errors-    -- Parse what the script said: a JSON object with the raw 𝜑-expression-    -- under 'n'.-    answered :: BS.ByteString -> IO Expression-    answered answer = case eitherDecodeStrict' answer of-      Left failure -> throwIO (AtomMute func spoken failure)-      Right (Answer raw) -> case parseExpression (T.unpack raw) of-        Left failure -> throwIO (AtomMute func (T.unpack raw) failure)-        Right expr -> pure expr-      where-        spoken :: String-        spoken = T.unpack (T.strip (decodeUtf8Lenient answer))+        (Just input, Just output, _, process) -> do+          hSetBinaryMode input True+          hSetBinaryMode output True+          pure (input, output, process)+        _ -> throwIO (AtomMute func "" "the program gave phino no streams to talk over")+    missing :: String -> IOError -> IO a+    missing executable failure = throwIO (NoRuntime func executable (show failure)) --- The JSON phino feeds a script on stdin: the formation being evaluated under--- 'b', with its λ binding removed so the script may dispatch on it, and the--- universe Φ under 's'. Both are rendered as canonical 𝜑-calculus on a single--- line — no syntax sugar, whatever '--sweet' says about the output of the run —--- so a script never has to know phino's sugar to find a datum: every byte array--- it may need is spelled out as a Δ binding. The text is what phino's own parser--- reads back, so a script may hand any part of it to another phino run (see the--- '--inside' option).-payload :: Expression -> Expression -> BS.ByteString-payload form univ = BSL.toStrict (A.encode (object ["b" .= rendered form, "s" .= rendered univ]))+-- Ask the running program to fire the λ function: it is told the universe,+-- unless it was told already, then the request, and its reply is read back.+-- How the request is pushed through is the caller's: a transient program has+-- its stdin closed behind it, since it may read its input whole before it+-- answers, a resident one has it flushed, since it reads on. A reply that is+-- not JSON, carries no '𝑛', answers another request, or a program that hangs+-- up fails the fire, with the program's stderr in the message.+asked :: T.Text -> Running -> Expression -> Expression -> (Handle -> IO ()) -> IO (Running, Expression)+asked func running@Running{..} form univ pushed = do+  let number = _requests + 1+      universe = lined (object ["𝑒" .= rendered univ])+      request = lined (object ["id" .= number, "λ" .= func, "𝑏" .= rendered form])+  logDebug (printf "Asking atom '%s' as request %d" (T.unpack func) number)+  said (if _told == Just univ then request else universe <> request)+  reply <- BC.hGetLine _output `catch` hungUp+  answer <- replied number reply+  pure (running{_told = Just univ, _requests = number}, answer)   where-    rendered :: Expression -> T.Text-    rendered expr = T.pack (printExpression' expr (SALTY, UNICODE, SINGLELINE, defaultMargin))+    -- A program that has died leaves the write with nobody to drain it. The+    -- failure worth reporting is the one the program made, so a broken pipe is+    -- swallowed here and the read that follows finds out.+    said :: BS.ByteString -> IO ()+    said content = (BS.hPut _input content >> pushed _input) `catch` unheard+    -- The program closed its stdout instead of answering: if it has quit with+    -- a failure, that is the failure; otherwise it went mute.+    hungUp :: IOError -> IO BS.ByteString+    hungUp _ = do+      status <- timeout 1000000 (waitForProcess _process)+      complaint <- readErrors _complaints+      case status of+        Just (ExitFailure code) -> throwIO (AtomBroke func code complaint)+        Just ExitSuccess -> throwIO (AtomMute func "" (unwords ("the program quit without answering" : [complaint | not (null complaint)])))+        Nothing -> throwIO (AtomMute func "" (unwords ("the program closed its stdout without answering" : [complaint | not (null complaint)])))+    -- Parse what the program said back: a JSON object answering this very+    -- request, with the raw 𝜑-expression under '𝑛'.+    replied :: Int -> BS.ByteString -> IO Expression+    replied number reply = case eitherDecodeStrict' reply of+      Left failure -> throwIO (AtomMute func (spoken reply) failure)+      Right (Reply echoed raw)+        | echoed /= number -> throwIO (AtomMute func (spoken reply) (printf "it answers request %d, while phino asked request %d" echoed number))+        | otherwise -> case parseExpression (T.unpack raw) of+            Left failure -> throwIO (AtomMute func (T.unpack raw) failure)+            Right expr -> pure expr --- Write the content to a fresh temporary file, hand its path to the action and--- delete the file afterwards, whatever the action does.-withTemp :: String -> BS.ByteString -> (FilePath -> IO a) -> IO a-withTemp template content action = do-  dir <- getTemporaryDirectory-  bracket (openBinaryTempFile dir template) discarded $ \(path, handle) -> do-    BS.hPut handle content-    hClose handle-    action path-  where-    discarded :: (FilePath, Handle) -> IO ()-    discarded (path, handle) = hClose handle >> removePathForcibly path+-- Hang up on the program: close its stdin, which is its cue to quit, wait for+-- it the given way and remove the files it was given, its complaints read+-- first, since they are what a failure is reported with.+stopped :: (Running -> IO ExitCode) -> Running -> IO (ExitCode, String)+stopped waited running@Running{..} = do+  hClose _input `catch` unheard+  status <- waited running+  hClose _output `catch` unheard+  complaint <- readErrors _complaints+  discarded _complaints _staged+  pure (status, complaint)++-- Wait for the program to quit for as long as it takes, draining whatever else+-- it writes, so that a chatty one never blocks on a full pipe: a transient+-- program is on its way out once it has answered, and its exit status is the+-- verdict on its answer.+patiently :: Running -> IO ExitCode+patiently Running{..} = BS.hGetContents _output >> waitForProcess _process++-- Wait for the program to quit for a second, then terminate it: a resident one+-- was told to quit and gets no say in the matter.+briefly :: Running -> IO ExitCode+briefly Running{..} = timeout 1000000 (waitForProcess _process) >>= maybe (terminateProcess _process >> waitForProcess _process) pure++-- Remove the files a program was given: the one its complaints went to and the+-- one its script was staged in, if it was a script.+discarded :: FilePath -> Maybe FilePath -> IO ()+discarded complaints staged = removePathForcibly complaints >> mapM_ removePathForcibly staged++-- Whatever the program said, decoded leniently and trimmed: the stream is the+-- program's, so it may hold anything at all.+spoken :: BS.ByteString -> String+spoken = T.unpack . T.strip . decodeUtf8Lenient++-- Whatever the program complained about, read from the file its stderr goes to.+readErrors :: FilePath -> IO String+readErrors errors = spoken <$> BS.readFile errors++unheard :: IOError -> IO ()+unheard _ = pure ()++-- One JSON object as one line, for the programs that read by the line.+lined :: A.Value -> BS.ByteString+lined value = BSL.toStrict (A.encode value) <> "\n"++-- An expression as canonical 𝜑-calculus on a single line — no syntax sugar,+-- whatever '--sweet' says about the output of the run — so a program never has+-- to know phino's sugar to find a datum: every byte array it may need is+-- spelled out as a Δ binding. The text is what phino's own parser reads back,+-- so a program may hand any part of it to another phino run (see the+-- '--inside' option).+rendered :: Expression -> T.Text+rendered expr = T.pack (printExpression' expr (SALTY, UNICODE, SINGLELINE, defaultMargin))

@@ -216,7 +216,7 @@             <> metavar "FILE"             <> help               ( printf-                  "Path to the JSON registry of λ functions this run may fire, mapping each name to the runtime that runs it (%s) and the script it runs"+                  "Path to the JSON registry of λ functions this run may fire, whose keys are regular expressions over λ names, tried top to bottom, each mapped to the runtime that runs it (%s), the script or the executable it runs and, with \"serve\", whether one process of it is to serve the whole run"                   (intercalate ", " runtimeNames)               )         )

@@ -8,6 +8,7 @@ module CLI.Runners where  import AST+import Atoms (closeRegistry) import CLI.Helpers import CLI.Types import CLI.Validators@@ -160,10 +161,15 @@       include = (`F.include` included)   save <- saveStepFunc _stepsDir printCtx   (outcome, chain) <--    withEvalFunc _evaluations printCtx $ \record -> do-      let ctx = DataizeContext loc _maxDepth _maxCycles (Steps _maxSteps 0) _depthSensitive _shuffle _partial atoms buildTerm save record-      (universe, aiming) <- aimed _inside expr ctx-      dataize universe aiming+    withEvalFunc+      _evaluations+      printCtx+      ( \record -> do+          let ctx = DataizeContext loc _maxDepth _maxCycles (Steps _maxSteps 0) _depthSensitive _shuffle _partial atoms buildTerm save record+          (universe, aiming) <- aimed _inside expr ctx+          dataize universe aiming+      )+      `finally` closeRegistry atoms   when _sequence (printRewrittens printCtx (exclude $ include chain, False) >>= putStrLn)   unless _quiet (printOutcome printCtx outcome >>= putStrLn)   where@@ -235,10 +241,15 @@       include = (`F.include` included)   save <- saveStepFunc _stepsDir printCtx   (morphed, chain) <--    withEvalFunc _evaluations printCtx $ \record -> do-      let ctx = DataizeContext loc _maxDepth _maxCycles (Steps _maxSteps 0) _depthSensitive _shuffle _partial atoms buildTerm save record-      (universe, aiming) <- aimed _inside expr ctx-      morph universe aiming+    withEvalFunc+      _evaluations+      printCtx+      ( \record -> do+          let ctx = DataizeContext loc _maxDepth _maxCycles (Steps _maxSteps 0) _depthSensitive _shuffle _partial atoms buildTerm save record+          (universe, aiming) <- aimed _inside expr ctx+          morph universe aiming+      )+      `finally` closeRegistry atoms   when _sequence (printRewrittens printCtx (exclude $ include chain, False) >>= putStrLn)   unless _quiet (printFocused printCtx morphed >>= putStrLn)   where

@@ -7,54 +7,155 @@ module AtomsSpec (spec) where  import AST-import Atoms (Atom (..), Runtime (RtNode), emptyRegistry, fireAtom, readRegistry, registeredAtom)-import Control.Exception (SomeException, bracket)+import Atoms (Atom (..), Program (..), Registry, Runtime (RtNode), Session (_program), closeRegistry, emptyRegistry, fireAtom, readRegistry, registeredAtom)+import Control.Exception (SomeException, finally) import Control.Monad (forM_)+import Data.Aeson (Value, object, (.=))+import Data.Aeson.Key qualified as Key+import Data.Aeson.Types (Pair) import Data.ByteString qualified as BS import Data.List (isInfixOf) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8)-import Fixtures (withNode)+import Fixtures (resident, withExecutable, withNode, withRegistryOf, withScript, withShell, withTemp) import Parser (parseExpressionThrows)-import System.Directory (getTemporaryDirectory, removePathForcibly)-import System.IO (Handle, hClose, openBinaryTempFile)+import System.Directory (doesFileExist, getTemporaryDirectory, removePathForcibly)+import System.FilePath ((</>)) import Test.Hspec+import Text.Printf (printf) --- A registry file holding the given content, removed afterwards-withRegistry :: T.Text -> (FilePath -> IO a) -> IO a-withRegistry content action = do-  dir <- getTemporaryDirectory-  bracket (openBinaryTempFile dir "phino-registry-.json") discarded $ \(path, handle) -> do-    BS.hPut handle (encodeUtf8 content)-    hClose handle-    action path-  where-    discarded :: (FilePath, Handle) -> IO ()-    discarded (path, handle) = hClose handle >> removePathForcibly path+-- The registry of the given λ functions, every one of them the same entry+registryOf :: [T.Text] -> [Pair] -> Value+registryOf names fields = object [Key.fromText name .= object fields | name <- names] --- Fire the λ function 'L_answer' out of the given script, against a formation+-- The entry of a λ function run as the given file, which goes through JSON+-- encoding rather than into text by hand, since a Windows path spells its+-- separators with the escape character of JSON+executing :: FilePath -> [Pair]+executing file = ["rt" .= ("exec" :: T.Text), "path" .= file]++-- The entry of a λ function run as the given script under node+scripted :: T.Text -> [Pair]+scripted script = ["rt" .= ("node" :: T.Text), "script" .= script]++-- The same entry, kept for the run+served :: [Pair] -> [Pair]+served fields = ("serve" .= True) : fields++-- The text of a registry of node scripts under the given keys, in exactly the+-- order given, which 'registryOf' cannot promise+ordered :: [(T.Text, T.Text)] -> BS.ByteString+ordered entries = encodeUtf8 ("{" <> T.intercalate ", " ["\"" <> key <> "\": {\"rt\": \"node\", \"script\": \"" <> script <> "\"}" | (key, script) <- entries] <> "}")++-- The λ functions of the given registry, read from a file, with every program+-- it has started stopped afterwards, so that no spec leaves a process behind+withRegistered :: Value -> (Registry -> IO a) -> IO a+withRegistered registry action =+  withRegistryOf registry $ \path -> do+    atoms <- readRegistry path+    action atoms `finally` closeRegistry atoms++-- The λ functions of the registry naming a resident program built of the given+-- per-request snippet (see 'resident') under every given name+withServed :: [T.Text] -> T.Text -> (Registry -> IO a) -> IO a+withServed names snippet action =+  withExecutable (resident snippet) $ \file ->+    withRegistered (registryOf names (served (executing file))) action++-- Fire the given λ function out of the registry, against the same formation+-- 'fired' uses, inside the given universe+firedFrom :: Registry -> T.Text -> String -> IO Expression+firedFrom registry func universe = do+  form <- parseExpressionThrows "⟦ x ↦ ⟦ Δ ⤍ 01- ⟧ ⟧"+  univ <- parseExpressionThrows universe+  maybe (fail (printf "'%s' is not registered" (T.unpack func))) (\atom -> fireAtom func atom form univ) (registeredAtom registry func)++-- Fire the λ function 'L_answer' out of the given atom, against a formation -- binding 'x' inside a universe binding 'y'-fired :: T.Text -> IO Expression-fired script = do+fired :: Atom -> IO Expression+fired atom = do   form <- parseExpressionThrows "⟦ x ↦ ⟦ Δ ⤍ 01- ⟧ ⟧"   univ <- parseExpressionThrows "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"-  fireAtom "L_answer" (Atom RtNode script) form univ+  fireAtom "L_answer" atom form univ --- What the script wrote under 'n' has to come back parsed, so a case asserting+-- The program a λ function is kept for the run with, if it is kept at all+kept :: Maybe Atom -> Maybe Program+kept (Just (Resident session)) = Just (_program session)+kept _ = Nothing++-- A script run once per fire, answering the request with the given JavaScript+-- expression, in which 'lines' is every line phino said, 'universe' the one+-- carrying '𝑒' and 'request' the one carrying 'id', so a case asserts on what+-- phino says rather than on how a script reads it+scripting :: T.Text -> T.Text+scripting expr =+  T.unlines+    [ "const lines = require('fs').readFileSync(0, 'utf8').split('\\n').filter(Boolean).map((line) => JSON.parse(line));"+    , "const universe = lines.find((message) => '𝑒' in message);"+    , "const request = lines.find((message) => 'id' in message);"+    , "process.stdout.write(JSON.stringify({id: request.id, '𝑛': " <> expr <> "}));"+    ]++-- A script reading phino's lines one by one until its stdin closes and+-- answering every request with how many it has seen, so a case tells one+-- process kept across fires from one started afresh for each+counting :: T.Text+counting =+  T.unlines+    [ "let seen = 0;"+    , "require('readline').createInterface({input: process.stdin}).on('line', (line) => {"+    , "  const message = JSON.parse(line);"+    , "  if ('id' in message) {"+    , "    seen += 1;"+    , "    process.stdout.write(JSON.stringify({id: message.id, '𝑛': '⟦ Δ ⤍ 0' + seen + '- ⟧'}) + '\\n');"+    , "  }"+    , "});"+    ]++-- What the script wrote under '𝑛' has to come back parsed, so a case asserting -- on it says which expression it expects in 𝜑 rather than in constructors answers :: T.Text -> String -> Expectation answers script expected = withNode $ do-  answer <- fired script+  answer <- fired (Transient (Scripted RtNode script))   wanted <- parseExpressionThrows expected   answer `shouldBe` wanted --- A firing that has to fail, with the reason naming the given fragments+-- The same, for an atom phino runs off its path instead of staging it+executes :: T.Text -> String -> Expectation+executes script expected = withShell $+  withExecutable script $ \file -> do+    answer <- fired (Transient (Executable file))+    wanted <- parseExpressionThrows expected+    answer `shouldBe` wanted++-- The same, for an atom served by a resident program built of the given+-- per-request snippet+serves :: T.Text -> String -> Expectation+serves snippet expected = withShell $+  withServed ["L_answer"] snippet $ \registry -> do+    answer <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+    wanted <- parseExpressionThrows expected+    answer `shouldBe` wanted++-- A firing of a script that has to fail, with the reason naming the given+-- fragments fails :: T.Text -> [String] -> Expectation fails script fragments =   withNode $-    fired script+    fired (Transient (Scripted RtNode script))       `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) fragments) +-- The same, for a served atom+refuses :: T.Text -> [String] -> Expectation+refuses snippet fragments = withShell $+  withServed ["L_answer"] snippet $ \registry ->+    firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+      `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) fragments)++-- The reply of a resident program answering the request with the given bytes+replying :: T.Text -> T.Text+replying bytes = "printf '{\"id\": %s, \"𝑛\": \"⟦ Δ ⤍ %s ⟧\"}\\n' \"$id\" \"" <> bytes <> "\""+ spec :: Spec spec = do   -- phino implements no λ function, so an empty registry is what a run without@@ -65,90 +166,314 @@    describe "readRegistry" $ do     it "reads a λ function together with its runtime and script" $-      withRegistry "{\"L_answer\": {\"rt\": \"node\", \"script\": \"say(1)\"}}" $ \path -> do+      withRegistryOf (registryOf ["L_answer"] (scripted "say(1)")) $ \path -> do         registry <- readRegistry path-        registeredAtom registry "L_answer" `shouldBe` Just (Atom RtNode "say(1)")+        registeredAtom registry "L_answer" `shouldBe` Just (Transient (Scripted RtNode "say(1)")) +    -- An atom the object model brought as a binary of its own names no+    -- interpreter at all, only the file phino is to run+    it "reads an executable λ function as the file it runs" $+      withShell $+        withExecutable "" $ \file ->+          withRegistryOf (registryOf ["L_answer"] (executing file)) $ \path -> do+            registry <- readRegistry path+            registeredAtom registry "L_answer" `shouldBe` Just (Transient (Executable file))++    -- Whether a program is kept for the run is its own flag, so any program+    -- may be kept, whatever runs it+    it "keeps an executable λ function for the run when its entry says serve" $+      withShell $+        withExecutable "" $ \file ->+          withRegistryOf (registryOf ["L_answer"] (served (executing file))) $ \path -> do+            registry <- readRegistry path+            kept (registeredAtom registry "L_answer") `shouldBe` Just (Executable file)++    it "keeps a script for the run when its entry says serve" $+      withRegistryOf (registryOf ["L_answer"] (served (scripted "say(1)"))) $ \path -> do+        registry <- readRegistry path+        kept (registeredAtom registry "L_answer") `shouldBe` Just (Scripted RtNode "say(1)")++    it "starts a program afresh for every fire when its entry says not to serve" $+      withRegistryOf (registryOf ["L_answer"] (("serve" .= False) : scripted "say(1)")) $ \path -> do+        registry <- readRegistry path+        registeredAtom registry "L_answer" `shouldBe` Just (Transient (Scripted RtNode "say(1)"))+     it "leaves a name the file does not carry unregistered" $-      withRegistry "{\"L_answer\": {\"rt\": \"node\", \"script\": \"say(1)\"}}" $ \path -> do+      withRegistryOf (registryOf ["L_answer"] (scripted "say(1)")) $ \path -> do         registry <- readRegistry path         registeredAtom registry "L_bytes_eq" `shouldBe` Nothing -    -- An unknown runtime is refused where the file is read, which is before any+    -- A key is a regular expression, so one entry may stand for a whole family+    -- of atoms and the same program need not be spelled once per name+    it "matches a λ name against the key as a regular expression" $+      withRegistryOf (registryOf ["L_number_.*"] (scripted "say(1)")) $ \path -> do+        registry <- readRegistry path+        registeredAtom registry "L_number_plus" `shouldBe` Just (Transient (Scripted RtNode "say(1)"))++    -- A plain name is a regular expression too, and it means that one atom,+    -- not every atom whose name it is a part of+    it "matches the key against the whole λ name" $+      withRegistryOf (registryOf ["L_number"] (scripted "say(1)")) $ \path -> do+        registry <- readRegistry path+        registeredAtom registry "L_number_plus" `shouldBe` Nothing++    -- The keys are tried in the order the file lists them, so a catch-all+    -- placed first hides everything below it, and the file is written by hand+    -- here because 'object' does not keep the order of its keys+    it "fires the first key top to bottom that matches" $+      withTemp "phino-atoms-.json" (ordered [(".*", "say(1)"), ("L_answer", "say(2)")]) $ \path -> do+        registry <- readRegistry path+        registeredAtom registry "L_answer" `shouldBe` Just (Transient (Scripted RtNode "say(1)"))++    it "reaches a later key when the earlier ones do not match" $+      withTemp "phino-atoms-.json" (ordered [("L_other", "say(1)"), (".*", "say(2)")]) $ \path -> do+        registry <- readRegistry path+        registeredAtom registry "L_answer" `shouldBe` Just (Transient (Scripted RtNode "say(2)"))++    -- A malformed entry is refused where the file is read, which is before any     -- dataization starts, rather than at the moment an atom of it would fire     forM_       [         ( "the runtime is not one phino can run"-        , "{\"L_answer\": {\"rt\": \"ruby\", \"script\": \"say(1)\"}}"+        , registryOf ["L_answer"] ["rt" .= ("ruby" :: T.Text), "script" .= ("say(1)" :: T.Text)]         , ["unknown runtime 'ruby'", "node"]         )       ,         ( "an entry carries no script"-        , "{\"L_answer\": {\"rt\": \"node\"}}"+        , registryOf ["L_answer"] ["rt" .= ("node" :: T.Text)]         , ["script"]         )       ,         ( "an entry carries no runtime"-        , "{\"L_answer\": {\"script\": \"say(1)\"}}"+        , registryOf ["L_answer"] ["script" .= ("say(1)" :: T.Text)]         , ["rt"]         )       ,-        ( "the file is not JSON at all"-        , "L_answer: js"-        , ["cannot be read"]+        ( "an executable entry carries no path"+        , registryOf ["L_answer"] ["rt" .= ("exec" :: T.Text)]+        , ["path"]         )+      ,+        ( "the executable file is not there"+        , registryOf ["L_answer"] (executing "no-such-atom")+        , ["L_answer", "no-such-atom", "there is no such file"]+        )+      ,+        ( "the file to serve from is not there"+        , registryOf ["L_answer"] (served (executing "no-such-atom"))+        , ["L_answer", "no-such-atom", "there is no such file"]+        )+      ,+        ( "serve is not a boolean"+        , registryOf ["L_answer"] (("serve" .= ("yes" :: T.Text)) : scripted "say(1)")+        , ["serve", "Bool"]+        )       ]-      ( \(desc, content, fragments) ->+      ( \(desc, registry, fragments) ->           it ("fails when " ++ desc) $-            withRegistry content $ \path ->+            withRegistryOf registry $ \path ->               readRegistry path                 `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) fragments)       ) +    it "fails when the file is not JSON at all" $+      withTemp "phino-atoms-.json" "L_answer: js" $ \path ->+        readRegistry path+          `shouldThrow` (\failure -> "cannot be read" `isInfixOf` show (failure :: SomeException))++    it "fails when a key is not a regular expression" $+      withRegistryOf (registryOf ["L_(answer"] (scripted "say(1)")) $ \path ->+        readRegistry path+          `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) ["L_(answer", "regular expression"])++    it "fails when the file is a JSON array" $+      withTemp "phino-atoms-.json" "[]" $ \path ->+        readRegistry path+          `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) ["cannot be read", "object"])++    it "fails when there is more in the file than the JSON object" $+      withTemp "phino-atoms-.json" "{} {}" $ \path ->+        readRegistry path+          `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) ["cannot be read", "more in the file"])+     it "fails when the file is not there" $       readRegistry "no-such-registry.json"         `shouldThrow` (\failure -> "cannot be read" `isInfixOf` show (failure :: SomeException)) +    -- A file nobody may run is refused where the registry is read, not where+    -- the atom would fire+    it "fails when the file of an executable λ function cannot be run" $+      withScript "" $ \file ->+        withRegistryOf (registryOf ["L_answer"] (executing file)) $ \path ->+          readRegistry path+            `shouldThrow` (\failure -> "not executable" `isInfixOf` show (failure :: SomeException))++    it "fails when the file to serve from cannot be run" $+      withScript "" $ \file ->+        withRegistryOf (registryOf ["L_answer"] (served (executing file))) $ \path ->+          readRegistry path+            `shouldThrow` (\failure -> "not executable" `isInfixOf` show (failure :: SomeException))+   describe "fireAtom" $ do-    it "hands back the 𝜑-expression the script wrote under 'n'" $-      answers "process.stdout.write(JSON.stringify({n: '⟦ Δ ⤍ 2A- ⟧'}))" "⟦ Δ ⤍ 2A- ⟧"+    -- Every program is spoken to in the letters of the evaluation rule of the+    -- calculus, 𝔼(𝑏, 𝑒, 𝑠) = 𝑛, one JSON object per line, whether it is+    -- started for the fire or kept for the run+    it "hands back the 𝜑-expression the script wrote under '𝑛'" $+      answers (scripting "'⟦ Δ ⤍ 2A- ⟧'") "⟦ Δ ⤍ 2A- ⟧" -    -- One script may stand for several λ functions, so the name of the one-    -- being fired is its first command-line argument — where node puts it-    it "names the λ function being fired as the first command-line argument" $+    -- One script may stand for several λ functions, so every request names+    -- the one being fired+    it "names the λ function being fired under 'λ' in the request" $       answers-        "process.stdout.write(JSON.stringify({n: process.argv[2] === 'L_answer' ? '⟦ Δ ⤍ FF- ⟧' : '⟦ Δ ⤍ 00- ⟧'}))"+        (scripting "request['λ'] === 'L_answer' ? '⟦ Δ ⤍ FF- ⟧' : '⟦ Δ ⤍ 00- ⟧'")         "⟦ Δ ⤍ FF- ⟧" -    -- The formation being evaluated arrives under 'b' and the universe Φ under-    -- 's', both as 𝜑 text on stdin-    it "feeds the formation and the universe to the script on stdin" $+    it "carries the formation under '𝑏' in the request and the universe under '𝑒'" $       answers-        "const {b, s} = JSON.parse(require('fs').readFileSync(0, 'utf8'));\-        \process.stdout.write(JSON.stringify({n: b.includes('x ↦') && s.includes('y ↦') ? '⟦ Δ ⤍ FF- ⟧' : '⟦ Δ ⤍ 00- ⟧'}))"+        (scripting "request['𝑏'].includes('x ↦') && universe['𝑒'].includes('y ↦') ? '⟦ Δ ⤍ FF- ⟧' : '⟦ Δ ⤍ 00- ⟧'")         "⟦ Δ ⤍ FF- ⟧" +    it "tells the script the universe before the request" $+      answers+        (scripting "'𝑒' in lines[0] && 'id' in lines[1] ? '⟦ Δ ⤍ FF- ⟧' : '⟦ Δ ⤍ 00- ⟧'")+        "⟦ Δ ⤍ FF- ⟧"+     -- Neither payload carries syntax sugar, whatever '--sweet' says about the     -- output of the run, so a script finds every datum spelled as a Δ binding     it "spells the payloads as canonical 𝜑-calculus" $       answers-        "const {b} = JSON.parse(require('fs').readFileSync(0, 'utf8'));\-        \process.stdout.write(JSON.stringify({n: b.includes('Δ ⤍ 01-') ? '⟦ Δ ⤍ FF- ⟧' : '⟦ Δ ⤍ 00- ⟧'}))"+        (scripting "request['𝑏'].includes('Δ ⤍ 01-') ? '⟦ Δ ⤍ FF- ⟧' : '⟦ Δ ⤍ 00- ⟧'")         "⟦ Δ ⤍ FF- ⟧" +    -- A script started for the fire is asked one request, the first, so it+    -- may answer without reading anything at all     it "reads a script that says nothing to stdin without waiting for it" $-      answers "process.stdout.write(JSON.stringify({n: '⟦ Δ ⤍ 01- ⟧'}))" "⟦ Δ ⤍ 01- ⟧"+      answers "process.stdout.write(JSON.stringify({id: 1, '𝑛': '⟦ Δ ⤍ 01- ⟧'}))" "⟦ Δ ⤍ 01- ⟧" +    -- The stdin of a script started for the fire closes behind the request,+    -- so a script that reads line by line answers and quits on its own, the+    -- same as it would were it kept for the run+    it "lets a script that reads line by line answer and quit on its own" $+      answers counting "⟦ Δ ⤍ 01- ⟧"+     it "fails with the script's own complaint when it exits non-zero" $       fails         "process.stderr.write('no idea what to do');process.exit(4)"         ["L_answer", "exit code 4", "no idea what to do"] +    -- A script is judged by its exit status even once it has answered, since+    -- an answer it did not stand behind is no answer+    it "fails when the script answers and then exits non-zero" $+      fails+        "process.stdout.write(JSON.stringify({id: 1, '𝑛': '⟦ Δ ⤍ 2A- ⟧'}) + '\\n');process.exit(2)"+        ["L_answer", "exit code 2"]+     it "fails when the script writes something other than JSON" $       fails "process.stdout.write('almost')" ["L_answer", "almost"] -    it "fails when the script writes JSON with no 'n' in it" $-      fails "process.stdout.write(JSON.stringify({m: '⟦ ⟧'}))" ["L_answer", "n"]+    it "fails when the script writes JSON with no '𝑛' in it" $+      fails "process.stdout.write(JSON.stringify({id: 1, m: '⟦ ⟧'}))" ["L_answer", "𝑛"] -    it "fails when what the script put under 'n' is not a 𝜑-expression" $-      fails "process.stdout.write(JSON.stringify({n: '⟦ ⟧⟧'}))" ["L_answer"]+    it "fails when the script answers another request" $+      fails "process.stdout.write(JSON.stringify({id: 7, '𝑛': '⟦ Δ ⤍ 2A- ⟧'}))" ["L_answer", "request 7"]++    it "fails when what the script put under '𝑛' is not a 𝜑-expression" $+      fails "process.stdout.write(JSON.stringify({id: 1, '𝑛': '⟦ ⟧⟧'}))" ["L_answer"]++    -- An executable atom is spawned as it is, under no interpreter, so phino+    -- stages nothing of it and the file speaks the same protocol a script does+    it "runs an executable λ function straight off its path" $+      executes "echo '{\"id\": 1, \"𝑛\": \"⟦ Δ ⤍ 2A- ⟧\"}'" "⟦ Δ ⤍ 2A- ⟧"++    it "speaks the same lines to an executable as to a script" $+      executes+        "case \"$(cat)\" in *'\"λ\":\"L_answer\"'*) echo '{\"id\": 1, \"𝑛\": \"⟦ Δ ⤍ FF- ⟧\"}';; *) echo '{\"id\": 1, \"𝑛\": \"⟦ Δ ⤍ 00- ⟧\"}';; esac"+        "⟦ Δ ⤍ FF- ⟧"++    -- A program kept for the run is asked over the streams of one process,+    -- whatever runs it, so a script that counts its requests sees them all+    it "keeps a script that serves across the fires" $+      withNode $+        withRegistered (registryOf ["L_answer"] (served (scripted counting))) $ \registry -> do+          _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          second <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          wanted <- parseExpressionThrows "⟦ Δ ⤍ 02- ⟧"+          second `shouldBe` wanted++    it "hands back the 𝜑-expression the resident program wrote under '𝑛'" $+      serves (replying "2A-") "⟦ Δ ⤍ 2A- ⟧"++    it "keeps one resident program across the fires" $+      withShell $+        withServed ["L_answer"] (replying "0$n-") $ \registry -> do+          _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          second <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          wanted <- parseExpressionThrows "⟦ Δ ⤍ 02- ⟧"+          second `shouldBe` wanted++    -- One file may be registered under several λ names, and it is one program+    -- that serves them all, not one per name+    it "serves every λ name registered on the same file from one program" $+      withShell $+        withServed ["L_answer", "L_other"] (replying "0$n-") $ \registry -> do+          _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          second <- firedFrom registry "L_other" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          wanted <- parseExpressionThrows "⟦ Δ ⤍ 02- ⟧"+          second `shouldBe` wanted++    -- One key matching many names is the way to have one program serve them+    -- all without spelling it once per name+    it "serves every λ name one key matches from one program" $+      withShell $+        withServed [".*"] (replying "0$n-") $ \registry -> do+          _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          second <- firedFrom registry "L_other" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          wanted <- parseExpressionThrows "⟦ Δ ⤍ 02- ⟧"+          second `shouldBe` wanted++    it "tells the resident program the universe under '𝑒' before the first request" $+      serves (replying "0$e-") "⟦ Δ ⤍ 01- ⟧"++    it "does not tell the resident program a universe it was told already" $+      withShell $+        withServed ["L_answer"] (replying "0$e-") $ \registry -> do+          _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          second <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          wanted <- parseExpressionThrows "⟦ Δ ⤍ 01- ⟧"+          second `shouldBe` wanted++    it "tells the resident program the universe again when it changes" $+      withShell $+        withServed ["L_answer"] (replying "0$e-") $ \registry -> do+          _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          second <- firedFrom registry "L_answer" "⟦ z ↦ ⟦ Δ ⤍ 03- ⟧ ⟧"+          wanted <- parseExpressionThrows "⟦ Δ ⤍ 02- ⟧"+          second `shouldBe` wanted++    it "fails when the resident program answers another request" $+      refuses "printf '{\"id\": 99, \"𝑛\": \"⟦ Δ ⤍ 2A- ⟧\"}\\n'" ["L_answer", "request 99"]++    it "fails with the resident program's own complaint when it quits non-zero" $+      refuses "echo 'no idea what to do' >&2; exit 4" ["L_answer", "exit code 4", "no idea what to do"]++    it "fails when the resident program quits without answering" $+      refuses "exit 0" ["L_answer", "without answering"]++    it "fails when the resident program writes something other than JSON" $+      refuses "echo almost" ["L_answer", "almost"]++  describe "closeRegistry" $ do+    -- The program is told to quit by its stdin closing, which its read loop+    -- notices, so it gets to run whatever it does on exit+    it "stops the resident program the registry has started" $+      withShell $ do+        dir <- getTemporaryDirectory+        let mark = dir </> "phino-resident-quit"+        removePathForcibly mark+        withServed ["L_answer"] ("trap 'touch " <> T.pack mark <> "' EXIT; " <> replying "2A-") $ \registry -> do+          _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Δ ⤍ 02- ⟧ ⟧"+          closeRegistry registry+          doesFileExist mark `shouldReturn` True++    it "leaves a registry that started no program alone" $+      closeRegistry emptyRegistry `shouldReturn` ()

@@ -12,10 +12,11 @@ import Control.Monad (forM_, unless) import Data.Char (isDigit) import Data.List (intercalate, isInfixOf, isPrefixOf, sort)+import Data.Text qualified as T import Data.Time.Clock (addUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Version (showVersion)-import Fixtures (withFixtureRegistry, withNode)+import Fixtures (withFixtureRegistry, withNode, withServing, withShell) import GHC.IO.Handle import Paths_phino (version) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeDirectoryRecursive, removeFile, removePathForcibly, setModificationTime)@@ -398,6 +399,16 @@           length files `shouldBe` 4           doesFileExist (dir ++ "/00001.phi") `shouldReturn` True           doesFileExist (dir ++ "/00003.phi") `shouldReturn` True++    -- A served atom is asked over the streams of one resident program that+    -- 'phino' starts on the first fire and stops when the run is over, so the+    -- whole of it goes through the command line here: registry, program and+    -- the bytes it answers with+    it "dataizes with an atom served by a resident program" $+      withShell $+        withServing (T.pack "printf '{\"id\": %s, \"𝑛\": \"⟦ Δ ⤍ 2A- ⟧\"}\\n' \"$id\"") $ \registry ->+          withStdin "⟦ @ ↦ ⟦ λ ⤍ L_answer ⟧ ⟧" $+            testCLISucceeded ["dataize", "--atoms=" ++ registry] ["2A-"]      it "saves dataize steps to dir with --steps-dir" $       withAtoms $ \atoms ->

@@ -6,22 +6,36 @@ -- The λ functions the specs fire. phino implements none of them, so a spec that -- needs an atom to answer brings its own: one JavaScript fixture, -- 'test-resources/atoms/primitives.js', registered under every name in--- 'fixtureAtoms' and branching on the one it is handed as its first--- command-line argument.-module Fixtures (fixtureAtoms, fixtureRegistry, withFixtureRegistry, withNode) where+-- 'fixtureAtoms' and branching on the one each request names under 'λ', or a+-- POSIX shell script written for the occasion, either run once per fire or+-- kept resident for the run.+module Fixtures+  ( fixtureAtoms+  , fixtureRegistry+  , resident+  , withExecutable+  , withFixtureRegistry+  , withNode+  , withRegistryOf+  , withScript+  , withServing+  , withShell+  , withTemp+  )+where -import Atoms (Atom (..), Registry, Runtime (RtNode))+import Atoms (Registry, readRegistry) import Control.Exception (bracket)-import Data.Aeson (encode, object, (.=))+import Data.Aeson (Value, encode, object, (.=)) import Data.Aeson.Key qualified as Key import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL-import Data.Map.Strict qualified as Map import Data.Maybe (isNothing) import Data.Text qualified as T-import Data.Text.Encoding (decodeUtf8)-import System.Directory (findExecutable, getTemporaryDirectory, removePathForcibly)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import System.Directory (findExecutable, getPermissions, getTemporaryDirectory, removePathForcibly, setOwnerExecutable, setPermissions) import System.IO (Handle, hClose, openBinaryTempFile)+import System.Info (os) import Test.Hspec (Expectation, pendingWith)  -- Every λ function the fixture answers for. A name outside this list is@@ -41,27 +55,26 @@ fixtureScript :: IO T.Text fixtureScript = decodeUtf8 <$> BS.readFile "test-resources/atoms/primitives.js" --- The registry the specs that drive 'Dataize' directly run against.+-- The registry the specs that drive 'Dataize' directly run against: the same+-- file '--atoms' reads, read once and gone. fixtureRegistry :: IO Registry-fixtureRegistry = do-  script <- fixtureScript-  pure (Map.fromList [(name, Atom RtNode script) | name <- fixtureAtoms])+fixtureRegistry = withFixtureRegistry readRegistry  -- The same registry as the JSON file '--atoms' reads, in a temporary file -- removed afterwards, for the specs that go through the command line. withFixtureRegistry :: (FilePath -> IO a) -> IO a withFixtureRegistry action = do   script <- fixtureScript-  dir <- getTemporaryDirectory-  bracket (openBinaryTempFile dir "phino-atoms-.json") discarded $ \(path, handle) -> do-    BSL.hPut handle (encode (object [Key.fromText name .= entry script | name <- fixtureAtoms]))-    hClose handle-    action path+  withRegistryOf (object [Key.fromText name .= entry script | name <- fixtureAtoms]) action   where+    entry :: T.Text -> Value     entry script = object ["rt" .= ("node" :: T.Text), "script" .= script]-    discarded :: (FilePath, Handle) -> IO ()-    discarded (path, handle) = hClose handle >> removePathForcibly path +-- The given JSON, as the registry file '--atoms' reads, in a temporary file+-- removed afterwards.+withRegistryOf :: Value -> (FilePath -> IO a) -> IO a+withRegistryOf registry = withTemp "phino-atoms-.json" (BSL.toStrict (encode registry))+ -- Every atom the fixture provides runs under 'node', so a machine without it -- cannot fire one at all: such an expectation is pending rather than red. withNode :: Expectation -> Expectation@@ -70,3 +83,63 @@   if isNothing node     then pendingWith "'node' is not installed, so no λ function can be fired"     else expectation++-- A POSIX shell script is executable nowhere on Windows, so a case that needs+-- one is pending there rather than red.+withShell :: Expectation -> Expectation+withShell expectation+  | os == "mingw32" = pendingWith "no POSIX shell script is executable on Windows"+  | otherwise = expectation++-- A file in the temporary directory holding the given POSIX shell script,+-- removed afterwards.+withScript :: T.Text -> (FilePath -> IO a) -> IO a+withScript script = withTemp "phino-exec-.sh" (encodeUtf8 (T.unlines ["#!/bin/sh", script]))++-- The same file, executable, which is what an 'exec' or a 'serve' atom names+-- and phino never stages itself.+withExecutable :: T.Text -> (FilePath -> IO a) -> IO a+withExecutable script action = withScript script $ \path -> do+  permissions <- getPermissions path+  setPermissions path (setOwnerExecutable True permissions)+  action path++-- The registry of one λ function, 'L_answer', kept for the run, as the JSON+-- file '--atoms' reads, together with the resident program it names: a POSIX+-- shell script built of the given per-request snippet (see 'resident'). Both+-- files are removed afterwards.+withServing :: T.Text -> (FilePath -> IO a) -> IO a+withServing snippet action =+  withExecutable (resident snippet) $ \program ->+    withRegistryOf (object ["L_answer" .= object ["rt" .= ("exec" :: T.Text), "path" .= program, "serve" .= True]]) action++-- A program as a POSIX shell script that reads phino's lines until its stdin+-- closes, so it serves started once per fire and kept for the run alike: it+-- counts the universes it is told in 'e' and runs the given snippet for every+-- request, with the request in 'line', its number in 'id' and how many+-- requests it has seen so far in 'n'.+resident :: T.Text -> T.Text+resident snippet =+  T.unlines+    [ "e=0"+    , "n=0"+    , "while IFS= read -r line; do"+    , "  case \"$line\" in"+    , "    *'\"𝑒\"'*) e=$((e+1));;"+    , "    *) n=$((n+1)); id=$(printf '%s' \"$line\" | sed 's/.*\"id\":\\([0-9]*\\).*/\\1/'); " <> snippet <> ";;"+    , "  esac"+    , "done"+    ]++-- Write the content to a fresh temporary file, hand its path to the action and+-- delete the file afterwards.+withTemp :: String -> BS.ByteString -> (FilePath -> IO a) -> IO a+withTemp template content action = do+  dir <- getTemporaryDirectory+  bracket (openBinaryTempFile dir template) discarded $ \(path, handle) -> do+    BS.hPut handle content+    hClose handle+    action path+  where+    discarded :: (FilePath, Handle) -> IO ()+    discarded (path, handle) = hClose handle >> removePathForcibly path