!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

bundleObjectPath = (root hash :
  ((shard : pathJoin (objectDir root shard) (append hash ".arboricx"))
   (take 3 hash)))

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

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
    (take 3 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)))

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

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

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

getBundleRoute = (root method target :
  matchBool
    ((hash :
      bind (getBundleByHash root hash) (result :
        matchResult
          (errMsg _ : pure (errorResponse 404 errMsg))
          (bytes _ : pure (response 200 "application/vnd.arboricx.bundle" bytes))
          result))
     (drop 23 target))
    (pure notFoundResponse)
    (and? (equal? method "GET") (startsWith? "/_arboricx/bundle/hash/" target)))

arboricxRouter = (root method target headers body :
  matchBool
    (getBundleRoute root method target)
    (matchBool
      (putBundleRoute root method target body)
      (matchBool
        (healthRoute method target)
        (pure notFoundResponse)
        (and? (equal? method "GET") (equal? target "/_arboricx/health")))
      (and? (equal? method "POST") (equal? target "/_arboricx/bundles")))
    (and? (equal? method "GET") (startsWith? "/_arboricx/bundle/hash/" target)))

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

arboricxHandler = (root client peer :
  httpHandlerIO (arboricxRouter root) client peer)

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