Add snapshot --from-elm-json

Rather than reading the package list from the internet, this running mode just takes elm.json as correct and writes only those packages to registry.dat. This produces a much smaller file which is more amenable for being included in distributions, and more importantly can run inside network sandboxes, since it just needs the elm.json file.
cachix · Sep 21, 2024 · 802f2e9 · 802f2e9
1 parent 5a78cdf
commit 802f2e9
Show file tree

Hide file tree

Showing 2 changed files with 50 additions and 27 deletions.
diff --git a/elm2nix/Main.hs b/elm2nix/Main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE QuasiQuotes #-}
 module Main
   ( main
@@ -16,7 +17,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP
 data Command
   = Init
   | Convert
-  | Snapshot
+  | Snapshot { fromElmJson :: Bool }
 
 main :: IO ()
 main = do
@@ -26,7 +27,7 @@ main = do
   case cmd of
     Convert -> Elm2Nix.convert
     Init -> Elm2Nix.initialize
-    Snapshot -> Elm2Nix.snapshot
+    Snapshot { fromElmJson } -> Elm2Nix.snapshot fromElmJson
 
 getOpts :: IO Command
 getOpts = customExecParser p (infoH opts rest)
@@ -45,15 +46,18 @@ getOpts = customExecParser p (infoH opts rest)
 
       $ elm2nix init > default.nix
       $ elm2nix convert > elm-srcs.nix
-      $ elm2nix snapshot
+      $ elm2nix snapshot --from-elm-json
       $ nix-build
 
       Note: You have to run elm2nix from top-level directory of an Elm project.
     |]
 
+    snapshotOpts :: Parser Command
+    snapshotOpts = Snapshot <$> switch (long "from-elm-json")
+
     opts :: Parser Command
     opts = subparser
       ( command "init" (infoH (pure Init) (progDesc "Generate default.nix (printed to stdout)"))
      <> command "convert" (infoH (pure Convert) (progDesc "Generate Nix expressions for elm.json using nix-prefetch-url"))
-     <> command "snapshot" (infoH (pure Snapshot) (progDesc "Generate registry.dat"))
+     <> command "snapshot" (infoH snapshotOpts (progDesc "Generate registry.dat"))
       )
diff --git a/src/Elm2Nix/PackagesSnapshot.hs b/src/Elm2Nix/PackagesSnapshot.hs
@@ -36,6 +36,8 @@ import qualified Data.List as List
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Builder as BS
 
+import Elm2Nix.ElmJson (readElmJson, toErrorMessage)
+
 
 data Name =
   Name
@@ -44,6 +46,12 @@ data Name =
     }
     deriving (Eq, Ord)
 
+parseName :: (MonadFail m) => Text -> m Name
+parseName n =
+  case Text.splitOn "/" n of
+    [author, package] -> pure $ Name author package
+    lst -> fail $ "wrong package name: " <> show lst
+
 data Package =
   Package
     { _name :: !Name
@@ -59,6 +67,17 @@ data Version =
     }
     deriving (Eq, Ord)
 
+parseVersion :: (MonadFail m) => Text -> m Version
+parseVersion x =
+    case Text.splitOn "." x of
+      [major, minor, patch] ->
+        return $ Version
+                  (read (Text.unpack major))
+                  (read (Text.unpack minor))
+                  (read (Text.unpack patch))
+      _ ->
+        fail "failure parsing version"
+
 data KnownVersions =
   KnownVersions
     { _newest :: Version
@@ -135,19 +154,33 @@ defHttpConfig = Req.defaultHttpConfig
 defHttpConfig = def
 #endif
 
-snapshot :: IO ()
-snapshot = do
+getFromElmJson :: IO Packages
+getFromElmJson = do
+  deps <- either (error . toErrorMessage) id <$> readElmJson
+  let
+    parseDep (k, v) = do
+      name <- parseName (Text.pack k)
+      version <- parseVersion (Text.pack v)
+      pure (name, KnownVersions version [])
+  Packages . Map.fromList <$> mapM parseDep deps
+
+getFromPackageServer :: IO Packages
+getFromPackageServer = do
   r <- Req.runReq defHttpConfig $
     Req.req
     Req.POST
     (Req.https "package.elm-lang.org" Req./: "all-packages")
     Req.NoReqBody
     Req.jsonResponse
     mempty
-  let packages = unwrap $ case Aeson.fromJSON (Req.responseBody r) of
-         Aeson.Error s -> error s
-         Aeson.Success val -> val
-      size = Map.foldr' addEntry 0 packages
+  case Aeson.fromJSON (Req.responseBody r) of
+    Aeson.Error s -> error s
+    Aeson.Success val -> pure val
+
+snapshot :: Bool -> IO ()
+snapshot fromElmJson = do
+  packages <- unwrap <$> if fromElmJson then getFromElmJson else getFromPackageServer
+  let size = Map.foldr' addEntry 0 packages
       registry = Registry size packages
 
       addEntry :: KnownVersions -> Int -> Int
@@ -171,26 +204,12 @@ instance Aeson.FromJSON Packages where
 
 
 instance Aeson.FromJSON Version where
-  parseJSON = Aeson.withText "string" $ \x ->
-    case Text.splitOn "." x of
-      [major, minor, patch] ->
-        return $ Version
-                  (read (Text.unpack major))
-                  (read (Text.unpack minor))
-                  (read (Text.unpack patch))
-      _ ->
-        fail "failure parsing version"
+  parseJSON = Aeson.withText "string" parseVersion
 
 
 instance Aeson.FromJSON Name where
-  parseJSON = Aeson.withText "string" $ \x ->
-    case Text.splitOn "/" x of
-      [author, package] -> return $ Name author package
-      lst -> fail $ "wrong package name: " <> show lst
+  parseJSON = Aeson.withText "string" parseName
 
 
 instance Aeson.FromJSONKey Name where
-  fromJSONKey = Aeson.FromJSONKeyTextParser $ \x ->
-    case Text.splitOn "/" x of
-      [author, package] -> return $ Name author package
-      lst -> fail $ "wrong package name: " <> show lst
+  fromJSONKey = Aeson.FromJSONKeyTextParser parseName