Prioritise less global repos and avoid local urls (#17)

Author: danielrolls

.github/workflows/cabaltest.yml

@@ -11,5 +11,5 @@ jobs:
       with:
         nix_path: nixpkgs=channel:nixos-unstable
     - run: nix develop
-    - run: cabal v2-update
-    - run: cabal v2-test
+    - run: nix develop --command cabal v2-update
+    - run: nix develop --command cabal v2-test --enable-tests

shellify.cabal

@@ -57,6 +57,7 @@ library
         extra >=1.7.13 && <1.9,
         HStringTemplate >=0.8.8 && <0.9,
         mtl >=2.2.2 && <2.4,
+        parsec >=3.1.17.0 && <3.2,
         shake >=0.19.7 && <0.20,
         unordered-containers >=0.2.19.1 && <0.3
 

src/Constants.hs

@@ -26,6 +26,12 @@ Options
     the versions of dependencies are kept for reproducibility and so that
     shells are cached to load faster.
 
+    --allow-local-pinned-registries-to-be-prioritized
+    Pinned local repoisitory URLs are usually taken last when looking for URLs for
+    generated flake.nix files. This is usually desired. If you do however want
+    to see these pinned entries in the flake file as specified in your registry,
+    then set this flag.
+
     --version
     Show the version number
 |]

src/Options.hs

@@ -29,6 +29,7 @@ data Options = Options {
     packages :: Packages
   , command :: Maybe Text
   , generateFlake :: Bool
+  , prioritiseLocalPinnedSystem :: Bool
 }
 
 data OptionsParser = OptionsParser [Text] -- remainingOptions
@@ -59,6 +60,7 @@ options progName args =
         oldStyleOption opt = baseOption opt
         newStyleOption "-p" = returnError "-p not supported with new style commands"
         newStyleOption "--packages" = returnError "--packages not supported with new style commands"
+        newStyleOption "--allow-local-pinned-registries-to-be-prioritized" = transformOptionsWith setPrioritiseLocalPinnedSystem
         newStyleOption arg | isSwitch arg = baseOption arg
                            | otherwise = transformOptionsWith $ appendPackages [arg]
         baseOption :: Text -> [Text] -> OptionsParser
@@ -82,6 +84,7 @@ options progName args =
         appendPackages ps opts = opts{packages=ps ++ packages opts}
         setCommand cmd opts = opts{command=Just cmd}
         setFlakeGeneration opts = opts{generateFlake=True}
+        setPrioritiseLocalPinnedSystem opts = opts {prioritiseLocalPinnedSystem=True}
         returnError errorText remaining = OptionsParser remaining $ Left errorText
 
 consumePackageArgs :: [Text] -> (Packages, [Text])
@@ -99,7 +102,7 @@ hasShellArg (hd:tl) | isSwitch hd = hasShellArg tl
 isSwitch = isPrefixOf "-"
 
 instance Default Options where
-  def = Options [] Nothing False
+  def = Options [] Nothing False False
 
 instance Eq Options where
   a == b =  isEqual command

src/TemplateGeneration.hs

@@ -1,24 +1,23 @@
 module TemplateGeneration (generateShellDotNixText, generateFlakeText, getRegistryDB) where
 
-import Prelude hiding (lines)
-
 import Constants
 import FlakeTemplate
 import Options
 import ShellifyTemplate
 
+import Data.Bifunctor (bimap)
 import Data.Bool (bool)
-import Data.List (find, sort)
-import Data.List.Extra ((!?))
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.List (find, sort, sortBy, sortOn)
+import Data.Maybe (fromMaybe)
 import Data.Set (fromList, toList)
-import Data.Text (isInfixOf, isPrefixOf, lines, pack, splitOn, Text())
+import Data.Text (Text(), isInfixOf, isPrefixOf, pack, splitOn, unpack)
 import Development.Shake.Command (cmd, Exit(Exit), Stderr(Stderr), Stdout(Stdout))
 import System.Exit (ExitCode (ExitSuccess))
+import Text.ParserCombinators.Parsec (Parser, char, endBy, eof, many1, noneOf, parse, string, (<|>))
 import Text.StringTemplate (newSTMP, render, setAttribute)
 
 generateFlakeText :: Text -> Options -> Maybe Text
-generateFlakeText db Options{packages=packages, generateFlake=shouldGenerateFlake} =
+generateFlakeText db Options{packages=packages, generateFlake=shouldGenerateFlake, prioritiseLocalPinnedSystem=prioritiseLocalPinnedSystem} =
   bool
     Nothing
     (Just $ render
@@ -28,15 +27,15 @@ generateFlakeText db Options{packages=packages, generateFlake=shouldGenerateFlak
           $ setAttribute "shell_args" shellArgs
           $ newSTMP flakeTemplate)
     shouldGenerateFlake
-  where repos = uniq $ getPackageRepo <$> sort packages
+  where repos = getPackageRepoWrapper packages
         repoVars = getPackageRepoVarName <$> repos
         repoInputs = repoInput <$> repos
         repoInputLine repoName url = repoName <> ".url = \"" <> url <> "\";"
         repoInput repoName = repoInputLine repoName .
           either
-            (error "Unexpected output from nix registry call: " <>)
+            (error . ("Unexpected output from nix registry call: " <>))
             (fromMaybe "PLEASE ENTER input here")
-            . findFlakeRepoUrl db $ repoName
+            . findFlakeRepoUrl prioritiseLocalPinnedSystem db $ repoName
         pkgsVar = (<> "Pkgs")
         pkgsVars = pkgsVar <$> repos
         pkgsDecls = (\repo -> pkgsDecl (pkgsVar repo) repo) <$> repos
@@ -52,9 +51,12 @@ generateShellDotNixText Options{packages=packages, command=command} =
           command
   $ newSTMP shellifyTemplate
   where pkgs = generateBuildInput <$> sort packages
-        parameters = uniq $ generateParameters <$> sort packages
+        parameters = generateParametersWrapper packages
         generateBuildInput input = (toImportVar . getPackageRepo) input <> "." <> getPackageName input
 
+getPackageRepoWrapper :: [Package] -> [Text]
+getPackageRepoWrapper = uniq . ("nixpkgs" :) . fmap getPackageRepo . sort
+
 getPackageRepo input | "#" `isInfixOf` input
                         = head $ splitOn "#" input
                      | otherwise
@@ -73,6 +75,9 @@ toImportVar var | var == "nixpkgs"
 getPackageRepoVarName "nixpkgs" = "pkgs"
 getPackageRepoVarName a = a
 
+generateParametersWrapper :: [Package] -> [Text]
+generateParametersWrapper = uniq . ("pkgs ? import <nixpkgs> {}" :) . fmap generateParameters . sort
+
 generateParameters :: Package -> Text
 generateParameters package | "#" `isInfixOf` package
                            && not ("nixpkgs#" `isPrefixOf` package)
@@ -90,23 +95,40 @@ getRegistryDB =
                       (Right $ pack out)
                       (ex == ExitSuccess)
 
-findFlakeRepoUrl :: Text -> Text -> Either Text (Maybe Text)
-findFlakeRepoUrl haystack needle =
-       fmap repoUrl . find ((needle ==) . repoName) . catMaybes <$> mapM getFlakeRepo (lines haystack)
+findFlakeRepoUrl :: Bool -> Text -> Text -> Either String (Maybe Text)
+findFlakeRepoUrl prioritiseLocalPinnedSystem haystack needle =
+  bimap ((<>) "Error processing nix registry list output: " . show)
+        (fmap repoUrl . find ((needle ==) . repoName)
+                       . (if prioritiseLocalPinnedSystem then sortOn repoType else sortBy compareRepoEntries))
+        $ parse parseRepos "" . unpack $ haystack
+
+compareRepoEntries repoA repoB
+  | repoHasLocalPinning repoA && not (repoHasLocalPinning repoB) = GT
+  | repoHasLocalPinning repoB && not (repoHasLocalPinning repoA) = LT
+  | otherwise = repoType repoA `compare` repoType repoB
+  where repoHasLocalPinning = isPrefixOf "path:" . repoUrl
+
+data RepoType = User | System | Global
+                deriving (Eq, Ord)
 
 data FlakeRepo = FlakeRepo {
     repoName :: Text
   , repoUrl :: Text
+  , repoType :: RepoType
 }
 
-getFlakeRepo :: Text -> Either Text (Maybe FlakeRepo)
-getFlakeRepo line = let expectedField = maybe (Left "unexepected nix registry command format")
-                                              Right
-                                        . (!?) (splitOn " " line)
-                        urlField = expectedField 2
-                        splitRepoField = splitOn ":" <$> expectedField 1
-                        potentialFlakeName ["flake", b] = Just b
-                        potentialFlakeName _ = Nothing
-                        f x y = (`FlakeRepo` y) <$> potentialFlakeName x
-                     in f <$> splitRepoField <*> urlField
+parseRepos :: Parser [FlakeRepo]
+parseRepos = do res <- endBy parseLine (char '\n')
+                eof
+                return res
+  where parseLine = do repoType <- parseRepoType
+                       char ' '
+                       flakeName <- string "flake:" >> parseParam
+                       char ' '
+                       repoUrl <- parseParam
+                       return $ FlakeRepo (pack flakeName) (pack repoUrl) repoType
+        parseParam = many1 (noneOf " \n")
+        parseRepoType = (string "global" >> return Global)
+                    <|> (string "system" >> return System)
+                    <|> (string "user" >> return User)