tricu

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

a7f07a7134d34494dc2fbd66e854a2a9308c6f169dba1951a385e3a9fa9658f4.tri (8454B)

      1 !import prelude *
      2 !import io *
      3 !import http *
      4 !import socket *
      5 !import patterns *
      6 !import arboricx *
      7 !export *
      8 
      9 -- ---------------------------------------------------------------------------
     10 -- Store layout helpers
     11 -- ---------------------------------------------------------------------------
     12 
     13 pathJoin a b = append a (append "/" b)
     14 
     15 objectDir root shard =
     16   pathJoin (pathJoin root "objects") shard
     17 
     18 hashShard hash =
     19   matchList
     20     t
     21     (h0 r0 :
     22       matchList
     23         (pair h0 t)
     24         (h1 r1 :
     25           matchList
     26             (pair h0 (pair h1 t))
     27             (h2 _ :
     28               pair h0 (pair h1 (pair h2 t)))
     29             r1)
     30         r0)
     31     hash
     32 
     33 bundleObjectPath root hash =
     34   pathJoin
     35     (objectDir root (hashShard hash))
     36     (append hash ".arboricx")
     37 
     38 bundleTmpPath root hash time =
     39   pathJoin
     40     (pathJoin root "tmp")
     41     (append hash ".tmp")
     42 
     43 -- ---------------------------------------------------------------------------
     44 -- Store initialization
     45 -- ---------------------------------------------------------------------------
     46 
     47 ensureDir path =
     48   void (createDirectory path)
     49 
     50 ensureStore root =
     51   foldl
     52     thenIO
     53     (pure (ok t t))
     54     [(ensureDir root)
     55      (ensureDir (pathJoin root "tmp"))
     56      (ensureDir (pathJoin root "objects"))
     57      (ensureDir (pathJoin root "aliases"))
     58      (ensureDir (pathJoin (pathJoin root "aliases") "names"))
     59      (ensureDir (pathJoin (pathJoin root "aliases") "packages"))
     60      (ensureDir (pathJoin root "manifests"))]
     61 
     62 -- ---------------------------------------------------------------------------
     63 -- Bundle object write
     64 -- ---------------------------------------------------------------------------
     65 
     66 putBundleWrite root bundleBytes hash shard tmpPath finalPath =
     67   do onOk_
     68     _ <- mapErrIO "createDirectory: " (createDirectory (objectDir root shard))
     69     _ <- mapErrIO "writeBytes: " (writeBytes tmpPath bundleBytes)
     70     _ <- mapErrIO "renameFile: " (renameFile tmpPath finalPath)
     71     pure (ok hash t)
     72 
     73 putBundleWithHash root bundleBytes time hash =
     74   let shard = hashShard hash in
     75   let tmpPath = bundleTmpPath root hash time in
     76   let finalPath = bundleObjectPath root hash in
     77   putBundleWrite root bundleBytes hash shard tmpPath finalPath
     78 
     79 putBundle root bundleBytes =
     80   do onOk_
     81     time <- mapErrIO "currentTime: " currentTime
     82     hash <- mapErrIO "sha256Hex: " (sha256Hex bundleBytes)
     83     savedHash <- mapErrIO "withHash: " (putBundleWithHash root bundleBytes time hash)
     84     pure (ok savedHash t)
     85 
     86 -- ---------------------------------------------------------------------------
     87 -- Bundle identifiers
     88 -- ---------------------------------------------------------------------------
     89 
     90 -- Exact canonical lowercase SHA-256 spelling. Equality against finite byte
     91 -- literals also rejects malformed numeral trees without traversing them fully.
     92 bundleHexByte? byte = (boolOr?
     93   (boolOr?
     94     (boolOr? (equal? byte 48) (equal? byte 49))
     95     (boolOr? (equal? byte 50) (equal? byte 51)))
     96   (boolOr?
     97     (boolOr?
     98       (boolOr? (equal? byte 52) (equal? byte 53))
     99       (boolOr? (equal? byte 54) (equal? byte 55)))
    100     (boolOr?
    101       (boolOr? (equal? byte 56) (equal? byte 57))
    102       (boolOr?
    103         (boolOr? (equal? byte 97) (equal? byte 98))
    104         (boolOr?
    105           (boolOr? (equal? byte 99) (equal? byte 100))
    106           (boolOr? (equal? byte 101) (equal? byte 102)))))))
    107 
    108 -- Consume the input before the counter. Reject a 65th cons without inspecting
    109 -- its byte or suffix; Stem spines are invalid, not ordinary list eliminations.
    110 bundleHashValid_ self hash remaining =
    111   ((triage
    112     (_ : isZero_? remaining)
    113     (_ _ : false)
    114     (byte rest : (_ : lazyBool
    115       (_ : false)
    116       (_ : lazyBool
    117         (_ : self rest (pred_ remaining))
    118         (_ : false)
    119         (bundleHexByte? byte))
    120       (isZero_? remaining)))
    121     hash) t)
    122 
    123 bundleHashValid? hash = y bundleHashValid_ hash 64
    124 
    125 bundleHashC = guardC "expected 64 lowercase hexadecimal hash characters" bundleHashValid?
    126 
    127 -- ---------------------------------------------------------------------------
    128 -- Bundle object fetch
    129 -- ---------------------------------------------------------------------------
    130 
    131 -- IO (Result bytes rest), with HTTP failures err status message. The contract's
    132 -- diagnostic/remainder protocol is deliberately translated here, before IO.
    133 getBundleByHash root hash = (lazyResult
    134   (diagnostic _ : pure (err 400 diagnostic))
    135   (checked _ : onResult_ (readFile (bundleObjectPath root checked))
    136     (errMsg : pure (err 404 errMsg))
    137     (bytes : pure (ok bytes t)))
    138   (checkContract bundleHashC hash))
    139 
    140 -- ---------------------------------------------------------------------------
    141 -- Route prefix helper
    142 -- ---------------------------------------------------------------------------
    143 
    144 stripPrefix_ self input prefix =
    145   lazyList
    146     (_ :
    147       lazyList
    148         (_ : just t)
    149         (_ _ : nothing)
    150         prefix)
    151     (ih ir :
    152       lazyList
    153         (_ : just input)
    154         (ph pr :
    155           lazyBool
    156             (_ : self ir pr)
    157             (_ : nothing)
    158             (equal? ih ph))
    159         prefix)
    160     input
    161 
    162 stripPrefix prefix input =
    163   y stripPrefix_ input prefix
    164 
    165 bundleHashPrefix = "/_arboricx/bundle/hash/"
    166 bundlePath = "/_arboricx/bundle"
    167 healthPath = "/_arboricx/health"
    168 bundleContentType = "application/vnd.arboricx.bundle"
    169 
    170 -- ---------------------------------------------------------------------------
    171 -- Landing page
    172 -- ---------------------------------------------------------------------------
    173 
    174 -- TODO: Let's replace in-line HTML with the ability to read and serve files
    175 -- from a public/ folder.
    176 
    177 htmlLandingPage = "<!DOCTYPE html><html><head><meta name='viewport' content='width=device-width, initial-scale=1'><title>Arboricx Server</title></head><body><h1>Arboricx Server</h1><p>Bundle registry</p><p><a href='https://git.eversole.co/James/tricu'>Made with Love (and trees, lots of trees)</a></p></body></html>"
    178 
    179 -- ---------------------------------------------------------------------------
    180 -- Registry routes
    181 -- ---------------------------------------------------------------------------
    182 
    183 bundleResponse bytes = response 200 bundleContentType bytes
    184 
    185 serveBundleHash root hash =
    186   onResult (getBundleByHash root hash)
    187     (status message : pure (errorResponse status message))
    188     (bytes _ : pure (bundleResponse bytes))
    189 
    190 healthRoute method target =
    191   cond
    192     [(guard (_ : equal? method "GET") (_ : getHealth))
    193      (guard (_ : true) (_ : pure notFoundResponse))]
    194   where getHealth =
    195     cond
    196       [(guard (_ : equal? target healthPath) (_ : pure (okResponse "OK\n")))
    197        (guard (_ : true) (_ : pure notFoundResponse))]
    198 
    199 putBundleRoute root method target body =
    200   cond
    201     [(guard (_ : equal? method "POST") (_ : postBundle))
    202      (guard (_ : true) (_ : pure notFoundResponse))]
    203   where postBundle =
    204     cond
    205       [(guard (_ : equal? target bundlePath) (_ : handleUpload))
    206        (guard (_ : true) (_ : pure notFoundResponse))]
    207   where handleUpload =
    208     onResult_ (putBundle root body)
    209       (err : pure (badRequestResponse (append "Upload failed: " err)))
    210       (hash : pure (createdResponse hash))
    211 
    212 getBundleRoute root method target =
    213   cond
    214     [(guard (_ : equal? method "GET") (_ : getBundle))
    215      (guard (_ : true) (_ : pure notFoundResponse))]
    216   where getBundle =
    217     lazyMaybe
    218       (_ : pure notFoundResponse)
    219       (hash : serveBundleHash root hash)
    220       (stripPrefix bundleHashPrefix target)
    221 
    222 arboricxRouter root method target headers body =
    223   cond
    224     [(guard (_ : equal? method "GET") (_ : getRoutes))
    225      (guard (_ : equal? method "POST") (_ : putBundleRoute root method target body))
    226      (guard (_ : true) (_ : pure notFoundResponse))]
    227   where getRoutes =
    228     cond
    229       [(guard (_ : equal? target "/") (_ : pure (htmlResponse htmlLandingPage)))
    230        (guard (_ : true) (_ : getBundleOrHealth))]
    231   where getBundleOrHealth =
    232     lazyMaybe
    233       (_ : healthRoute method target)
    234       (hash : serveBundleHash root hash)
    235       (stripPrefix bundleHashPrefix target)
    236 
    237 -- ---------------------------------------------------------------------------
    238 -- Server entrypoint
    239 -- ---------------------------------------------------------------------------
    240 
    241 arboricxHandler root = (client peer :
    242   httpHandlerIO
    243     (method target headers body :
    244       arboricxRouter root method target headers body)
    245     client
    246     peer)
    247 
    248 arboricxServer root addr port =
    249   onResult_ (listenSocket addr port 128)
    250     (errMsg : pure (err errMsg t))
    251     (server :
    252       serveForever server (arboricxHandler root))