tricu/lib/arboricx/server.tri

!import "../io.tri"        !Local
!import "../http.tri"      !Local
!import "../socket.tri"    !Local
!import "arboricx.tri"     !Local

-- ---------------------------------------------------------------------------
-- Store layout helpers
-- ---------------------------------------------------------------------------

pathJoin = a b : append a (append "/" b)

objectDir = root shard :
  pathJoin (pathJoin root "objects") shard

hashShard = (hash :
  matchList
    t
    (h0 r0 :
      matchList
        (pair h0 t)
        (h1 r1 :
          matchList
            (pair h0 (pair h1 t))
            (h2 _ :
              pair h0 (pair h1 (pair h2 t)))
            r1)
        r0)
    hash)

bundleObjectPath = (root hash :
  pathJoin
    (objectDir root (hashShard hash))
    (append hash ".arboricx"))

bundleTmpPath = (root hash time :
  pathJoin
    (pathJoin root "tmp")
    (append hash ".tmp"))

-- ---------------------------------------------------------------------------
-- Store initialization
-- ---------------------------------------------------------------------------

ensureDir = path :
  void (createDirectory path)

ensureStore = (root :
  foldl
    thenIO
    (pure (ok t t))
    [(ensureDir root)
     (ensureDir (pathJoin root "tmp"))
     (ensureDir (pathJoin root "objects"))
     (ensureDir (pathJoin root "aliases"))
     (ensureDir (pathJoin (pathJoin root "aliases") "names"))
     (ensureDir (pathJoin (pathJoin root "aliases") "packages"))
     (ensureDir (pathJoin root "manifests"))])

-- ---------------------------------------------------------------------------
-- Bundle object write
-- ---------------------------------------------------------------------------

putBundleWrite = (root bundleBytes hash shard tmpPath finalPath :
  onResult_ (createDirectory (objectDir root shard))
    (e : pure (err (append "createDirectory: " e) t))
    (_ :
      onResult_ (writeBytes tmpPath bundleBytes)
        (e : pure (err (append "writeBytes: " e) t))
        (_ :
          onResult_ (renameFile tmpPath finalPath)
            (e : pure (err (append "renameFile: " e) t))
            (_ : pure (ok hash t)))))

putBundleWithHash = (root bundleBytes time hash :
  putBundleWrite
    root
    bundleBytes
    hash
    (hashShard hash)
    (bundleTmpPath root hash time)
    (bundleObjectPath root hash))

putBundle = (root bundleBytes :
  onResult_ currentTime
    (e : pure (err (append "currentTime: " e) t))
    (time :
      onResult_ (sha256Hex bundleBytes)
        (e : pure (err (append "sha256Hex: " e) t))
        (hash :
          bind (putBundleWithHash root bundleBytes time hash) (r :
            matchResult
              (e _ : pure (err (append "withHash: " e) t))
              (v _ : pure (ok v t))
              r))))

-- ---------------------------------------------------------------------------
-- Bundle object fetch
-- ---------------------------------------------------------------------------

getBundleByHash = (root hash :
  onResult_ (readFile (bundleObjectPath root hash))
    (errMsg : pure (err errMsg t))
    (bytes : pure (ok bytes t)))

-- ---------------------------------------------------------------------------
-- Route prefix helper
-- ---------------------------------------------------------------------------

stripPrefix_ = (self input prefix :
  lazyList
    (_ :
      lazyList
        (_ : just t)
        (_ _ : nothing)
        prefix)
    (ih ir :
      lazyList
        (_ : just input)
        (ph pr :
          lazyBool
            (_ : self ir pr)
            (_ : nothing)
            (equal? ih ph))
        prefix)
    input)

stripPrefix = (prefix input :
  y stripPrefix_ input prefix)

bundleHashPrefix = "/_arboricx/bundle/hash/"

-- ---------------------------------------------------------------------------
-- Registry routes
-- ---------------------------------------------------------------------------

healthRoute = (method target :
  lazyBool
    (_ :
      lazyBool
        (_ : pure (okResponse "OK\n"))
        (_ : pure notFoundResponse)
        (equal? target "/_arboricx/health"))
    (_ : pure notFoundResponse)
    (equal? method "GET"))

putBundleRoute = (root method target body :
  lazyBool
    (_ :
      lazyBool
        (_ :
          bind (putBundle root body) (result :
            matchResult
              (err _ : pure (badRequestResponse (append "Upload failed: " err)))
              (hash _ : pure (createdResponse hash))
              result))
        (_ : pure notFoundResponse)
        (equal? target "/_arboricx/bundles"))
    (_ : pure notFoundResponse)
    (equal? method "POST"))

getBundleRoute = (root method target :
  lazyBool
    (_ :
      lazyMaybe
        (_ : pure notFoundResponse)
        (hash :
          bind (getBundleByHash root hash) (result :
            matchResult
              (errMsg _ : pure (errorResponse 404 errMsg))
              (bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
              result))
        (stripPrefix bundleHashPrefix target))
    (_ : pure notFoundResponse)
    (equal? method "GET"))

arboricxRouter = (root method target headers body :
  lazyBool
    (_ :
      lazyMaybe
        (_ : healthRoute method target)
        (hash :
          bind (getBundleByHash root hash) (result :
            matchResult
              (errMsg _ : pure (errorResponse 404 errMsg))
              (bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
              result))
        (stripPrefix bundleHashPrefix target))
    (_ :
      lazyBool
        (_ : putBundleRoute root method target body)
        (_ : pure notFoundResponse)
        (equal? method "POST"))
    (equal? method "GET"))

-- ---------------------------------------------------------------------------
-- Server entrypoint
-- ---------------------------------------------------------------------------

arboricxHandler = (root client peer :
  httpHandlerIO
    (method target headers body :
      arboricxRouter root method target headers body)
    client
    peer)

arboricxServer = (root addr port :
  onResult_ (listenSocket addr port 128)
    (errMsg : pure (err errMsg t))
    (server :
      serveForever server (arboricxHandler root)))