tricu

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

publish.tri (3223B)

      1 !import base as B
      2 !import io_v2 as IO
      3 !import io_v2_artifacts as Artifacts
      4 !import handlers as H
      5 !export failedAfterFull
      6 !export invalidChunk
      7 !export badDigest
      8 !export nestedProducer
      9 !export forkedProducer
     10 !export publish
     11 !export cancelled
     12 !export earlySuccess
     13 !export ignoresWriteFailure
     14 !export emptyChunk
     15 !export overrideWrite
     16 !export rejectedDestination
     17 !export malformedDestination
     18 
     19 pump reader = H.bind (H.liftIO (IO.readSome reader 4096)) (reply : case reply of
     20   ((t t), (("eof", t), t)) = H.pure (B.ok t t)
     21   ((t t), (("data", bytes), t)) = H.bind (Artifacts.write bytes) (written : case written of
     22     ((t t), (t, t)) = pump reader
     23     _ = H.pure written)
     24   (t, (_, t)) = H.pure reply
     25   _ = H.fail "invalid-response" "reader" "read" "Invalid read reply")
     26 
     27 publish source directory expected = IO.io <| IO.scope (owner : IO.require
     28   (IO.openReader owner source) (reader :
     29     H.runIOV2 (Artifacts.publish directory expected (H.label "file-producer" (pump reader)))))
     30 
     31 cancelled directory = IO.io <| H.runIOV2 (Artifacts.publish directory 3 (do H.bind
     32   Artifacts.write [97 98 99]
     33   H.liftIO (IO.cancelled "producer cancelled")))
     34 earlySuccess directory = IO.io <| H.runIOV2 (Artifacts.publish directory 3 (H.pure (B.ok t t)))
     35 ignoresWriteFailure directory = IO.io <| H.runIOV2 (Artifacts.publish directory 1 (do H.bind
     36   Artifacts.write [97 98 99]
     37   H.pure (B.ok t t)))
     38 emptyChunk directory = IO.io <| H.runIOV2 (Artifacts.publish directory 0 (do H.bind
     39   Artifacts.write []
     40   H.pure (B.ok t t)))
     41 acknowledge _ _ = H.pure (B.ok t t)
     42 overrideWrite directory = IO.io <| H.runIOV2 (Artifacts.publish directory 3
     43   (H.handle "artifact-stream" acknowledge (do H.bind
     44     Artifacts.write [97 98 99]
     45     H.pure (B.ok t t))))
     46 
     47 failedAfterFull directory = IO.io <| H.runIOV2 (Artifacts.publish directory 3 (do H.bind
     48   Artifacts.write [97 98 99]
     49   H.pure (B.err "Producer failed" t)))
     50 invalidChunk directory = IO.io <| H.runIOV2 (Artifacts.publish directory 1 (do H.bind
     51   Artifacts.write [256]
     52   H.pure (B.ok t t)))
     53 corruptDigest "run" (10, ("digest", (1, ("finish", _)))) = H.pure (B.ok "../escape" t)
     54 corruptDigest operation argument = H.forward "host.io" operation argument
     55 observe computation = IO.io <| IO.require
     56   (IO.spawn 1 1 [] (_ : H.runIOV2 computation))
     57   (spawned : case spawned of
     58     [task ticket] = IO.require (IO.join ticket) IO.pure
     59     _ = IO.fail "Invalid spawn reply")
     60 badDigest directory = observe (H.handle "host.io" corruptDigest
     61   (Artifacts.publish directory 3 (do H.bind
     62     Artifacts.write [97 98 99]
     63     H.pure (B.ok t t))))
     64 
     65 observeBoundary directory producer = observe (H.label "outer"
     66   (Artifacts.publish directory 0 (H.label "inner" producer)))
     67 nestedProducer directory = observeBoundary directory (H.scopeV2 (_ : H.pure (B.ok t t)))
     68 forkedProducer directory = observeBoundary directory (H.spawnV2 0 0 [] (_ : H.pure (B.ok t t)))
     69 rejectedDestination directory = IO.io (H.runIOV2 (Artifacts.publishWith directory 3
     70   (_ : H.pure (B.err "Destination rejected" t)) (do H.bind
     71     Artifacts.write [97 98 99]
     72     H.pure (B.ok t t))))
     73 malformedDestination directory = observe (Artifacts.publishWith directory 3
     74   (_ : H.pure 0) (do H.bind
     75     Artifacts.write [97 98 99]
     76     H.pure (B.ok t t)))