Implement a minimal server

app/spago.yaml

@@ -30,6 +30,7 @@ package:
     - foreign-object
     - formatters
     - http-methods
+    - httpurple
     - identity
     - integers
     - js-date
@@ -54,6 +55,7 @@ package:
     - partial
     - prelude
     - profunctor
+    - profunctor-lenses
     - refs
     - registry-foreign
     - registry-lib

app/src/App/Effect/Storage.purs

@@ -1,6 +1,7 @@
 -- | An effect for reading and writing to the registry storage backend.
 module Registry.App.Effect.Storage
-  ( STORAGE
+  ( S3Env
+  , STORAGE
   , STORAGE_CACHE
   , Storage
   , StorageCache

app/src/App/Server.purs

@@ -0,0 +1,219 @@
+module Registry.App.Server where
+
+import Registry.App.Prelude hiding ((/))
+
+import Data.Formatter.DateTime as Formatter.DateTime
+import Data.Lens.Iso.Newtype (_Newtype)
+import Data.String as String
+import Effect.Aff as Aff
+import Effect.Class.Console as Console
+import HTTPurple (class Generic, JsonDecoder(..), Method(..), Request, Response, RouteDuplex', (/))
+import HTTPurple as HTTPurple
+import Node.Path as Path
+import Node.Process as Process
+import Registry.App.API (Source(..))
+import Registry.App.API as API
+import Registry.App.Effect.Cache (CacheRef)
+import Registry.App.Effect.Cache as Cache
+import Registry.App.Effect.Env (PACCHETTIBOTTI_ENV)
+import Registry.App.Effect.Env as Env
+import Registry.App.Effect.Git (Debouncer, GIT)
+import Registry.App.Effect.Git as Git
+import Registry.App.Effect.GitHub (GITHUB)
+import Registry.App.Effect.GitHub as GitHub
+import Registry.App.Effect.Log (LOG, LogVerbosity(..))
+import Registry.App.Effect.Log as Log
+import Registry.App.Effect.Notify (NOTIFY)
+import Registry.App.Effect.Notify as Notify
+import Registry.App.Effect.Pursuit (PURSUIT)
+import Registry.App.Effect.Pursuit as Pursuit
+import Registry.App.Effect.Registry (REGISTRY)
+import Registry.App.Effect.Registry as Registry
+import Registry.App.Effect.Storage (STORAGE)
+import Registry.App.Effect.Storage as Storage
+import Registry.App.Legacy.Manifest (LEGACY_CACHE, _legacyCache)
+import Registry.Foreign.FSExtra as FS.Extra
+import Registry.Foreign.Octokit (GitHubToken, Octokit)
+import Registry.Foreign.Octokit as Octokit
+import Registry.Internal.Format as Internal.Format
+import Registry.Operation as Operation
+import Routing.Duplex as Routing
+import Routing.Duplex.Generic as RoutingG
+import Run (AFF, EFFECT, Run)
+import Run as Run
+import Run.Except (EXCEPT)
+import Run.Except as Except
+
+data Route
+  = Publish
+  | Unpublish
+  | Transfer
+  | Jobs JobID
+
+derive instance Generic Route _
+
+newtype JobID = JobID String
+
+instance Newtype JobID String
+
+jobID :: RouteDuplex' JobID
+jobID = _Newtype Routing.segment
+
+routes :: RouteDuplex' Route
+routes = Routing.root $ Routing.prefix "api" $ Routing.prefix "v1" $ RoutingG.sum
+  { "Publish": "publish" / RoutingG.noArgs
+  , "Unpublish": "unpublish" / RoutingG.noArgs
+  , "Transfer": "transfer" / RoutingG.noArgs
+  , "Jobs": "jobs" / jobID
+  }
+
+router :: Request Route -> Run ServerEffects Response
+router { route, method, body } = HTTPurple.usingCont case route, method of
+  Publish, Post -> do
+    publish <- HTTPurple.fromJson (jsonDecoder Operation.publishCodec) body
+
+    -- TODO: This should really be a launchAff_ acknowledging receipt but
+    -- not actualy processing, once we validate the operation is OK, and we
+    -- can return the job ID for polling.
+    -- So we shall:
+    -- - fork the publishing in a fiber
+    -- - stash the fiber in a ref (so we can keep track of how many things are going)
+    -- - generate a job ID
+    -- - make a log file with that job ID
+    -- - change the Notify effect to write to that log file in a structured format (so we can read it back)
+    lift $ API.publish Current publish
+    HTTPurple.ok "Completed publish operation."
+
+  Unpublish, Post -> do
+    auth <- HTTPurple.fromJson (jsonDecoder Operation.authenticatedCodec) body
+    case auth.payload of
+      Operation.Unpublish _ -> do
+        lift $ API.authenticated auth
+        HTTPurple.ok "Completed unpublish operation."
+      _ ->
+        HTTPurple.badRequest "Expected unpublish operation."
+
+  Transfer, Post -> do
+    auth <- HTTPurple.fromJson (jsonDecoder Operation.authenticatedCodec) body
+    case auth.payload of
+      Operation.Transfer _ -> do
+        lift $ API.authenticated auth
+        HTTPurple.ok "Completed transfer operation."
+      _ ->
+        HTTPurple.badRequest "Expected transfer operation."
+
+  Jobs _jobId, _ -> do
+    HTTPurple.ok "TODO"
+
+  _, _ -> HTTPurple.notFound
+
+type ServerEnvVars =
+  { token :: GitHubToken
+  , publicKey :: String
+  , privateKey :: String
+  , spacesKey :: String
+  , spacesSecret :: String
+  }
+
+readServerEnvVars :: Aff ServerEnvVars
+readServerEnvVars = do
+  Env.loadEnvFile ".env"
+  token <- Env.lookupRequired Env.pacchettibottiToken
+  publicKey <- Env.lookupRequired Env.pacchettibottiED25519Pub
+  privateKey <- Env.lookupRequired Env.pacchettibottiED25519
+  spacesKey <- Env.lookupRequired Env.spacesKey
+  spacesSecret <- Env.lookupRequired Env.spacesSecret
+  pure { token, publicKey, privateKey, spacesKey, spacesSecret }
+
+type ServerEnv =
+  { cacheDir :: FilePath
+  , logsDir :: FilePath
+  , githubCacheRef :: CacheRef
+  , legacyCacheRef :: CacheRef
+  , registryCacheRef :: CacheRef
+  , octokit :: Octokit
+  , vars :: ServerEnvVars
+  , debouncer :: Debouncer
+  }
+
+createServerEnv :: Aff ServerEnv
+createServerEnv = do
+  vars <- readServerEnvVars
+
+  let cacheDir = Path.concat [ scratchDir, ".cache" ]
+  let logsDir = Path.concat [ scratchDir, "logs" ]
+  for_ [ cacheDir, logsDir ] FS.Extra.ensureDirectory
+
+  githubCacheRef <- Cache.newCacheRef
+  legacyCacheRef <- Cache.newCacheRef
+  registryCacheRef <- Cache.newCacheRef
+
+  octokit <- Octokit.newOctokit vars.token
+  debouncer <- Git.newDebouncer
+
+  pure { debouncer, githubCacheRef, legacyCacheRef, registryCacheRef, cacheDir, logsDir, vars, octokit }
+
+type ServerEffects = (PACCHETTIBOTTI_ENV + REGISTRY + GITHUB + GIT + STORAGE + PURSUIT + LEGACY_CACHE + NOTIFY + LOG + EXCEPT String + AFF + EFFECT ())
+
+runServer :: ServerEnv -> (Request Route -> Run ServerEffects Response) -> Request Route -> Aff Response
+runServer env router' request = do
+  now <- nowUTC
+  let logFile = String.take 19 (Formatter.DateTime.format Internal.Format.iso8601DateTime now) <> "-" <> String.joinWith "__" request.path <> ".log"
+  let logPath = Path.concat [ env.logsDir, logFile ]
+
+  result <- Aff.attempt do
+    router' request
+      # Env.runPacchettiBottiEnv { publicKey: env.vars.publicKey, privateKey: env.vars.privateKey }
+      # Registry.interpret (Registry.handle env.registryCacheRef)
+      # Git.interpret
+          ( Git.handle
+              { repos: Git.defaultRepos
+              , pull: Git.ForceClean
+              , write: Git.CommitAs (Git.pacchettibottiCommitter env.vars.token)
+              , workdir: scratchDir
+              , debouncer: env.debouncer
+              }
+          )
+      # Pursuit.interpret (Pursuit.handleAff env.vars.token)
+      # GitHub.interpret (GitHub.handle { octokit: env.octokit, cache: env.cacheDir, ref: env.githubCacheRef })
+      # Storage.interpret (Storage.handleS3 { s3: { key: env.vars.spacesKey, secret: env.vars.spacesSecret }, cache: env.cacheDir })
+      # Cache.interpret _legacyCache (Cache.handleMemoryFs { cache: env.cacheDir, ref: env.legacyCacheRef })
+      # Notify.interpret Notify.handleLog
+      # Except.catch (\msg -> Log.error msg *> Run.liftAff (Aff.throwError (Aff.error msg)))
+      # Log.interpret (\log -> Log.handleTerminal Normal log *> Log.handleFs Verbose logPath log)
+      # Run.runBaseAff'
+
+  case result of
+    Left error -> HTTPurple.badRequest (Aff.message error)
+    Right response -> pure response
+
+main :: Effect Unit
+main = do
+  createServerEnv # Aff.runAff_ case _ of
+    Left error -> do
+      Console.log $ "Failed to start server: " <> Aff.message error
+      Process.exit 1
+    Right env -> do
+      _close <- HTTPurple.serve
+        { hostname: "0.0.0.0"
+        , port: 8080
+        , onStarted
+        }
+        { route: routes
+        , router: runServer env router
+        }
+      pure unit
+  where
+  onStarted :: Effect Unit
+  onStarted = do
+    Console.log $ String.joinWith "\n"
+      [ " ┌───────────────────────────────────────────┐"
+      , " │ Server now up on port 8080                │"
+      , " │                                           │"
+      , " │ To test, run:                             │"
+      , " │  > curl -v localhost:8080/api/v1/publish  │"
+      , " └───────────────────────────────────────────┘"
+      ]
+
+jsonDecoder :: forall a. JsonCodec a -> JsonDecoder JsonDecodeError a
+jsonDecoder codec = JsonDecoder (parseJson codec)

app/test/App/API.purs

@@ -15,13 +15,13 @@ import Registry.Foreign.FSExtra as FS.Extra
 import Registry.Foreign.FastGlob as FastGlob
 import Registry.Foreign.Tmp as Tmp
 import Registry.PackageName as PackageName
+import Registry.Test.Assert as Assert
 import Registry.Test.Assert.Run as Assert.Run
+import Registry.Test.Utils as Utils
 import Registry.Version as Version
 import Run (EFFECT, Run)
 import Run as Run
-import Test.Assert as Assert
 import Test.Spec as Spec
-import Test.Utils as Utils
 
 spec :: Spec.Spec Unit
 spec = do

app/test/App/Auth.purs

@@ -7,8 +7,8 @@ import Data.String as String
 import Registry.App.Auth as Auth
 import Registry.Operation (AuthenticatedData, AuthenticatedPackageOperation(..))
 import Registry.PackageName as PackageName
+import Registry.Test.Assert as Assert
 import Registry.Version as Version
-import Test.Assert as Assert
 import Test.Spec as Spec
 
 spec :: Spec.Spec Unit

app/test/App/CLI/Licensee.purs

@@ -5,7 +5,7 @@ import Registry.App.Prelude
 import Node.FS.Aff as FS.Aff
 import Node.Path as Path
 import Registry.App.CLI.Licensee as Licensee
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
 import Test.Spec as Spec
 
 spec :: Spec.Spec Unit

app/test/App/CLI/Purs.purs

@@ -5,7 +5,7 @@ import Registry.App.Prelude
 import Data.Foldable (traverse_)
 import Registry.App.CLI.Purs (CompilerFailure(..))
 import Registry.App.CLI.Purs as Purs
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
 import Test.Spec as Spec
 
 spec :: Spec.Spec Unit

app/test/App/CLI/Tar.purs

@@ -10,7 +10,7 @@ import Registry.App.CLI.Tar as Tar
 import Registry.Foreign.FSExtra as FS.Extra
 import Registry.Foreign.Tmp as Tmp
 import Registry.Sha256 as Sha256
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
 import Test.Spec as Spec
 
 spec :: Spec.Spec Unit

app/test/App/Effect/PackageSets.purs

@@ -5,10 +5,10 @@ import Registry.App.Prelude
 import Data.Map as Map
 import Registry.App.Effect.PackageSets (Change(..))
 import Registry.App.Effect.PackageSets as PackageSets
+import Registry.Test.Assert as Assert
+import Registry.Test.Utils as Utils
 import Registry.Version as Version
-import Test.Assert as Assert
 import Test.Spec as Spec
-import Test.Utils as Utils
 
 spec :: Spec.Spec Unit
 spec = do

app/test/App/Legacy/LenientRange.purs

@@ -4,7 +4,7 @@ import Registry.App.Prelude
 
 import Data.Either as Either
 import Registry.App.Legacy.LenientRange as LenientRange
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
 import Test.Spec as Spec
 
 spec :: Spec.Spec Unit

app/test/App/Legacy/LenientVersion.purs

@@ -4,7 +4,7 @@ import Registry.App.Prelude
 
 import Data.Either as Either
 import Registry.App.Legacy.LenientVersion as LenientVersion
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
 import Test.Spec as Spec
 
 spec :: Spec.Spec Unit

app/test/App/Legacy/Manifest.purs

@@ -5,7 +5,7 @@ import Registry.App.Prelude
 import Data.Array as Array
 import Data.Codec.Argonaut as CA
 import Registry.App.Legacy.Manifest as Legacy.Manifest
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
 import Test.Spec (Spec)
 import Test.Spec as Spec
 

app/test/App/Legacy/PackageSet.purs

@@ -14,10 +14,10 @@ import Registry.App.Legacy.Types (legacyPackageSetCodec)
 import Registry.ManifestIndex as ManifestIndex
 import Registry.PackageName as PackageName
 import Registry.Sha256 as Sha256
+import Registry.Test.Assert as Assert
+import Registry.Test.Utils as Utils
 import Registry.Version as Version
-import Test.Assert as Assert
 import Test.Spec as Spec
-import Test.Utils as Utils
 
 spec :: Spec.Spec Unit
 spec = do

app/test/Main.purs

@@ -10,7 +10,8 @@ import Registry.App.Main as Main
 import Registry.Foreign.Octokit (IssueNumber(..))
 import Registry.Operation (PackageOperation(..), PackageSetOperation(..))
 import Registry.Operation as Operation
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
+import Registry.Test.Utils as Utils
 import Test.Registry.App.API (spec) as API
 import Test.Registry.App.Auth as Auth
 import Test.Registry.App.CLI.Licensee as Test.CLI.Licensee
@@ -24,7 +25,6 @@ import Test.Registry.App.Legacy.PackageSet as Test.Legacy.PackageSet
 import Test.Spec as Spec
 import Test.Spec.Reporter.Console (consoleReporter)
 import Test.Spec.Runner (defaultConfig, runSpec')
-import Test.Utils as Utils
 
 main :: Effect Unit
 main = launchAff_ $ runSpec' (defaultConfig { timeout = Just $ Milliseconds 10_000.0 }) [ consoleReporter ] do

app/test/Assert/Run.purs → app/test/Test/Assert/Run.purs

@@ -7,11 +7,11 @@ import Data.Foldable as Foldable
 import Effect.Exception as Exception
 import Registry.App.Effect.Log (LOG, Log(..))
 import Registry.App.Effect.Log as Log
+import Registry.Test.Utils as Utils
 import Run (AFF, EFFECT, Run)
 import Run as Run
 import Run.Except (EXCEPT)
 import Run.Except as Except
-import Test.Utils as Utils
 
 runTest :: forall a. Run (LOG + EXCEPT String + AFF + EFFECT ()) a -> Aff a
 runTest =

foreign/test/Foreign/FastGlob.purs

@@ -11,7 +11,7 @@ import Node.Process as Process
 import Registry.Foreign.FSExtra as FS.Extra
 import Registry.Foreign.FastGlob as FastGlob
 import Registry.Foreign.Tmp as Tmp
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
 import Test.Spec as Spec
 
 spec :: Spec.Spec Unit

foreign/test/Foreign/JsonRepair.purs

@@ -12,7 +12,7 @@ import Data.Codec.Argonaut.Record as CA.Record
 import Data.Either (Either)
 import Data.Either as Either
 import Registry.Foreign.JsonRepair as JsonRepair
-import Test.Assert as Assert
+import Registry.Test.Assert as Assert
 import Test.Spec as Spec
 
 spec :: Spec.Spec Unit