tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

consumer_registry_linked.tri (3094B)

      1 -- Fresh verified source composition for the general-source registry profile.
      2 -- The application owns root/path policy; the library owns IR and worker prep.
      3 !import "prelude" !Local
      4 !import "io" !Local
      5 !import "consumers.module" M
      6 !import "consumers.link" CL
      7 !import "consumers.lexical-worker" L
      8 !import "consumers.validate" V
      9 !import "lexer" Position
     10 !import "consumers.structural" S
     11 !import "consumers.effect" E
     12 !import "source.resolve" Resolve
     13 
     14 root = "__ROOT__"
     15 row alias hash name = pair alias (pair hash name)
     16 stage = do onOk_
     17   prefixSource <- readFile "lib/consumer/stripPrefix.scp"
     18   prefixHash <- M.cmPutSource root prefixSource
     19   bundleSource <- readFile "demos/consumers/registry/registry-bundle.scp"
     20   bundleHash <- M.cmPutSource root bundleSource
     21   pathSource <- readFile "lib/consumer/pathWithState.scp"
     22   pathHash <- M.cmPutSource root pathSource
     23   entrySource <- readFile "demos/consumers/registry/registry-entry.scp"
     24   entryHash <- M.cmPutSource root entrySource
     25   M.cmPutImports root [(row "prefix" prefixHash "stripPrefix")
     26     (row "bundle" bundleHash "registryBundle")
     27     (row "path" pathHash "pathWithState")
     28     (row "entry" entryHash "registryEntry")]
     29 lookup workers alias = (lazyMaybe (_ : t) (worker : worker)
     30   (Resolve.sourceFindExternal workers alias))
     31 prepare descriptor = CL.clPrepare root descriptor [
     32   (pair "prefix" "/_arboricx/bundle/hash/")
     33   (pair "bundle" t) (pair "path" t) (pair "entry" t)]
     34 readBundle argument = pure (err "absent" t)
     35 run request = (onOk_ stage (descriptor : onOk_ (prepare descriptor) (prepared :
     36   let manifest = fst prepared in
     37   let workers = fst (snd prepared) in
     38   let sourcePositions = snd (snd prepared) in
     39   let diagnostic = V.vDiagnostic "malformed" 0 ["output"] "unknown capture" in
     40   let entryOutput = CL.clProblemLocation diagnostic sourcePositions "entry" in
     41   let prefix = lookup workers "prefix" in
     42   let bundle = lookup workers "bundle" in
     43   onOk_ (CL.clCompileSelected root manifest "path" (pair prefix bundle)) (path :
     44     onOk_ (CL.clCompileSelected root manifest "entry" (pair path root)) (entry :
     45       lazyBool
     46         (_ : E.run L.lEffectStep
     47           [(pair "registryEntry" (S.makeConsumer t entry))
     48            (pair "registryBundle" (S.makeConsumer t bundle))]
     49           [(pair "ReadBundle" readBundle)] "registryEntry" request
     50           (pair path root))
     51         (_ : pure (err "missing verified source position" t))
     52         (and? (equal? (Position.lexerPositionLine entryOutput) 3)
     53           (equal? (CL.clProblemLocation diagnostic sourcePositions "absent") t)))))))
     54 health = pair "GET" "/_arboricx/health"
     55 missing = pair "GET" "/_arboricx/bundle/hash/abc999"
     56 main = io (onResult_ (run health)
     57   (problem : putStrLn "registry-link-ERROR")
     58   (healthWire : onResult_ (run missing)
     59     (problem : putStrLn "registry-link-ERROR")
     60     (missingWire : putStrLn (matchBool "registry-link-ok" "registry-link-DIFFER"
     61       (and? (equal? healthWire
     62         (pair 200 (pair "text/plain; charset=utf-8" "OK\n")))
     63         (equal? missingWire
     64           (pair 404 (pair "text/plain; charset=utf-8" "absent"))))))))
     65 main