Make dhall types directory configurable (#631)

.env.example

@@ -17,3 +17,6 @@ PACCHETTIBOTTI_ED25519="YWJjeHl6"
 
 # The location of the sqlite database file.
 DATABASE_URL="sqlite:db/registry.sqlite3"
+
+# The location of the Dhall specifications
+DHALL_TYPES="./types"

app/default.nix

@@ -44,7 +44,6 @@ in {
     name = "registry-server";
     src = ./.;
     database = ../db;
-    dhallTypes = ../types;
     nativeBuildInputs = [esbuild makeWrapper];
     buildInputs = [nodejs];
     entrypoint = writeText "entrypoint.js" ''
@@ -64,9 +63,6 @@ in {
       cp ${name}.js $out/${name}.js
       ln -s ${package-lock}/js/node_modules $out
 
-      echo "Copying Dhall types..."
-      cp -r ${dhallTypes} $out/bin/types
-
       echo "Copying database..."
       cp -r ${database} $out/bin/db
 
@@ -77,7 +73,8 @@ in {
     '';
     postFixup = ''
       wrapProgram $out/bin/${name} \
-        --set PATH ${lib.makeBinPath [compilers purs-versions dhall dhall-json licensee git coreutils gzip gnutar]}
+        --set PATH ${lib.makeBinPath [compilers purs-versions dhall dhall-json licensee git coreutils gzip gnutar]} \
+        --set DHALL_TYPES ${../types}
     '';
   };
 
@@ -110,7 +107,8 @@ in {
     '';
     postFixup = ''
       wrapProgram $out/bin/${name} \
-        --set PATH ${lib.makeBinPath [compilers purs-versions dhall dhall-json licensee git coreutils gzip gnutar]}
+        --set PATH ${lib.makeBinPath [compilers purs-versions dhall dhall-json licensee git coreutils gzip gnutar]} \
+        --set DHALL_TYPES ${../types}
     '';
   };
 }

app/src/App/API.purs

@@ -45,7 +45,7 @@ import Registry.App.CLI.Purs as Purs
 import Registry.App.CLI.Tar as Tar
 import Registry.App.Effect.Comment (COMMENT)
 import Registry.App.Effect.Comment as Comment
-import Registry.App.Effect.Env (GITHUB_EVENT_ENV, PACCHETTIBOTTI_ENV)
+import Registry.App.Effect.Env (DHALL_ENV, GITHUB_EVENT_ENV, PACCHETTIBOTTI_ENV)
 import Registry.App.Effect.Env as Env
 import Registry.App.Effect.GitHub (GITHUB)
 import Registry.App.Effect.GitHub as GitHub
@@ -320,7 +320,7 @@ authenticated auth = case auth.payload of
         Registry.mirrorLegacyRegistry payload.name payload.newLocation
         Comment.comment "Mirrored registry operation to the legacy registry."
 
-type PublishEffects r = (PURSUIT + REGISTRY + STORAGE + SOURCE + GITHUB + LEGACY_CACHE + COMMENT + LOG + EXCEPT String + AFF + EFFECT + r)
+type PublishEffects r = (DHALL_ENV + PURSUIT + REGISTRY + STORAGE + SOURCE + GITHUB + LEGACY_CACHE + COMMENT + LOG + EXCEPT String + AFF + EFFECT + r)
 
 -- | Publish a package via the 'publish' operation. If the package has not been
 -- | published before then it will be registered and the given version will be
@@ -454,7 +454,7 @@ publish source payload = do
     Left error -> do
       Log.error $ "Could not read purs.json from path " <> packagePursJson <> ": " <> Aff.message error
       Except.throw $ "Could not find a purs.json file in the package source."
-    Right string -> Run.liftAff (jsonToDhallManifest string) >>= case _ of
+    Right string -> Env.askDhallEnv >>= \{ typesDir } -> Run.liftAff (jsonToDhallManifest typesDir string) >>= case _ of
       Left error -> do
         Log.error $ "Manifest does not typecheck: " <> error
         Except.throw $ "Found a valid purs.json file in the package source, but it does not typecheck."
@@ -959,12 +959,12 @@ removeIgnoredTarballFiles path = do
   for_ (ignoredDirectories <> ignoredFiles <> globMatches.succeeded) \match ->
     FS.Extra.remove (Path.concat [ path, match ])
 
-jsonToDhallManifest :: String -> Aff (Either String String)
-jsonToDhallManifest jsonStr = do
+jsonToDhallManifest :: FilePath -> String -> Aff (Either String String)
+jsonToDhallManifest dhallTypes jsonStr = do
   let cmd = "json-to-dhall"
   -- Dhall requires that the path begin with './', but joining paths together with Node
   -- will remove the './' prefix. We need to manually append this to the relative path.
-  let args = [ "--records-loose", "--unions-strict", "." <> Path.sep <> Path.concat [ "types", "v1", "Manifest.dhall" ] ]
+  let args = [ "--records-loose", "--unions-strict", Path.concat [ dhallTypes, "v1", "Manifest.dhall" ] ]
   process <- Execa.execa cmd args identity
   process.stdin.writeUtf8End jsonStr
   result <- process.result

app/src/App/CLI/Git.purs

@@ -261,11 +261,11 @@ gitPush { address, committer } cwd = Except.runExcept do
       let
         inRepoErr error = " in local checkout " <> cwd <> ": " <> error
 
-        origin :: URL
-        origin = coerce (mkOrigin address committer)
+        repoOrigin :: URL
+        repoOrigin = coerce (mkOrigin address committer)
 
-      _ <- withGit cwd [ "push", origin ] \error ->
-        "Failed to push to " <> origin <> " from " <> status.branch <> inRepoErr error
+      _ <- withGit cwd [ "push", repoOrigin ] \error ->
+        "Failed to push to " <> address.owner <> "/" <> address.repo <> " from " <> status.branch <> inRepoErr error
 
       pure Changed
 

app/src/App/Effect/Env.purs

@@ -16,6 +16,23 @@ import Run (Run)
 import Run.Reader (Reader)
 import Run.Reader as Run.Reader
 
+-- | Environment fields available in the GitHub Event environment, namely
+-- | pointers to the user who created the event and the issue associated with it.
+type DhallEnv =
+  { typesDir :: FilePath
+  }
+
+type DHALL_ENV r = (dhallEnv :: Reader DhallEnv | r)
+
+_dhallEnv :: Proxy "dhallEnv"
+_dhallEnv = Proxy
+
+askDhallEnv :: forall r. Run (DHALL_ENV + r) DhallEnv
+askDhallEnv = Run.Reader.askAt _dhallEnv
+
+runDhallEnv :: forall r a. DhallEnv -> Run (DHALL_ENV + r) a -> Run r a
+runDhallEnv = Run.Reader.runReaderAt _dhallEnv
+
 -- | Environment fields available in the GitHub Event environment, namely
 -- | pointers to the user who created the event and the issue associated with it.
 type GitHubEventEnv =
@@ -118,6 +135,10 @@ type DatabaseUrl = { prefix :: String, path :: FilePath }
 databaseUrl :: EnvKey DatabaseUrl
 databaseUrl = EnvKey { key: "DATABASE_URL", decode: decodeDatabaseUrl }
 
+-- | The location of the Dhall specifications directory
+dhallTypes :: EnvKey FilePath
+dhallTypes = EnvKey { key: "DHALL_TYPES", decode: pure }
+
 -- | A GitHub token for the @pacchettibotti user at the PACCHETTIBOTTI_TOKEN key.
 pacchettibottiToken :: EnvKey GitHubToken
 pacchettibottiToken = EnvKey { key: "PACCHETTIBOTTI_TOKEN", decode: decodeGitHubToken }

app/src/App/GitHubIssue.purs

@@ -93,6 +93,7 @@ main = launchAff_ $ do
     thrownRef <- liftEffect $ Ref.new false
 
     run
+      # Env.runDhallEnv { typesDir: env.dhallTypes }
       # Env.runGitHubEventEnv { username: env.username, issue: env.issue }
       # Env.runPacchettiBottiEnv { publicKey: env.publicKey, privateKey: env.privateKey }
       -- App effects
@@ -127,6 +128,7 @@ type GitHubEventEnv =
   , spacesConfig :: SpaceKey
   , publicKey :: String
   , privateKey :: String
+  , dhallTypes :: FilePath
   }
 
 initializeGitHub :: Aff (Maybe GitHubEventEnv)
@@ -136,6 +138,9 @@ initializeGitHub = do
   privateKey <- Env.lookupRequired Env.pacchettibottiED25519
   spacesKey <- Env.lookupRequired Env.spacesKey
   spacesSecret <- Env.lookupRequired Env.spacesSecret
+  dhallTypes <- do
+    types <- Env.lookupRequired Env.dhallTypes
+    liftEffect $ Path.resolve [] types
   eventPath <- Env.lookupRequired Env.githubEventPath
 
   octokit <- Octokit.newOctokit token
@@ -171,6 +176,7 @@ initializeGitHub = do
         , spacesConfig: { key: spacesKey, secret: spacesSecret }
         , publicKey
         , privateKey
+        , dhallTypes
         }
 
 data OperationDecoding

app/src/App/Server.purs

@@ -26,7 +26,7 @@ import Registry.App.Effect.Comment (COMMENT)
 import Registry.App.Effect.Comment as Comment
 import Registry.App.Effect.Db (DB)
 import Registry.App.Effect.Db as Db
-import Registry.App.Effect.Env (DatabaseUrl, PACCHETTIBOTTI_ENV)
+import Registry.App.Effect.Env (DHALL_ENV, DatabaseUrl, PACCHETTIBOTTI_ENV)
 import Registry.App.Effect.Env as Env
 import Registry.App.Effect.GitHub (GITHUB)
 import Registry.App.Effect.GitHub as GitHub
@@ -65,30 +65,27 @@ router env { route, method, body } = HTTPurple.usingCont case route, method of
   Publish, Post -> do
     publish <- HTTPurple.fromJson (jsonDecoder Operation.publishCodec) body
     lift $ Log.info $ "Received Publish request: " <> printJson Operation.publishCodec publish
-    forkPipelineJob publish.name publish.ref PublishJob
-      \jobId -> do
-        Log.info $ "Received Publish request, job id: " <> unwrap jobId
-        API.publish Current publish
+    forkPipelineJob publish.name publish.ref PublishJob \jobId -> do
+      Log.info $ "Received Publish request, job id: " <> unwrap jobId
+      API.publish Current publish
 
   Unpublish, Post -> do
     auth <- HTTPurple.fromJson (jsonDecoder Operation.authenticatedCodec) body
     case auth.payload of
       Operation.Unpublish { name, version } -> do
-        forkPipelineJob name (Version.print version) UnpublishJob
-          \jobId -> do
-            Log.info $ "Received Unpublish request, job id: " <> unwrap jobId
-            API.authenticated auth
+        forkPipelineJob name (Version.print version) UnpublishJob \jobId -> do
+          Log.info $ "Received Unpublish request, job id: " <> unwrap jobId
+          API.authenticated auth
       _ ->
         HTTPurple.badRequest "Expected unpublish operation."
 
   Transfer, Post -> do
     auth <- HTTPurple.fromJson (jsonDecoder Operation.authenticatedCodec) body
     case auth.payload of
       Operation.Transfer { name } -> do
-        forkPipelineJob name "" TransferJob
-          \jobId -> do
-            Log.info $ "Received Transfer request, job id: " <> unwrap jobId
-            API.authenticated auth
+        forkPipelineJob name "" TransferJob \jobId -> do
+          Log.info $ "Received Transfer request, job id: " <> unwrap jobId
+          API.authenticated auth
       _ ->
         HTTPurple.badRequest "Expected transfer operation."
 
@@ -127,9 +124,13 @@ router env { route, method, body } = HTTPurple.usingCont case route, method of
         let newEnv = env { jobId = Just jobId }
 
         _fiber <- liftAff $ Aff.forkAff $ Aff.attempt $ do
-          void $ runEffects newEnv (action jobId)
-          finishedAt <- nowUTC
-          void $ runEffects newEnv (Db.finishJob { jobId, finishedAt, success: true })
+          result <- runEffects newEnv (action jobId)
+          case result of
+            Left _ -> pure unit
+            Right _ -> do
+              finishedAt <- nowUTC
+              void $ runEffects newEnv (Db.finishJob { jobId, finishedAt, success: true })
+
         jsonOk V1.jobCreatedResponseCodec { jobId }
 
 type ServerEnvVars =
@@ -139,6 +140,7 @@ type ServerEnvVars =
   , spacesKey :: String
   , spacesSecret :: String
   , databaseUrl :: DatabaseUrl
+  , dhallTypes :: FilePath
   }
 
 readServerEnvVars :: Aff ServerEnvVars
@@ -150,7 +152,10 @@ readServerEnvVars = do
   spacesKey <- Env.lookupRequired Env.spacesKey
   spacesSecret <- Env.lookupRequired Env.spacesSecret
   databaseUrl <- Env.lookupRequired Env.databaseUrl
-  pure { token, publicKey, privateKey, spacesKey, spacesSecret, databaseUrl }
+  dhallTypes <- do
+    types <- Env.lookupRequired Env.dhallTypes
+    liftEffect $ Path.resolve [] types
+  pure { token, publicKey, privateKey, spacesKey, spacesSecret, databaseUrl, dhallTypes }
 
 type ServerEnv =
   { cacheDir :: FilePath
@@ -182,7 +187,10 @@ createServerEnv = do
 
   db <- liftEffect $ SQLite.connect
     { database: vars.databaseUrl.path
-    , logger: Run.runBaseEffect <<< Log.interpret (Log.handleTerminal Verbose) <<< Log.info
+    -- To see all database queries logged in the terminal, use this instead
+    -- of 'mempty'. Turned off by default because this is so verbose.
+    -- Run.runBaseEffect <<< Log.interpret (Log.handleTerminal Normal) <<< Log.info
+    , logger: mempty
     }
 
   -- At server startup we clean out all the jobs that are not completed,
@@ -204,7 +212,7 @@ createServerEnv = do
     , jobId: Nothing
     }
 
-type ServerEffects = (PACCHETTIBOTTI_ENV + REGISTRY + STORAGE + PURSUIT + SOURCE + DB + GITHUB + LEGACY_CACHE + COMMENT + LOG + EXCEPT String + AFF + EFFECT ())
+type ServerEffects = (DHALL_ENV + PACCHETTIBOTTI_ENV + REGISTRY + STORAGE + PURSUIT + SOURCE + DB + GITHUB + LEGACY_CACHE + COMMENT + LOG + EXCEPT String + AFF + EFFECT ())
 
 runServer :: ServerEnv -> (ServerEnv -> Request Route -> Run ServerEffects Response) -> Request Route -> Aff Response
 runServer env router' request = do
@@ -257,6 +265,7 @@ runEffects env operation = Aff.attempt do
   let logPath = Path.concat [ env.logsDir, logFile ]
   operation
     # Env.runPacchettiBottiEnv { publicKey: env.vars.publicKey, privateKey: env.vars.privateKey }
+    # Env.runDhallEnv { typesDir: env.vars.dhallTypes }
     # Registry.interpret
         ( Registry.handle
             { repos: Registry.defaultRepos

app/test/Test/Assert/Run.purs

@@ -20,15 +20,14 @@ import Data.String as String
 import Effect.Aff as Aff
 import Effect.Now as Now
 import Effect.Ref as Ref
-import Effect.Unsafe (unsafePerformEffect)
 import Node.FS.Aff as FS.Aff
 import Node.Path as Path
 import Registry.App.CLI.Git as Git
 import Registry.App.Effect.Cache (CacheRef)
 import Registry.App.Effect.Cache as Cache
 import Registry.App.Effect.Comment (COMMENT)
 import Registry.App.Effect.Comment as Comment
-import Registry.App.Effect.Env (GITHUB_EVENT_ENV, PACCHETTIBOTTI_ENV)
+import Registry.App.Effect.Env (DHALL_ENV, GITHUB_EVENT_ENV, PACCHETTIBOTTI_ENV)
 import Registry.App.Effect.Env as Env
 import Registry.App.Effect.GitHub (GITHUB, GITHUB_CACHE, GitHub(..))
 import Registry.App.Effect.GitHub as GitHub
@@ -81,6 +80,7 @@ type TEST_EFFECTS =
       + GITHUB
       + PACCHETTIBOTTI_ENV
       + GITHUB_EVENT_ENV
+      + DHALL_ENV
       + GITHUB_CACHE
       + LEGACY_CACHE
       + COMMENT
@@ -101,25 +101,30 @@ type TestEnv =
   }
 
 runTestEffects :: forall a. TestEnv -> Run TEST_EFFECTS a -> Aff a
-runTestEffects env =
-  Pursuit.interpret (handlePursuitMock env.metadata)
-    >>> Registry.interpret (handleRegistryMock { metadataRef: env.metadata, indexRef: env.index })
-    >>> PackageSets.interpret handlePackageSetsMock
-    >>> Storage.interpret (handleStorageMock { storage: env.storage })
-    >>> Source.interpret (handleSourceMock { github: env.github })
-    >>> GitHub.interpret (handleGitHubMock { github: env.github })
+runTestEffects env operation = do
+  typesDir <- liftEffect $ Path.resolve [] "./types"
+  githubCache <- liftEffect Cache.newCacheRef
+  legacyCache <- liftEffect Cache.newCacheRef
+  operation
+    # Pursuit.interpret (handlePursuitMock env.metadata)
+    # Registry.interpret (handleRegistryMock { metadataRef: env.metadata, indexRef: env.index })
+    # PackageSets.interpret handlePackageSetsMock
+    # Storage.interpret (handleStorageMock { storage: env.storage })
+    # Source.interpret (handleSourceMock { github: env.github })
+    # GitHub.interpret (handleGitHubMock { github: env.github })
     -- Environments
-    >>> Env.runGitHubEventEnv { username: env.username, issue: IssueNumber 1 }
-    >>> Env.runPacchettiBottiEnv { publicKey: "Unimplemented", privateKey: "Unimplemented" }
+    # Env.runGitHubEventEnv { username: env.username, issue: IssueNumber 1 }
+    # Env.runPacchettiBottiEnv { publicKey: "Unimplemented", privateKey: "Unimplemented" }
+    # Env.runDhallEnv { typesDir }
     -- Caches
-    >>> runGitHubCacheMemory (unsafePerformEffect Cache.newCacheRef)
-    >>> runLegacyCacheMemory (unsafePerformEffect Cache.newCacheRef)
+    # runGitHubCacheMemory githubCache
+    # runLegacyCacheMemory legacyCache
     -- Other effects
-    >>> Comment.interpret Comment.handleLog
-    >>> Log.interpret (\(Log _ _ next) -> pure next)
+    # Comment.interpret Comment.handleLog
+    # Log.interpret (\(Log _ _ next) -> pure next)
     -- Base effects
-    >>> Except.catch (\err -> Run.liftAff (Aff.throwError (Aff.error err)))
-    >>> Run.runBaseAff'
+    # Except.catch (\err -> Run.liftAff (Aff.throwError (Aff.error err)))
+    # Run.runBaseAff'
 
 -- | For testing simple Run functions that don't need the whole environment.
 runBaseEffects :: forall a. Run (LOG + EXCEPT String + AFF + EFFECT + ()) a -> Aff a

flake.nix

@@ -75,15 +75,14 @@
 
         # An attrset containing all the PureScript binaries we want to make
         # available.
-        compilers = 
-          prev.symlinkJoin {
-            name = "purs-compilers";
-            paths = prev.lib.mapAttrsToList (name: drv:
-              prev.writeShellScriptBin name ''
-                exec ${drv}/bin/purs "$@"
-              '')
-            supportedCompilers;
-          };
+        compilers = prev.symlinkJoin {
+          name = "purs-compilers";
+          paths = prev.lib.mapAttrsToList (name: drv:
+            prev.writeShellScriptBin name ''
+              exec ${drv}/bin/purs "$@"
+            '')
+          supportedCompilers;
+        };
 
         purs-versions = prev.writeShellScriptBin "purs-versions" ''
           echo ${prev.lib.concatMapStringsSep " " (x: prev.lib.removePrefix "purs-" (builtins.replaceStrings ["_"] ["."] x)) (prev.lib.attrNames supportedCompilers)}
@@ -278,6 +277,7 @@
         default = pkgs.mkShell {
           name = "registry-dev";
           inherit DHALL_PRELUDE;
+          DHALL_TYPES = ./types;
           packages = with pkgs; [
             # All stable PureScript compilers
             registry.compilers

nix/module.nix

@@ -36,7 +36,7 @@ in {
 
   config = lib.mkIf cfg.enable {
     environment = {
-      systemPackages = [ pkgs.vim ];
+      systemPackages = [pkgs.vim];
     };
 
     nix = {