consumer_registry_phases.tri (3217B)
1 -- Cold verified-source registry request with real ReadBundle and HTTP response. 2 !import "prelude" !Local 3 !import "io" !Local 4 !import "consumers.module" M 5 !import "consumers.link" CL 6 !import "consumers.lexical-worker" X 7 !import "consumers.structural" S 8 !import "consumers.effect" E 9 !import "consumers.registry-base" R 10 !import "consumers.comparison.registry-lambda" Baseline 11 !import "source.resolve" Resolve 12 13 sourceRoot = "__ROOT__/cas" 14 appRoot = "__ROOT__/app" 15 expectedLength = __EXPECTED_LENGTH__ 16 mode = "__MODE__" 17 request = pair "GET" "/_arboricx/bundle/hash/__HASH__" 18 row alias hash name = pair alias (pair hash name) 19 stage = do onOk_ 20 prefixSource <- readFile "lib/consumer/stripPrefix.scp" 21 prefixHash <- M.cmPutSource sourceRoot prefixSource 22 bundleSource <- readFile "demos/consumers/registry/registry-bundle.scp" 23 bundleHash <- M.cmPutSource sourceRoot bundleSource 24 pathSource <- readFile "lib/consumer/pathWithState.scp" 25 pathHash <- M.cmPutSource sourceRoot pathSource 26 entrySource <- readFile "demos/consumers/registry/registry-entry.scp" 27 entryHash <- M.cmPutSource sourceRoot entrySource 28 M.cmPutImports sourceRoot [(row "prefix" prefixHash "stripPrefix") 29 (row "bundle" bundleHash "registryBundle") 30 (row "path" pathHash "pathWithState") 31 (row "entry" entryHash "registryEntry")] 32 selections = [(pair "prefix" "/_arboricx/bundle/hash/") 33 (pair "bundle" t) (pair "path" t) (pair "entry" t)] 34 lookup workers alias = (lazyMaybe (_ : t) (worker : worker) 35 (Resolve.sourceFindExternal workers alias)) 36 validated linked = (lazyResult 37 (problem _ : pure (err problem t)) 38 (_ _ : pure (ok linked t)) 39 (CL.clValidate linked)) 40 execute entry bundle path = (onResult_ 41 (E.run X.lEffectStep 42 [(pair "registryEntry" (S.makeConsumer t entry)) 43 (pair "registryBundle" (S.makeConsumer t bundle))] 44 [(pair "ReadBundle" R.readBundle)] "registryEntry" request 45 (pair path appRoot)) 46 (_ : putStrLn "WRONG") 47 (wire : let response = R.response wire in 48 putStrLn (matchBool "DONE" "WRONG" 49 (lazyBool 50 (_ : maybe? (Baseline.prefixRest "HTTP/1.1 404" response)) 51 (_ : equal? (length response) expectedLength) 52 (equal? mode "missing"))))) 53 run = (thenIO (putStrLn "READY") (onOk_ stage (descriptor : 54 thenIO (putStrLn "STAGED") 55 (onOk_ (M.cmLoadLocated sourceRoot descriptor) (linked : 56 thenIO (putStrLn "RESOLVED_PARSED") 57 (onOk_ (validated linked) (_ : thenIO (putStrLn "VALIDATED") 58 (onOk_ (M.cmPublishIR sourceRoot (CL.clAuthored linked) 59 (CL.clNames selections)) (manifest : 60 thenIO (putStrLn "PUBLISHED") 61 (onOk_ (CL.clPrepareRows selections sourceRoot manifest 62 (CL.clLocations linked)) (workers : 63 let prefix = lookup workers "prefix" in 64 let bundle = lookup workers "bundle" in 65 onOk_ (CL.clCompileSelected sourceRoot manifest "path" 66 (pair prefix bundle)) (path : 67 onOk_ (CL.clCompileSelected sourceRoot manifest "entry" 68 (pair path appRoot)) (entry : 69 thenIO (putStrLn "WORKERS") 70 (execute entry bundle path)))))))))))))) 71 main = io run 72 main