{-# LANGUAGE DeriveGeneric #-}
{- | Layer 1 coverage for "Salmon.Actions.Serve.Http" (milestone 3 of
@specs\/generic-server.md@): the @run serve@ loop with an HTTP server on a
unix socket beside its standard input, driven by a real @http-client@ over
real connections.
The nodes are the counter-bumping stubs 'Test.ServeSocketSpec' uses, plus
one whose @up@ blocks until the test lets it go. The claims: @\/dag@ is,
node for node and edge for edge, what 'Help.printDagTree' prints for the
same world; it is populated the moment something is declared, before any
pass; a retired seed's nodes stay in it wanted @down@ until they are gone;
a script typed through @POST \/command@ synchronously, asynchronously, and
on standard input leaves the same world, and the synchronous form answers
with exactly the reports each line produced; and a read answers while the
loop is inside a node's @up@. Milestone 7's static files: @GET \/@ is the
page, @\/ui\/ui.js@ is the script with its content type — one that subscribes
from a snapshot's @seq@, writes only through @POST \/command?async@, reads
@\/help\/seed@ for its seed form and never sends @quit@ — and a path outside
the embedded set is the ordinary @404@.
-}
module Test.ServeHttpSpec (tests) where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (try)
import Control.Monad (forM, forM_)
import Data.Aeson (FromJSON, ToJSON, Value (..), eitherDecode, toJSON)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString.Lazy.Char8 as LChar8
import Data.Foldable (toList)
import Data.List (isInfixOf, isPrefixOf, sort)
import qualified Data.List as List
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, mapMaybe)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.Internal (makeConnection)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Socket as Socket
import qualified Network.Socket.ByteString as SocketBS
import System.FilePath ((</>))
import System.IO (Handle, IOMode (ReadMode), hClose, hPutStr, withFile)
import System.IO.Temp (withSystemTempFile)
import System.Timeout (timeout)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)
import qualified Salmon.Actions.Help as Help
import qualified Test.ServeApi as Api
import qualified Salmon.Actions.Serve as Serve
import Salmon.Actions.Serve (Attributed (..), Convergence (..), Direction (..), NodeState (..), World (..))
import qualified Salmon.Actions.Query as Query
import qualified Salmon.Actions.Serve.Events as Events
import qualified Salmon.Actions.Serve.Http as Http
import qualified Salmon.Actions.Serve.StatusSink as StatusSink
import Salmon.Builtin.Extension (Op, Track', amendNode, deps, down, help, nodeps, op, ref, up, withCardTemplate)
import Salmon.Op.Configure (Configure (..))
import Salmon.Op.Ref (Ref, mkRef)
import Salmon.Op.Track (Track (..))
import Salmon.Reporter (contramap, silent)
import qualified Salmon.Reporter.Tagged as Tagged
import Test.Harness (capture, privatePipe, withTempDir)
tests :: TestTree
tests =
testGroup
"Salmon.Actions.Serve.Http"
[ testCase "/dag is what printDagTree prints, node for node and edge for edge" dagMatchesPrintDagTree
, testCase "/dag is populated from the first declaration on, before any pass" dagBeforeAnyPass
, testCase "a retired seed's nodes stay in /dag wanted down until they are gone" retiredNodesAreDown
, testCase "sync, async and stdin leave the same world; sync answers with the line's reports" syncAndAsyncAgree
, testCase "a text line, {\"line\"} and {\"verb\", \"seed\"} bodies give the same reports and world" bodyFormsAgree
, testCase "a malformed JSON command body is a 400, not a command" badStructuredBodies
, testCase "a structured body renders to a line that tokenizes back to its seed" structuredRoundTrips
, testCase "reads answer while the loop is inside a long up" readsDuringLongUp
, testCase "/help/seed, /history and the error responses" theOtherReads
, testCase "GET /openapi.json is the embedded document, and every route it documents answers" openApiServed
, testCase "/dag carries the mode the loop's accessor answers at the moment of the read" dagCarriesMode
, testCase "GET / is the web UI's page, /ui/* its files, and a missing one is 404" theWebUi
, testCase "two seeds colliding on one ref: /dag carries the kept and replaced pair while both are wanted" conflictingPairOnDag
, testCase "a node's card template is on /dag, only on that node, and a new one is not a conflict" cardTemplateOnDag
, testCase "a chain of diamonds: /dag, /status, status, a --select and a status-sink write all answer" diamondChainAnswers
, testCase "--http-read-only: every POST /command is 403, reads and stdin still work; read-write by default" readOnlyRefusesCommands
]
-------------------------------------------------------------------------------
-- the thing served: counters per node name, plus one node that blocks
newtype Spec = Spec {specNames :: [String]}
deriving (Eq, Show, Generic)
instance ToJSON Spec
instance FromJSON Spec
parseSpec :: [String] -> Either Text Spec
parseSpec [] = Left "expected at least one node name"
parseSpec args = Right (Spec args)
-- | The name of the node whose @up@ waits to be let go.
slowName :: String
slowName = "slow"
data Slow = Slow
{ slowStarted :: MVar ()
-- ^ filled when the slow node's @up@ is entered
, slowGate :: MVar ()
-- ^ filled by the test to let it return
}
spyProgram :: Slow -> IORef (Map String Int) -> IORef (Map String Int) -> Track' Spec
spyProgram slow upsRef downsRef = Track $ \spec ->
op "http-root" (deps (fmap nodeOp spec.specNames)) $ \actions ->
actions{ref = mkRef "http-root" spec.specNames, help = "the root of " <> Text.pack (unwords spec.specNames)}
where
nodeOp name | name == diamondsName = diamondChain diamondCount
-- @card=SRC@ is one node (ref keyed on @card@, help fixed) carrying the
-- card template @SRC@: two seeds differing only by their template
nodeOp name
| Just src <- List.stripPrefix "card=" name =
amendNode (withCardTemplate (Text.pack src)) $
op "http-node" nodeps $ \actions ->
actions{ref = mkRef "http-node" ("card" :: String), help = "node card", up = bump upsRef "card", down = bump downsRef "card"}
-- @NAME:VARIANT@ is the same node (ref keyed on @NAME@) described
-- differently (help carries the whole word): two seeds colliding on
-- one ref, for the /dag conflict case
nodeOp name =
op "http-node" nodeps $ \actions ->
actions
{ ref = mkRef "http-node" (takeWhile (/= ':') name)
, help = "node " <> Text.pack name
, up =
if name == slowName
then putMVar (slowStarted slow) () >> takeMVar (slowGate slow)
else bump upsRef name
, down = bump downsRef name
}
bump r name = atomicModifyIORef' r (\m -> (Map.insertWith (+) name 1 m, ()))
-- | The name of the seed word that declares 'diamondChain'.
diamondsName :: String
diamondsName = "diamonds"
{- | How many diamonds: 49 nodes under the root, 2^16 paths to the last.
No more than that because declaring a seed still walks every occurrence
once ('Salmon.Op.Dag.foldDag'): four more diamonds make the declaration
seconds of allocation, during which the suite's timing-sensitive cases,
sharing this process and its collector, miss their windows.
'Test.QuerySpec' has sixty diamonds without a loop around them.
-}
diamondCount :: Int
diamondCount = 16
{- | Diamonds on top of one another: each @top@ stands on a @left@ and a
@right@ that both stand on the next @top@ down, and the last on @bottom@. The
number of paths to a node doubles with every diamond above it, which is the
shape a listing of every path cannot survive.
-}
diamondChain :: Int -> Op
diamondChain 0 = op "bottom" nodeps $ \actions -> actions{ref = mkRef "http-diamond" ("bottom" :: String)}
diamondChain i =
op "top" (deps [side "left", side "right"]) $ \actions -> actions{ref = mkRef "http-diamond" ("top" :: String, i)}
where
below = diamondChain (i - 1)
side name = op (Text.pack name) (deps [below]) $ \actions -> actions{ref = mkRef "http-diamond" (name, i)}
-------------------------------------------------------------------------------
-- a running loop with an HTTP server
data Running = Running
{ runningStdin :: Handle
-- ^ the writing end of the loop's standard input; closing it ends the loop
, runningWorld :: MVar (World Spec Spec)
, runningOwn :: IO [Tagged.Tagged]
-- ^ everything the loop's own reporter saw
, runningUps :: IORef (Map String Int)
, runningDowns :: IORef (Map String Int)
, runningSlow :: Slow
, runningManager :: HTTP.Manager
}
seedHelp :: Text
seedHelp = "usage: config NAME...\n"
{- | Start the loop on a temp socket with a pipe for standard input, hand
it to the test, and make sure it has ended before the temp dir goes.
-}
withRunning :: (Running -> IO a) -> IO a
withRunning = withRunningMode (pure Serve.Interactive)
-- | 'withRunning' with the server's mode accessor chosen by the test.
withRunningMode :: IO Serve.Mode -> (Running -> IO a) -> IO a
withRunningMode = withRunningAccess Http.ReadWrite
-- | 'withRunningMode' with the server's 'Http.Access' chosen.
withRunningAccess :: Http.Access -> IO Serve.Mode -> (Running -> IO a) -> IO a
withRunningAccess access mode act =
withTempDir $ \dir -> do
let path = dir </> "serve.http"
(stdinR, stdinW) <- privatePipe
worldVar <- newEmptyMVar
(own, seen) <- capture
upsRef <- newIORef Map.empty
downsRef <- newIORef Map.empty
slow <- Slow <$> newEmptyMVar <*> newEmptyMVar
Http.withHttpServerAccess Events.defaultConfig access [Http.BindUnix path] seedHelp mode $ \server -> do
let base = (contramap attributed (Tagged.serveStream own), contramap attributed (Tagged.updownStream own))
(serveR, updownR) = Http.serverReporters server base
_ <- forkIO $ do
w <-
Serve.serveObserved
(Http.serverObserver server)
[]
Nothing
True
serveR
updownR
parseSpec
(Configure pure)
(spyProgram slow upsRef downsRef)
Nothing
[Serve.stdinProducer stdinR, Http.serverProducer server]
putMVar worldVar w
-- the loop publishes its inbox from a thread it forks: wait for
-- it, or the first request can beat it and be answered 503
timeout (10 * 1000000) (Http.awaitLoop server)
>>= maybe (assertFailure "the loop did not start within 10s") pure
manager <- unixManager path
let running = Running stdinW worldVar seen upsRef downsRef slow manager
r <- act running
_ <- try (hClose stdinW) :: IO (Either IOError ())
_ <- awaitWorld running
pure r
awaitWorld :: Running -> IO (World Spec Spec)
awaitWorld running = do
mw <- timeout (10 * 1000000) (takeMVar (runningWorld running))
case mw of
Nothing -> assertFailure "the loop did not end"
Just w -> do
putMVar (runningWorld running) w
pure w
-- | End the loop through standard input and hand back the world it left.
finish :: Running -> IO (World Spec Spec)
finish running = do
hClose (runningStdin running)
awaitWorld running
-------------------------------------------------------------------------------
-- an http client over the unix socket
unixManager :: FilePath -> IO HTTP.Manager
unixManager path =
HTTP.newManager
HTTP.defaultManagerSettings
{ HTTP.managerRawConnection = pure $ \_ _ _ -> do
sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol
Socket.connect sock (Socket.SockAddrUnix path)
makeConnection (SocketBS.recv sock 4096) (SocketBS.sendAll sock) (Socket.close sock)
}
-- | A GET, decoded; the status and the body.
get :: Running -> String -> IO (Int, Value)
get running route = do
req <- HTTP.parseRequest ("http://salmon" <> route)
exchange running req
-- | A text @POST \/command@, decoded.
post :: Running -> String -> String -> IO (Int, Value)
post running route line = do
req0 <- HTTP.parseRequest ("http://salmon" <> route)
let req =
req0
{ HTTP.method = "POST"
, HTTP.requestHeaders = [(HTTP.hContentType, "text/plain")]
, HTTP.requestBody = HTTP.RequestBodyLBS (LChar8.pack line)
}
exchange running req
-- | A @POST \/command@ with a given content type and body, decoded.
postAs :: Running -> String -> String -> IO (Int, Value)
postAs running ctype body = do
req0 <- HTTP.parseRequest "http://salmon/command"
let req =
req0
{ HTTP.method = "POST"
, HTTP.requestHeaders = [(HTTP.hContentType, LChar8.toStrict (LChar8.pack ctype))]
, HTTP.requestBody = HTTP.RequestBodyLBS (LChar8.pack body)
}
exchange running req
-- | A GET left undecoded: the status, the content type, and the body.
getRaw :: Running -> String -> IO (Int, Maybe LChar8.ByteString, LChar8.ByteString)
getRaw running route = do
req <- HTTP.parseRequest ("http://salmon" <> route)
r <- timeout (10 * 1000000) (HTTP.httpLbs req (runningManager running))
case r of
Nothing -> assertFailure ("no answer within 10s to " <> route)
Just resp ->
pure
( HTTP.statusCode (HTTP.responseStatus resp)
, LChar8.fromStrict <$> lookup HTTP.hContentType (HTTP.responseHeaders resp)
, HTTP.responseBody resp
)
exchange :: Running -> HTTP.Request -> IO (Int, Value)
exchange running req = do
r <- timeout (10 * 1000000) (HTTP.httpLbs req (runningManager running))
case r of
Nothing -> assertFailure ("no answer within 10s to " <> show (HTTP.path req))
Just resp ->
case eitherDecode (HTTP.responseBody resp) of
Left err -> assertFailure ("not JSON: " <> err <> ": " <> LChar8.unpack (HTTP.responseBody resp))
Right v -> do
let status = HTTP.statusCode (HTTP.responseStatus resp)
-- every JSON answer this spec gets is also checked against
-- the schema the OpenAPI document gives that operation and status
assertEqual
("schema errors in " <> show (HTTP.method req) <> " " <> show (HTTP.path req) <> " -> " <> show status)
[]
(Api.validateResponse (HTTP.method req) (HTTP.path req) status v)
pure (status, v)
-- | A synchronous command: the kinds of the reports it answered with.
sync :: Running -> String -> IO [Text]
sync running line = do
(code, v) <- post running "/command" line
assertEqual ("status of sync " <> line) 200 code
case v of
Array xs -> pure (fmap kindOf (toList xs))
_ -> assertFailure ("sync answer is not an array: " <> show v)
-- | An asynchronous command: the sequence number it was queued at.
async :: Running -> String -> IO Integer
async running line = do
(code, v) <- post running "/command?async" line
assertEqual ("status of async " <> line) 202 code
case v of
Object o | Just (Number n) <- KeyMap.lookup "seq" o -> pure (truncate n)
_ -> assertFailure ("async answer has no seq: " <> show v)
-------------------------------------------------------------------------------
-- reading the JSON
kindOf :: Value -> Text
kindOf v = maybe "<no kind>" id (textAt ["kind"] v)
textAt :: [Text] -> Value -> Maybe Text
textAt [] (String t) = Just t
textAt (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= textAt ks
textAt _ _ = Nothing
field :: Text -> Value -> Maybe Value
field k (Object o) = KeyMap.lookup (Key.fromText k) o
field _ _ = Nothing
withoutSeq :: Value -> Value
withoutSeq (Object o) = Object (KeyMap.delete "seq" o)
withoutSeq v = v
arrayOf :: Value -> [Value]
arrayOf (Array xs) = toList xs
arrayOf _ = []
-- | The @nodes@ of a @\/dag@ answer.
dagNodes :: Value -> IO [Value]
dagNodes v = case field "nodes" v of
Just (Array xs) -> pure (toList xs)
_ -> assertFailure ("/dag without nodes: " <> show v)
-- | The lines 'Help.printDagTree' would print, rebuilt from a @\/dag@ answer.
dagLinesOf :: [Value] -> [Text]
dagLinesOf nodes = concatMap nodeLines nodes
where
shorthandByRef :: Map Text Text
shorthandByRef = Map.fromList (mapMaybe (\n -> (,) <$> textAt ["ref", "full"] n <*> textAt ["shorthand"] n) nodes)
nodeLines n =
let sh = orNothing (textAt ["shorthand"] n)
full = orNothing (textAt ["ref", "full"] n)
hlp = orNothing (textAt ["help"] n)
depLine d =
let dref = orNothing (textAt ["full"] d)
in " <- " <> Map.findWithDefault dref dref shorthandByRef
in (sh <> " (" <> full <> ") " <> hlp) : fmap depLine (maybe [] arrayOf (field "dependencies" n))
orNothing = maybe "<missing>" id
-------------------------------------------------------------------------------
dagMatchesPrintDagTree :: IO ()
dagMatchesPrintDagTree =
withRunning $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "up n1 n2"
_ <- sync running "up n2 n3"
(code, v) <- get running "/dag"
assertEqual "status" 200 code
nodes <- dagNodes v
w <- finish running
let dag = Serve.worldDag w
assertEqual "the same lines printDagTree prints" (Help.dagLines dag) (dagLinesOf nodes)
assertEqual "one node per world node" (Map.size w.worldNodes) (length nodes)
-- edges in both directions agree: every dependency edge is a
-- dependant edge on the other node, and vice versa
let refOf n = orMissing (textAt ["ref", "full"] n)
edgesOut = Set.fromList [(orMissing (textAt ["full"] d), refOf n) | n <- nodes, d <- maybe [] arrayOf (field "dependencies" n)]
edgesIn = Set.fromList [(refOf n, orMissing (textAt ["full"] d)) | n <- nodes, d <- maybe [] arrayOf (field "dependants" n)]
assertEqual "dependants are the transpose of dependencies" edgesOut edgesIn
assertBool "there are edges" (not (Set.null edgesOut))
-- and every node carries the loop's state and the representative's fields
forM_ nodes $ \n -> do
assertEqual ("direction of " <> show (refOf n)) (Just "up") (textAt ["direction"] n)
assertEqual ("convergence of " <> show (refOf n)) (Just "converged") (textAt ["convergence"] n)
assertBool "notes present" (field "notes" n /= Nothing)
assertBool "dynamics present" (field "dynamics" n /= Nothing)
assertBool "status present (null: never tended)" (field "status" n /= Nothing)
where
orMissing = maybe "<missing>" id
{- | @up n1:a@ then @up n1:b@ describe one ref two ways. The second
declaration is reported @conflicting@ and, from then on, @\/dag@\'s node for
it carries the pair — @kept@ being what the magma holds, @replaced@ what it
beat — where every other node carries none. Re-declaring the winner keeps the
pair (the loser is still wanted); retiring the loser and converging clears
it, since nothing wants that version any more.
-}
conflictingPairOnDag :: IO ()
conflictingPairOnDag =
withRunning $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "autoconverge off"
first <- sync running "up n1:a n2"
assertBool ("no conflict on a first declaration: " <> show first) ("conflicting" `notElem` first)
second <- sync running "up n1:b"
assertBool ("the collision is reported: " <> show second) ("conflicting" `elem` second)
(_, v) <- get running "/dag"
nodes <- dagNodes v
let n1 = filter (\n -> textAt ["help"] n == Just "node n1:b") nodes
assertEqual "the magma holds the last writer" 1 (length n1)
forM_ n1 $ \n -> do
assertEqual "kept is the winner" (Just "node n1:b") (textAt ["conflict", "kept", "help"] n)
assertEqual "replaced is the loser" (Just "node n1:a") (textAt ["conflict", "replaced", "help"] n)
assertEqual "kept carries the shorthand" (Just "http-node") (textAt ["conflict", "kept", "shorthand"] n)
forM_ (filter (\n -> textAt ["help"] n /= Just "node n1:b") nodes) $ \n ->
assertEqual ("no conflict on " <> show (textAt ["help"] n)) Nothing (field "conflict" n)
-- the winner re-declared: nothing changed, the loser is still wanted
again <- sync running "up n1:b"
assertBool ("an unchanged re-declaration is not a new collision: " <> show again) ("conflicting" `notElem` again)
(_, v') <- get running "/dag"
nodes' <- dagNodes v'
assertEqual "the pair stands" [Just "node n1:a"] [textAt ["conflict", "replaced", "help"] n | n <- nodes', textAt ["help"] n == Just "node n1:b"]
-- the loser retired and gone: nobody wants its version, the pair goes
_ <- sync running "down n1:a n2"
_ <- sync running "converge"
_ <- sync running "up n1:b"
(_, v'') <- get running "/dag"
nodes'' <- dagNodes v''
forM_ nodes'' $ \n -> assertEqual ("no conflict left on " <> show (textAt ["help"] n)) Nothing (field "conflict" n)
{- | A node carrying a card template ("Salmon.Op.CardTemplate") has it on
@\/dag@ as @template@ (and the answer is valid against the document); no
other node has the key. Re-declaring it with another template is not a
collision, does not demote the node, and @\/dag@ then carries the new one.
-}
cardTemplateOnDag :: IO ()
cardTemplateOnDag =
withRunning $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "autoconverge off"
_ <- sync running "up card=.p($ctx.help) n2"
_ <- sync running "converge"
let cardOf nodes = [n | n <- nodes, textAt ["help"] n == Just "node card"]
(_, v) <- get running "/dag"
nodes <- dagNodes v
assertEqual "the template" [Just ".p($ctx.help)"] (fmap (textAt ["template"]) (cardOf nodes))
assertEqual "converged" [Just "converged"] (fmap (textAt ["convergence"]) (cardOf nodes))
forM_ [n | n <- nodes, textAt ["help"] n /= Just "node card"] $ \n ->
assertEqual ("no template on " <> show (textAt ["help"] n)) Nothing (field "template" n)
assertBool "not among the rendered dynamics" (all (\n -> field "dynamics" n == Just (Array mempty)) (cardOf nodes))
again <- sync running "up card=.div($ctx.shorthand)"
assertBool ("another template is not a collision: " <> show again) ("conflicting" `notElem` again)
(_, v') <- get running "/dag"
nodes' <- dagNodes v'
assertEqual "the new template" [Just ".div($ctx.shorthand)"] (fmap (textAt ["template"]) (cardOf nodes'))
assertEqual "still converged" [Just "converged"] (fmap (textAt ["convergence"]) (cardOf nodes'))
assertEqual "no conflict on it" [Nothing] (fmap (field "conflict") (cardOf nodes'))
{- | A graph whose paths are not to be listed: 'diamondCount' diamonds, 65536
paths to the last node and a quarter of a million in all. Everything that
shows a node's paths or resolves a pattern against them answers within
'exchange'\'s ten seconds, and what it answers is bounded: at most
'Query.pathLimit' paths per node, the shortest first. A pattern still
selects by any path, listed or not.
-}
diamondChainAnswers :: IO ()
diamondChainAnswers =
withRunning $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "autoconverge off"
declared <- sync running ("up " <> diamondsName)
assertBool ("declared: " <> show declared) ("declared" `elem` declared)
let total = 3 * diamondCount + 2
-- /dag
(dagCode, dag) <- get running "/dag"
assertEqual "/dag status" 200 dagCode
nodes <- dagNodes dag
let pathsOf n = [p | String p <- maybe [] arrayOf (field "paths" n)]
bottoms = [n | n <- nodes, textAt ["shorthand"] n == Just "bottom"]
assertEqual "one node per ref, the root included" total (length nodes)
forM_ nodes $ \n -> do
assertBool ("a path to " <> show (textAt ["ref", "short"] n)) (not (null (pathsOf n)))
assertBool ("no more than the limit for " <> show (textAt ["ref", "short"] n)) (length (pathsOf n) <= Query.pathLimit)
assertEqual "the last node lists the limit" [Query.pathLimit] (fmap (length . pathsOf) bottoms)
assertEqual
"its shortest path first: left all the way down"
[Just ("http-root/" <> Text.concat (replicate diamondCount "top/left/") <> "bottom")]
(fmap (headMay . pathsOf) bottoms)
-- /status, and the typed status
(statusCode, status) <- get running "/status"
assertEqual "/status status" 200 statusCode
assertEqual "/status lists every node" total (length (maybe [] arrayOf (field "nodes" status)))
typed <- sync running "status"
assertEqual "the typed status answers" ["status"] typed
-- a selector: everything under the first right, by whatever path
(_, q) <- post running "/command" "query --select /http-root/top/right/**"
let selectedIn v = [n | r <- arrayOf v, n <- maybe [] arrayOf (field "nodes" r), field "selected" n == Just (Bool True)]
assertEqual "all but the root, the first top and its left" (total - 3) (length (selectedIn q))
-- by a path that is not among the ones listed
(_, q') <- post running "/command" ("query --select /http-root" <> concat (replicate diamondCount "/top/right") <> "/bottom")
assertEqual "the longest path still selects its node" [Just "bottom"] (fmap (textAt ["shorthand"]) (selectedIn q'))
-- a restricted pass
_ <- sync running "converge --select /http-root/top/left/**"
ups <- readIORef (runningUps running)
assertEqual "no counter node is in this graph" Map.empty ups
(_, dag') <- get running "/dag"
nodes' <- dagNodes dag'
assertEqual
"the pass converged what the pattern selected and nothing else"
(total - 3)
(length [() | n <- nodes', textAt ["convergence"] n == Just "converged"])
-- the status sink writes the same object
w <- finish running
withTempDir $ \dir -> do
let path = dir </> "status.json"
cfg = StatusSink.Config{StatusSink.configPath = path, StatusSink.configInterval = 60 * 1000000, StatusSink.configHost = "diamonds"}
written <- timeout (10 * 1000000) $
StatusSink.withSink cfg Nothing silent $ \sink -> do
StatusSink.sinkObserver sink (pure w)
StatusSink.writeNow sink
eitherDecode <$> LChar8.readFile path
case written of
Nothing -> assertFailure "the status sink did not write within 10s"
Just (Left err) -> assertFailure ("the sink's document does not parse: " <> err)
Just (Right (doc :: StatusSink.Document)) ->
assertEqual "the sink's status lists every node" total (length (maybe [] arrayOf (field "nodes" (StatusSink.docStatus doc))))
where
headMay (x : _) = Just x
headMay [] = Nothing
dagBeforeAnyPass :: IO ()
dagBeforeAnyPass =
withRunning $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "autoconverge off"
declared <- sync running "up n1 n2"
assertEqual "no pass ran" ["declared"] declared
(_, v) <- get running "/dag"
nodes <- dagNodes v
assertEqual "three nodes, no pass" 3 (length nodes)
forM_ nodes $ \n -> do
assertEqual "pending" (Just "pending") (textAt ["convergence"] n)
assertEqual "up" (Just "up") (textAt ["direction"] n)
ups <- readIORef (runningUps running)
assertEqual "nothing was applied" Map.empty ups
converged <- sync running "converge"
assertBool ("the pass ran: " <> show converged) ("converge-stop" `elem` converged)
(_, v') <- get running "/dag"
nodes' <- dagNodes v'
forM_ nodes' $ \n -> assertEqual "converged" (Just "converged") (textAt ["convergence"] n)
retiredNodesAreDown :: IO ()
retiredNodesAreDown =
withRunning $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "up n1 n2"
_ <- sync running "autoconverge off"
_ <- sync running "down n1 n2"
(_, v) <- get running "/dag"
nodes <- dagNodes v
assertEqual "still there, on their way down" 3 (length nodes)
forM_ nodes $ \n -> do
assertEqual "down" (Just "down") (textAt ["direction"] n)
assertEqual "pending" (Just "pending") (textAt ["convergence"] n)
-- the edges survive the retraction: they are what orders the teardown
assertBool "edges kept" (any (\n -> not (null (maybe [] arrayOf (field "dependencies" n)))) nodes)
_ <- sync running "converge"
(_, v') <- get running "/dag"
nodes' <- dagNodes v'
assertEqual "gone once down" 0 (length nodes')
downs <- readIORef (runningDowns running)
assertEqual "both nodes went down" (Map.fromList [("n1", 1), ("n2", 1)]) downs
syncAndAsyncAgree :: IO ()
syncAndAsyncAgree = do
(stdinUps, stdinDowns, stdinWorld, stdinKinds) <- runScript script
-- synchronously: each line answered with its reports
(syncUps, syncDowns, syncWorld, syncKinds) <- withRunning $ \running -> do
kinds <- concat <$> forM script (sync running)
w <- finish running
(,,,) <$> readIORef (runningUps running) <*> readIORef (runningDowns running) <*> pure w <*> pure kinds
-- as a multiset: a convergence pass is concurrent, so two nodes ready
-- at the same time report in whichever order their threads ran, on
-- stdin and over HTTP alike
assertEqual "sync answers with exactly the reports the lines produced on stdin" (sort stdinKinds) (sort syncKinds)
assertEqual "the first line's reports come first" (take 2 stdinKinds) (take 2 syncKinds)
-- asynchronously: queued, then a sync `status` that is handled after them all
(asyncUps, asyncDowns, asyncWorld) <- withRunning $ \running -> do
seqs <- forM script (async running)
assertBool ("sequence numbers are assigned at enqueue, in order: " <> show seqs) (and (zipWith (<) seqs (drop 1 seqs)))
_ <- sync running "status"
own <- runningOwn running
let handled = length (filter isConvergeStop own)
assertEqual "every declaring line was handled before the status" (length (filter isDeclaring script)) handled
w <- finish running
(,,) <$> readIORef (runningUps running) <*> readIORef (runningDowns running) <*> pure w
assertEqual "ups (sync)" stdinUps syncUps
assertEqual "downs (sync)" stdinDowns syncDowns
assertEqual "world (sync)" (worldShape stdinWorld) (worldShape syncWorld)
assertEqual "ups (async)" stdinUps asyncUps
assertEqual "downs (async)" stdinDowns asyncDowns
assertEqual "world (async)" (worldShape stdinWorld) (worldShape asyncWorld)
where
script = ["supervise off", "up n1", "up n1 n2", "down n1", "history"]
isDeclaring l = any (`Text.isPrefixOf` Text.pack l) ["up ", "down "]
isConvergeStop t = case t of
Tagged.FromServe Serve.ConvergeStop{} -> True
_ -> False
-- | The same script sent as text, as @{"line"}@ and as @{"verb", "seed"}@.
bodyFormsAgree :: IO ()
bodyFormsAgree = do
results <- forM forms $ \(name, encodeBody) -> withRunning $ \running -> do
kinds <- fmap concat $ forM script $ \l -> do
(code, v) <- uncurry (postAs running) (encodeBody l)
assertEqual ("status of " <> name <> ": " <> l) 200 code
pure (maybe [] (fmap kindOf) (arrayMaybe v))
w <- finish running
ups <- readIORef (runningUps running)
pure (sort kinds, ups, worldShape w)
case results of
(r0 : rest) -> forM_ rest (assertEqual "every body form gives the text form's reports, ups and world" r0)
[] -> pure ()
where
script = ["supervise off", "up n1", "up n1 n2", "down n1", "history"]
forms =
[ ("text", \l -> ("text/plain", l))
, ("line", \l -> ("application/json", jsonObject [("line", jsonString l)]))
, ("verb+seed", \l -> let (v : seed) = words l in ("application/json", jsonObject [("verb", jsonString v), ("seed", "[" <> commaSep (fmap jsonString seed) <> "]")]))
]
jsonString x = show x
jsonObject kvs = "{" <> commaSep [show k <> ":" <> v | (k, v) <- kvs] <> "}"
commaSep = foldr1' (\a b -> a <> "," <> b)
foldr1' _ [] = ""
foldr1' f xs = foldr1 f xs
arrayMaybe v = case v of Array xs -> Just (toList xs); _ -> Nothing
badStructuredBodies :: IO ()
badStructuredBodies =
withRunning $ \running -> do
forM_
[ ("both forms", "{\"line\": \"up n1\", \"verb\": \"up\"}")
, ("neither form", "{}")
, ("a seed with a line", "{\"line\": \"up n1\", \"seed\": [\"n1\"]}")
, ("a seed that is not a list of words", "{\"verb\": \"up\", \"seed\": 3}")
, ("a newline in a word", "{\"verb\": \"up\", \"seed\": [\"a\\nhistory\"]}")
]
$ \(why, body) -> do
(code, _) <- postAs running "application/json" body
assertEqual ("400 for " <> why) 400 code
-- and nothing was declared by any of them
(_, hist) <- get running "/history"
assertEqual "no declaration was made" 0 (length (maybe [] arrayOf (field "seeds" hist)))
structuredRoundTrips :: IO ()
structuredRoundTrips =
forM_ seeds $ \seed ->
assertEqual ("the seed " <> show seed) (Right (Serve.Declare Serve.Add seed)) (Serve.parseServeCommand (Http.renderStructured "up" seed))
where
seeds = [["a", "b"], ["with space", "x"], ["it's", "say \"hi\""], ["back\\slash"], [""], []]
readsDuringLongUp :: IO ()
readsDuringLongUp =
withRunning $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "up n1"
seqNo <- async running ("up " <> slowName)
assertBool "a later number than the earlier commands'" (seqNo >= 2)
-- the loop is now inside the slow node's up
started <- timeout (10 * 1000000) (takeMVar (slowStarted (runningSlow running)))
assertEqual "the slow up was entered" (Just ()) started
-- and reads answer without waiting for it
(code, v) <- get running "/status"
assertEqual "status answers" 200 code
let nodes = maybe [] arrayOf (field "nodes" v)
assertEqual "the earlier seed's nodes plus the slow seed's" 4 (length nodes)
let slowNode = [n | n <- nodes, textAt ["help"] n == Just ("node " <> Text.pack slowName)]
assertEqual "the slow node is still pending" [Just "pending"] (fmap (textAt ["convergence"]) slowNode)
(code', v') <- get running "/dag"
assertEqual "dag answers" 200 code'
nodes' <- dagNodes v'
assertEqual "dag has the same nodes" 4 (length nodes')
(code'', _) <- get running "/history"
assertEqual "history answers" 200 code''
-- let it go, and make sure the loop is past it before ending
putMVar (slowGate (runningSlow running)) ()
_ <- sync running "status"
(_, after) <- get running "/status"
let slowAfter = [n | n <- maybe [] arrayOf (field "nodes" after), textAt ["help"] n == Just ("node " <> Text.pack slowName)]
assertEqual "the slow node converged once let go" [Just "converged"] (fmap (textAt ["convergence"]) slowAfter)
theOtherReads :: IO ()
theOtherReads =
withRunning $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "up n1"
_ <- sync running "down n1"
(code, h) <- get running "/help/seed"
assertEqual "help status" 200 code
assertEqual "the seed help is the text the binary supplied" (Just seedHelp) (textAt ["seed"] h)
assertBool "the command reference is there" (not (null (maybe [] arrayOf (field "commands" h))))
(hcode, hist) <- get running "/history"
assertEqual "history status" 200 hcode
assertEqual "kind" (Just "history") (textAt ["kind"] hist)
assertEqual "two declarations" 2 (length (maybe [] arrayOf (field "seeds" hist)))
assertEqual "nothing elided" (Just (Number 0)) (field "elided" hist)
(scode, st) <- get running "/status"
assertEqual "status status" 200 scode
assertEqual "kind" (Just "status") (textAt ["kind"] st)
-- and the same object the loop's own `status` produces, plus the
-- event stream's cursor (milestone 4)
assertBool "the read carries seq" (isJust (field "seq" st))
_ <- sync running "status"
own <- runningOwn running
let fromLoop = [toJSON t | t@(Tagged.FromServe Serve.StatusReport{}) <- own]
assertEqual "the same object --json prints" [withoutSeq st] fromLoop
(nf, _) <- get running "/nope"
assertEqual "unknown route" 404 nf
(mna, _) <- post running "/dag" "status"
assertEqual "wrong method" 405 mna
(bad, _) <- post running "/command" "status\nhistory"
assertEqual "two lines in one body" 400 bad
{- | @--http-read-only@: nothing typed over HTTP reaches the loop, whatever
the line (a declaration, @clear@, @quit@, even @status@), sync, async or as
a JSON body; the reads answer and stdin still declares. Without the flag
@\/access@ says read-write.
-}
readOnlyRefusesCommands :: IO ()
readOnlyRefusesCommands = do
withRunning $ \running -> do
(code, v) <- get running "/access"
assertEqual "access status" 200 code
assertEqual "the default is read-write" (Just "read-write") (textAt ["access"] v)
(ups, w) <- withRunningAccess Http.ReadOnly (pure Serve.Interactive) $ \running -> do
(code, v) <- get running "/access"
assertEqual "access status" 200 code
assertEqual "the server says it is read-only" (Just "read-only") (textAt ["access"] v)
forM_ ["up n1", "clear", "quit", "supervise off", "converge", "status"] $ \l -> do
(sc, sv) <- post running "/command" l
assertEqual ("sync " <> l) 403 sc
assertBool ("the refusal says why: " <> show sv) (maybe False ("read-only" `Text.isInfixOf`) (textAt ["error"] sv))
(ac, _) <- post running "/command?async" l
assertEqual ("async " <> l) 403 ac
(jc, _) <- postAs running "application/json" "{\"verb\": \"up\", \"seed\": [\"n1\"]}"
assertEqual "a JSON body" 403 jc
-- the reads still answer, and nothing above declared anything
(hc, hist) <- get running "/history"
assertEqual "history status" 200 hc
assertEqual "no declaration came in over HTTP" 0 (length (maybe [] arrayOf (field "seeds" hist)))
(dc, _) <- get running "/dag"
assertEqual "dag status" 200 dc
(mna, _) <- post running "/access" "status"
assertEqual "access takes no POST" 405 mna
-- the operator's own channel is not the HTTP server's to restrict
hPutStr (runningStdin running) "up n1\n"
w <- finish running
ups <- readIORef (runningUps running)
pure (ups, w)
assertEqual "stdin's declaration was applied, and only it" (Map.fromList [("n1", 1)]) ups
assertEqual "one declaration in the world" 1 (length w.worldEpochs)
theWebUi :: IO ()
theWebUi =
withRunning $ \running -> do
(code, ctype, body) <- getRaw running "/"
assertEqual "the page's status" 200 code
assertEqual "the page's content type" (Just "text/html; charset=utf-8") ctype
assertBool "the page is HTML" ("<!doctype html>" `LChar8.isPrefixOf` body)
assertBool "the page loads the script" ("ui/ui.js" `isInfixOf` LChar8.unpack body)
(jcode, jtype, js) <- getRaw running "/ui/ui.js"
assertEqual "the script's status" 200 jcode
assertEqual "the script's content type" (Just "text/javascript; charset=utf-8") jtype
assertBool "the script subscribes from the snapshot's seq" ("events?since=" `isInfixOf` LChar8.unpack js)
assertBool "the script's writes are asynchronous commands" ("command?async" `isInfixOf` LChar8.unpack js)
assertBool "the script's seed form reads the seed's help" ("help/seed" `isInfixOf` LChar8.unpack js)
assertBool "the script never sends quit" (not ("post(\"quit\"" `isInfixOf` LChar8.unpack js) && not ("data-line=\"quit\"" `isInfixOf` LChar8.unpack body))
(ccode, ctype', _) <- getRaw running "/ui/ui.css"
assertEqual "the stylesheet's status" 200 ccode
assertEqual "the stylesheet's content type" (Just "text/css; charset=utf-8") ctype'
-- tail templates are opt-in: the page names neither file, the script
-- imports them only on demand, and both are embedded (no third-party fetch)
assertBool "the page loads no template code" (not ("tail-template" `isInfixOf` LChar8.unpack body) && not ("card-template" `isInfixOf` LChar8.unpack body) && not ("vendor/" `isInfixOf` LChar8.unpack body))
assertBool "the script imports the evaluator lazily" ("import(\"./vendor/tramaj-js/index.js\")" `isInfixOf` LChar8.unpack js)
assertBool "the script has no static import" (not (any ("import " `isPrefixOf`) (lines (LChar8.unpack js))))
forM_ ["/ui/tail-template.js", "/ui/card-template.js", "/ui/vendor/tramaj-js/index.js", "/ui/vendor/tramaj-js/eval.js"] $ \path -> do
(vcode, vtype, _) <- getRaw running path
assertEqual (path <> "'s status") 200 vcode
assertEqual (path <> "'s content type") (Just "text/javascript; charset=utf-8") vtype
(missing, _) <- get running "/ui/missing"
assertEqual "a file outside the embedded set" 404 missing
(mna, _) <- post running "/" "status"
assertEqual "the page takes no POST" 405 mna
_ <- finish running
pure ()
-------------------------------------------------------------------------------
-- | The same script on one stdin, for the comparison: side effects, world,
-- and the kinds of every report the loop produced for its lines.
runScript :: [String] -> IO (Map String Int, Map String Int, World Spec Spec, [Text])
runScript script = do
upsRef <- newIORef Map.empty
downsRef <- newIORef Map.empty
slow <- Slow <$> newEmptyMVar <*> newEmptyMVar
(own, seen) <- capture
w <- withScript script $ \h ->
Serve.serveWith [] Nothing True (Tagged.serveStream own) (Tagged.updownStream own) parseSpec (Configure pure) (spyProgram slow upsRef downsRef) h
reports <- seen
let kinds = [k | t <- reports, let k = kindOf (toJSON t), k `notElem` ["started", "stopped"]]
(,,,) <$> readIORef upsRef <*> readIORef downsRef <*> pure w <*> pure kinds
withScript :: [String] -> (Handle -> IO a) -> IO a
withScript ls act =
withSystemTempFile "salmon-serve-http-script" $ \path h -> do
hPutStr h (unlines ls)
hClose h
withFile path ReadMode act
-- | The comparable part of a 'World', as 'Test.ServeSocketSpec' takes it.
worldShape :: World Spec Spec -> (Map Ref (Direction, Convergence), Set.Set Ref, Int, Int, Int)
worldShape w =
( Map.map (\st -> (st.nodeDirection, st.nodeConvergence)) w.worldNodes
, Map.keysSet w.worldMagma
, Map.size w.worldLedger
, length w.worldEpochs
, length w.worldLog
)
{- | The @mode@ on @\/dag@ is read from the server's accessor at the moment
of the read, not fixed when the server starts: the same accessor is what
@\/status@ opens with, and the loop's mode moves (@replay@ turns to
@following@ at the first full round, "Salmon.Actions.Follow").
-}
dagCarriesMode :: IO ()
dagCarriesMode = do
modeRef <- newIORef Serve.Replay
withRunningMode (readIORef modeRef) $ \running -> do
_ <- sync running "supervise off"
_ <- sync running "up n1"
(code, v) <- get running "/dag"
assertEqual "status" 200 code
assertEqual "the mode the accessor answered" (Just "replay") (textAt ["mode"] v)
(_, st) <- get running "/status"
assertEqual "/status agrees" (Just "replay") (textAt ["mode"] st)
atomicModifyIORef' modeRef (const (Serve.Following, ()))
(_, v') <- get running "/dag"
assertEqual "the mode after the accessor moved" (Just "following") (textAt ["mode"] v')
(_, st') <- get running "/status"
assertEqual "/status moved with it" (Just "following") (textAt ["mode"] st')
_ <- finish running
pure ()
{- | @GET \/openapi.json@ answers the very bytes the binary embeds, and every
operation the document describes is one the loop answers (anything but the
@404@ of an unknown route). The other direction — a route in the code the
document does not describe — is "Test.ServeApiSpec"'s source comparison.
-}
openApiServed :: IO ()
openApiServed =
withRunning $ \running -> do
(code, ctype, body) <- getRaw running "/openapi.json"
assertEqual "status" 200 code
assertEqual "content type" (Just "application/json") ctype
assertEqual "the embedded document" (LChar8.fromStrict Http.openApiDocument) body
forM_ Api.unixRoutes $ \(method, template) -> do
let route = Text.unpack (Text.replace "{file}" "ui.js" template)
req0 <- HTTP.parseRequest ("http://salmon" <> route)
let req = req0{HTTP.method = LChar8.toStrict (LChar8.pack (Text.unpack method))}
-- the status line only: /events never ends
status <- HTTP.withResponse req (runningManager running) (pure . HTTP.statusCode . HTTP.responseStatus)
assertBool (Text.unpack method <> " " <> route <> " is documented but answers 404") (status /= 404)