diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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` diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -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 diff --git a/src/Atoms.hs b/src/Atoms.hs --- a/src/Atoms.hs +++ b/src/Atoms.hs @@ -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)) diff --git a/src/CLI/Parsers.hs b/src/CLI/Parsers.hs --- a/src/CLI/Parsers.hs +++ b/src/CLI/Parsers.hs @@ -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) ) ) diff --git a/src/CLI/Runners.hs b/src/CLI/Runners.hs --- a/src/CLI/Runners.hs +++ b/src/CLI/Runners.hs @@ -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 diff --git a/test/AtomsSpec.hs b/test/AtomsSpec.hs --- a/test/AtomsSpec.hs +++ b/test/AtomsSpec.hs @@ -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` () diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -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 -> diff --git a/test/Fixtures.hs b/test/Fixtures.hs --- a/test/Fixtures.hs +++ b/test/Fixtures.hs @@ -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