84cb2fe · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge remote-tracking branch 'origin/develop' into eac@ghcide-compat

84cb2feTom Smalley7 years ago

all-tests.nix+23−23

compare with master

unifiedsplit

@@ -63,15 +63,18 @@ in

63 '';

64 in ''

65 start_all()

66− githost.wait_for_open_port("22")

68− with subtest("test obelisk is installed"):

67+ with subtest("obelisk is installed and git is configured"):

69 client.succeed("ob --help")

68 client.succeed("ob --help")

69+ client.succeed('git config --global user.email "you@example.com"')

70+ client.succeed('git config --global user.name "Your Name"')

72+ githost.wait_for_open_port("22")

73+

71− with subtest("test the client can access the server via ssh"):

74+ with subtest("the client can access the server via ssh"):

72 client.succeed("mkdir -p ~/.ssh/")

75 client.succeed("mkdir -p ~/.ssh/")

73 client.succeed(

76 client.succeed(

74− "cp ${privateKeyFile} ~/.ssh/id_rsa"

77+ "cp ${privateKeyFile} ~/.ssh/id_rsa"

75 )

78 )

76 client.succeed("chmod 600 ~/.ssh/id_rsa")

79 client.succeed("chmod 600 ~/.ssh/id_rsa")

77 client.wait_until_succeeds(

80 client.wait_until_succeeds(

@@ -82,36 +85,35 @@ in

82 )

85 )

83 client.wait_until_succeeds("ssh githost true")

86 client.wait_until_succeeds("ssh githost true")

85− with subtest("test a remote bare repo can be started"):

88+ with subtest("a remote bare repo can be started"):

86 githost.succeed("mkdir -p ~/myorg/myapp.git")

89 githost.succeed("mkdir -p ~/myorg/myapp.git")

87 githost.succeed("cd ~/myorg/myapp.git && git init --bare")

90 githost.succeed("cd ~/myorg/myapp.git && git init --bare")

89− with subtest("test a git project can be configured with a remote using ssh"):

92+ with subtest("a git project can be configured with a remote using ssh"):

90 client.succeed("mkdir -p ~/code/myapp")

93 client.succeed("mkdir -p ~/code/myapp")

91 client.succeed("cd ~/code/myapp && git init")

94 client.succeed("cd ~/code/myapp && git init")

92 client.succeed(

95 client.succeed(

93 "cp ${thunkableSample} ~/code/myapp/default.nix"

96 "cp ${thunkableSample} ~/code/myapp/default.nix"

94 )

97 )

95 client.succeed("cd ~/code/myapp && git add .")

98 client.succeed("cd ~/code/myapp && git add .")

96− client.succeed('git config --global user.email "you@example.com"')

99+

97− client.succeed('git config --global user.name "Your Name"')

98 client.succeed('cd ~/code/myapp && git commit -m "Initial"')

100 client.succeed('cd ~/code/myapp && git commit -m "Initial"')

99 client.succeed(

101 client.succeed(

100 "cd ~/code/myapp && git remote add origin root@githost:/root/myorg/myapp.git"

102 "cd ~/code/myapp && git remote add origin root@githost:/root/myorg/myapp.git"

101 )

103 )

102

104

103

105

104− with subtest("test pushing code to the remote"):

106+ with subtest("pushing code to the remote"):

105 client.succeed("cd ~/code/myapp && git push -u origin master")

107 client.succeed("cd ~/code/myapp && git push -u origin master")

106 client.succeed("cd ~/code/myapp && git status")

108 client.succeed("cd ~/code/myapp && git status")

107

109

108− with subtest("test obelisk can pack"):

110+ with subtest("obelisk can pack"):

109 client.succeed("ob -v thunk pack ~/code/myapp")

111 client.succeed("ob -v thunk pack ~/code/myapp")

110− client.succeed("grep -qF 'git' ~/code/myapp/default.nix")

112+ client.succeed("grep -qF 'git.json' ~/code/myapp/thunk.nix")

111 client.succeed("grep -qF 'myorg' ~/code/myapp/git.json")

113 client.succeed("grep -qF 'myorg' ~/code/myapp/git.json")

112 client.succeed("ob -v thunk unpack ~/code/myapp")

114 client.succeed("ob -v thunk unpack ~/code/myapp")

113

115

114− with subtest("test obelisk can set the public / private flag"):

116+ with subtest("obelisk can set the public / private flag"):

115 client.succeed("ob -v thunk pack ~/code/myapp --private")

117 client.succeed("ob -v thunk pack ~/code/myapp --private")

116 client.fail("""grep -qF '"private": practice' ~/code/myapp/git.json""")

118 client.fail("""grep -qF '"private": practice' ~/code/myapp/git.json""")

117 client.succeed("""grep -qF '"private": true' ~/code/myapp/git.json""")

119 client.succeed("""grep -qF '"private": true' ~/code/myapp/git.json""")

@@ -122,22 +124,20 @@ in

122 client.succeed("nix-build ~/code/myapp")

124 client.succeed("nix-build ~/code/myapp")

123 client.succeed("ob -v thunk unpack ~/code/myapp")

125 client.succeed("ob -v thunk unpack ~/code/myapp")

124

126

125− with subtest("test building an invalid thunk fails"):

127+ with subtest("building an invalid thunk fails"):

126− client.succeed("cd ~/code/myapp && git checkout -b bad")

128+ client.succeed("cd ~/code/myapp/local && git checkout -b bad")

127 client.succeed(

129 client.succeed(

128− "cp ${invalidThunkableSample} ~/code/myapp/default.nix"

130+ "cp ${invalidThunkableSample} ~/code/myapp/local/default.nix"

129 )

131 )

130− client.succeed("cd ~/code/myapp && git add .")

132+ client.succeed("cd ~/code/myapp/local && git add .")

131− client.succeed('git config --global user.email "you@example.com"')

132− client.succeed('git config --global user.name "Your Name"')

133− client.succeed('cd ~/code/myapp && git commit -m "Bad commit"')

133+ client.succeed('cd ~/code/myapp/local && git commit -m "Bad commit"')

134− client.succeed("cd ~/code/myapp && git push -u origin bad")

134+ client.succeed("cd ~/code/myapp/local && git push -u origin bad")

135 client.succeed("ob -v thunk pack ~/code/myapp --public")

136− client.fail("nix-build ~/code/myapp")

136+ client.fail("nix-build ~/code/myapp")

137 client.succeed("ob -v thunk unpack ~/code/myapp")

138− client.succeed("cd ~/code/myapp && git checkout master")

138+ client.succeed("cd ~/code/myapp/local && git checkout master")

139

140− with subtest("test obelisk can detect private repos"):

140+ with subtest("obelisk can detect private repos"):

141 client.succeed("ob -v thunk pack ~/code/myapp")

142 client.succeed("""grep -qF '"private": true' ~/code/myapp/git.json""")

143 client.succeed("ob -v thunk unpack ~/code/myapp")

haskell-overlays/obelisk.nix+1

@@ -34,6 +34,7 @@ in

34 pkgs.coreutils

35 pkgs.git

36 pkgs.nix

37+ pkgs.nix-prefetch-git

37 pkgs.rsync

38 pkgs.rsync

38 ];

39 ];

39 };

40 };

lib/cliapp/src/Obelisk/CliApp/Spinner.hs−1

@@ -3,7 +3,6 @@

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TupleSections #-}

7-- | Provides a simple CLI spinner that interoperates cleanly with the rest of the logging output.

6-- | Provides a simple CLI spinner that interoperates cleanly with the rest of the logging output.

8module Obelisk.CliApp.Spinner

7module Obelisk.CliApp.Spinner

9 ( withSpinner

8 ( withSpinner

lib/command/obelisk-command.cabal+1

@@ -18,6 +18,7 @@ library

18 , either

19 , errors

20 , exceptions

21+ , extra

21 , filepath

22 , filepath

22 , git

23 , git

23 , github

24 , github

lib/command/src/Obelisk/Command.hs+38−35

@@ -10,8 +10,9 @@ import Control.Monad

10import Control.Monad.IO.Class (MonadIO, liftIO)

11import Data.Bool (bool)

12import Data.Foldable (for_)

13−import Data.List

13+import Data.List (isInfixOf, isPrefixOf)

14−import Data.List.NonEmpty (nonEmpty)

14+import Data.List.NonEmpty (NonEmpty, nonEmpty)

15+import qualified Data.List.NonEmpty as NonEmpty

15import qualified Data.Map as Map

16import qualified Data.Map as Map

16import qualified Data.Text as T

17import qualified Data.Text as T

17import Data.Traversable (for)

18import Data.Traversable (for)

@@ -86,7 +87,7 @@ data ObCommand

86 | ObCommand_Deploy DeployCommand

87 | ObCommand_Deploy DeployCommand

87 | ObCommand_Run [(FilePath, HackOn)]

88 | ObCommand_Run [(FilePath, HackOn)]

88 | ObCommand_Profile String [String]

89 | ObCommand_Profile String [String]

89− | ObCommand_Thunk ThunkCommand

90+ | ObCommand_Thunk ThunkOption

90 | ObCommand_Repl [(FilePath, HackOn)]

91 | ObCommand_Repl [(FilePath, HackOn)]

91 | ObCommand_Watch [(FilePath, HackOn)]

92 | ObCommand_Watch [(FilePath, HackOn)]

92 | ObCommand_Shell ShellOpts

93 | ObCommand_Shell ShellOpts

@@ -109,7 +110,7 @@ obCommand cfg = hsubparser

109 , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"

110 , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"

110 , command "run" $ info (ObCommand_Run <$> hackOnOpts) $ progDesc "Run current project in development mode"

111 , command "run" $ info (ObCommand_Run <$> hackOnOpts) $ progDesc "Run current project in development mode"

111 , command "profile" $ info (uncurry ObCommand_Profile <$> profileCommand) $ progDesc "Run current project with profiling enabled"

112 , command "profile" $ info (uncurry ObCommand_Profile <$> profileCommand) $ progDesc "Run current project with profiling enabled"

112− , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"

113+ , command "thunk" $ info (ObCommand_Thunk <$> thunkOption) $ progDesc "Manipulate thunk directories"

113 , command "repl" $ info (ObCommand_Repl <$> hackOnOpts) $ progDesc "Open an interactive interpreter"

114 , command "repl" $ info (ObCommand_Repl <$> hackOnOpts) $ progDesc "Open an interactive interpreter"

114 , command "watch" $ info (ObCommand_Watch <$> hackOnOpts) $ progDesc "Watch current project for errors and warnings"

115 , command "watch" $ info (ObCommand_Watch <$> hackOnOpts) $ progDesc "Watch current project for errors and warnings"

115 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"

116 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"

@@ -208,15 +209,6 @@ profileCommand = (,)

208 <> showDefault

209 <> showDefault

209 ))

210 ))

210

211

211−

212−--TODO: Result should provide normalised path and also original user input for error reporting.

213−thunkDirectoryParser :: Parser FilePath

214−thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgument $ mconcat

215− [ action "directory"

216− , metavar "THUNKDIR"

217− , help "Path to directory containing thunk data"

218− ]

219−

220thunkConfig :: Parser ThunkConfig

212thunkConfig :: Parser ThunkConfig

221thunkConfig = ThunkConfig

213thunkConfig = ThunkConfig

222 <$>

214 <$>

@@ -235,18 +227,33 @@ thunkPackConfig = ThunkPackConfig

235 <$> switch (long "force" <> short 'f' <> help "Force packing thunks even if there are branches not pushed upstream, uncommitted changes, stashes. This will cause changes that have not been pushed upstream to be lost; use with care.")

227 <$> switch (long "force" <> short 'f' <> help "Force packing thunks even if there are branches not pushed upstream, uncommitted changes, stashes. This will cause changes that have not been pushed upstream to be lost; use with care.")

236 <*> thunkConfig

228 <*> thunkConfig

237

229

230+data ThunkOption = ThunkOption

231+ { _thunkOption_thunks :: NonEmpty FilePath

232+ , _thunkOption_command :: ThunkCommand

233+ } deriving Show

234+

238data ThunkCommand

235data ThunkCommand

239− = ThunkCommand_Update [FilePath] ThunkUpdateConfig

236+ = ThunkCommand_Update ThunkUpdateConfig

240− | ThunkCommand_Unpack [FilePath]

237+ | ThunkCommand_Unpack

241− | ThunkCommand_Pack [FilePath] ThunkPackConfig

238+ | ThunkCommand_Pack ThunkPackConfig

239+ | ThunkCommand_Init

242 deriving Show

240 deriving Show

243

241

244−thunkCommand :: Parser ThunkCommand

242+thunkOption :: Parser ThunkOption

245−thunkCommand = hsubparser $ mconcat

243+thunkOption = hsubparser $ mconcat

246− [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> thunkUpdateConfig) $ progDesc "Update thunk to latest revision available"

244+ [ command "update" $ info (thunkOptionWith $ ThunkCommand_Update <$> thunkUpdateConfig) $ progDesc "Update packed thunk to latest revision available on the tracked branch"

247− , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

245+ , command "unpack" $ info (thunkOptionWith $ pure ThunkCommand_Unpack) $ progDesc "Unpack thunk into git checkout of revision it points to"

248− , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> thunkPackConfig) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"

246+ , command "pack" $ info (thunkOptionWith $ ThunkCommand_Pack <$> thunkPackConfig) $ progDesc "Pack git checkout or unpacked thunk into thunk that points at the current branch's upstream"

247+ , command "init" $ info (thunkOptionWith $ pure ThunkCommand_Init) $ progDesc "Initialize git checkout by converting it to an unpacked thunk"

249 ]

248 ]

249+ where

250+ thunkOptionWith f = ThunkOption

251+ <$> ((NonEmpty.:|)

252+ <$> thunkDirArg (metavar "THUNKDIRS..." <> help "Paths to directories containing thunk data")

253+ <*> many (thunkDirArg mempty)

254+ )

255+ <*> f

256+ thunkDirArg opts = fmap (dropTrailingPathSeparator . normalise) $ strArgument $ action "directory" <> opts

250

257

251data ShellOpts

258data ShellOpts

252 = ShellOpts

259 = ShellOpts

@@ -384,16 +391,9 @@ ob = \case

384 when rootEqualsTarget $

391 when rootEqualsTarget $

385 failWith $ "Deploy directory " <> T.pack deployDir <> " should not be the same as project root."

392 failWith $ "Deploy directory " <> T.pack deployDir <> " should not be the same as project root."

386 thunkPtr <- readThunk root >>= \case

393 thunkPtr <- readThunk root >>= \case

387− Left err -> failWith $ case err of

388− ReadThunkError_AmbiguousFiles ->

389− "Project root " <> T.pack r <> " is not a git repository or valid thunk"

390− ReadThunkError_UnrecognizedFiles ->

391− "Project root " <> T.pack r <> " is not a git repository or valid thunk"

392− _ -> "thunk read: " <> T.pack (show err)

394+ Left err -> failWith $ "Can't read thunk at: " <> T.pack root <> ": " <> T.pack (show err)

393− Right (ThunkData_Packed ptr) -> return ptr

395+ Right (ThunkData_Packed _ ptr) -> return ptr

394− Right (ThunkData_Checkout (Just ptr)) -> return ptr

395− Right (ThunkData_Checkout Nothing) ->

396− getThunkPtr False root Nothing

396+ Right ThunkData_Checkout -> getThunkPtr False root Nothing

397 let sshKeyPath = _deployInitOpts_sshKey deployOpts

398 hostname = _deployInitOpts_hostname deployOpts

399 route = _deployInitOpts_route deployOpts

@@ -409,10 +409,13 @@ ob = \case

409 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs

410 ObCommand_Run hackPathsList -> withHackPaths hackPathsList run

411 ObCommand_Profile basePath rtsFlags -> profile basePath rtsFlags

412− ObCommand_Thunk tc -> case tc of

412+ ObCommand_Thunk to -> case _thunkOption_command to of

413− ThunkCommand_Update thunks config -> for_ thunks (updateThunkToLatest config)

413+ ThunkCommand_Update config -> for_ thunks (updateThunkToLatest config)

414− ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

414+ ThunkCommand_Unpack -> for_ thunks unpackThunk

415− ThunkCommand_Pack thunks config -> for_ thunks (packThunk config)

415+ ThunkCommand_Pack config -> for_ thunks (packThunk config)

416+ ThunkCommand_Init -> for_ thunks initThunk

417+ where

418+ thunks = _thunkOption_thunks to

416 ObCommand_Repl hackPathsList -> withHackPaths hackPathsList runRepl

419 ObCommand_Repl hackPathsList -> withHackPaths hackPathsList runRepl

417 ObCommand_Watch hackPathsList -> withHackPaths hackPathsList runWatch

420 ObCommand_Watch hackPathsList -> withHackPaths hackPathsList runWatch

418 ObCommand_Shell (ShellOpts shellAttr hackPathsList cmd) -> withHackPaths hackPathsList $ \root hackPaths ->

421 ObCommand_Shell (ShellOpts shellAttr hackPathsList cmd) -> withHackPaths hackPathsList $ \root hackPaths ->

lib/command/src/Obelisk/Command/Deploy.hs+7−7

@@ -9,7 +9,7 @@ module Obelisk.Command.Deploy where

9import Control.Lens

10import Control.Monad

11import Control.Monad.Catch (Exception (displayException), MonadThrow, bracket, throwM, try)

12−import Control.Monad.IO.Class (liftIO)

12+import Control.Monad.IO.Class (MonadIO, liftIO)

13import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)

14import Data.Bits

15import qualified Data.ByteString.Lazy as BSL

@@ -77,8 +77,8 @@ deployInit thunkPtr deployDir sshKeyPath hostnames route adminEmail enableHttps

77 ]

79 let srcDir = deployDir </> "src"

80− withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ liftIO $ do

80+ withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ do

81− createThunk srcDir thunkPtr

81+ createThunk srcDir $ Right thunkPtr

82 setupObeliskImpl deployDir

84 withSpinner "Writing deployment configuration" $ do

@@ -92,8 +92,8 @@ deployInit thunkPtr deployDir sshKeyPath hostnames route adminEmail enableHttps

92 withSpinner ("Initializing git repository (" <> T.pack deployDir <> ")") $

93 initGit deployDir

95−setupObeliskImpl :: FilePath -> IO ()

95+setupObeliskImpl :: MonadIO m => FilePath -> m ()

96−setupObeliskImpl deployDir = do

96+setupObeliskImpl deployDir = liftIO $ do

97 let

98 implDir = toImplDir deployDir

99 goBackUp = foldr (</>) "" $ (".." <$) $ splitPath $ makeRelative deployDir implDir

@@ -109,8 +109,8 @@ deployPush deployPath getNixBuilders = do

109 routeHost <- getHostFromRoute enableHttps route

110 let srcPath = deployPath </> "src"

111 thunkPtr <- readThunk srcPath >>= \case

112− Right (ThunkData_Packed ptr) -> return ptr

112+ Right (ThunkData_Packed _ ptr) -> return ptr

113− Right (ThunkData_Checkout _) -> do

113+ Right ThunkData_Checkout -> do

114 checkGitCleanStatus srcPath True >>= \case

115 True -> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath

116 False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."

lib/command/src/Obelisk/Command/Project.hs+1−10

@@ -13,7 +13,6 @@ module Obelisk.Command.Project

13 , nixShellWithPkgs

14 , obeliskDirName

15 , toImplDir

16− , toNixPath

17 , toObeliskDir

16 , toObeliskDir

18 , withProjectRoot

17 , withProjectRoot

19 ) where

18 ) where

@@ -28,7 +27,6 @@ import Data.Bits

28import qualified Data.ByteString.Lazy as BSL

27import qualified Data.ByteString.Lazy as BSL

29import Data.Default (def)

28import Data.Default (def)

30import Data.Function ((&), on)

29import Data.Function ((&), on)

31−import Data.List (isInfixOf)

32import Data.Map (Map)

30import Data.Map (Map)

33import Data.Text (Text)

31import Data.Text (Text)

34import qualified Data.Text as T

32import qualified Data.Text as T

@@ -49,7 +47,7 @@ import Obelisk.App (MonadObelisk)

49import Obelisk.CliApp

47import Obelisk.CliApp

50import Obelisk.Command.Nix

48import Obelisk.Command.Nix

51import Obelisk.Command.Thunk

49import Obelisk.Command.Thunk

52−import Obelisk.Command.Utils (nixExePath, nixBuildExePath)

50+import Obelisk.Command.Utils (nixBuildExePath, nixExePath, toNixPath)

54--TODO: Make this module resilient to random exceptions

52--TODO: Make this module resilient to random exceptions

@@ -248,13 +246,6 @@ filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= uma

248 fileGroupWritable = fileMode s .&. 0o020 == 0o020

246 fileGroupWritable = fileMode s .&. 0o020 == 0o020

249 umaskGroupWritable = umask .&. 0o020 == 0

247 umaskGroupWritable = umask .&. 0o020 == 0

250

248

251−-- | Nix syntax requires relative paths to be prefixed by @./@ or

252−-- @../@. This will make a 'FilePath' that can be embedded in a Nix

253−-- expression.

254−toNixPath :: FilePath -> FilePath

255−toNixPath root | "/" `isInfixOf` root = root

256− | otherwise = "./" <> root

257−

258nixShellRunConfig :: MonadObelisk m => FilePath -> Bool -> Maybe String -> m NixShellConfig

249nixShellRunConfig :: MonadObelisk m => FilePath -> Bool -> Maybe String -> m NixShellConfig

259nixShellRunConfig root isPure command = do

250nixShellRunConfig root isPure command = do

260 nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $

251 nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $

lib/command/src/Obelisk/Command/Run.hs+12−7

@@ -73,7 +73,7 @@ import Obelisk.CliApp (

73 withSpinner,

74 )

75import Obelisk.Command.Nix

76−import Obelisk.Command.Project (nixShellWithPkgs, toImplDir, withProjectRoot, findProjectAssets)

76+import Obelisk.Command.Project (nixShellWithPkgs, withProjectRoot, findProjectAssets)

77import Obelisk.Command.Thunk (attrCacheFileName)

78import Obelisk.Command.Utils (findExePath, ghcidExePath)

@@ -199,7 +199,7 @@ getLocalPkgs root hackPaths = do

199 rootsAndExclusions = calcHackOnFinds "" hackPaths

200

201 fmap fold $ for (Map.toAscList rootsAndExclusions) $ \(hackPathRoot, exclusions) ->

202− let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton (toImplDir "*" </> attrCacheFileName)

202+ let allExclusions = obeliskPackageExclusions <> exclusions <> Set.singleton ("*" </> attrCacheFileName)

203 in fmap (Set.fromList . map normalise) $ runFind $

204 ["-L", hackPathRoot, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]

205 <> concat [["-not", "-path", p </> "*"] | p <- toList allExclusions]

@@ -342,14 +342,19 @@ parsePackagesOrFail dirs' = do

342 | _cabalPackageInfo_buildable packageInfo -> Right packageInfo

343 _ -> Left dir

344

345+ -- Sort duplicate packages such that we prefer shorter paths, but fall back to alphabetical ordering.

346+ let packagesByName = Map.map (NE.sortBy $ comparing $ \p -> let n = _cabalPackageInfo_packageFile p in (length n, n))

345− let packagesByName = Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']

347+ $ Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']

346 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of

348 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of

347 p NE.:| [] -> pure p -- No ambiguity here

349 p NE.:| [] -> pure p -- No ambiguity here

348 p NE.:| _ -> do

350 p NE.:| _ -> do

351+ let chosenText = " [Chosen] "

352+ prefix p'

353+ | _cabalPackageInfo_packageFile p' == _cabalPackageInfo_packageFile p = chosenText

354+ | otherwise = T.map (const ' ') chosenText

349− putLog Warning $ T.pack $

355+ putLog Warning $ T.unlines $

350− "Packages named '" <> T.unpack packageName <> "' appear in " <> show (length ps) <> " different locations: "

356+ "Packages named '" <> packageName <> "' appear in " <> T.pack (show $ length ps) <> " different locations: "

351− <> intercalate ", " (map _cabalPackageInfo_packageFile $ toList ps)

357+ : map (\p' -> prefix p' <> T.pack (_cabalPackageInfo_packageFile p')) (toList ps)

352− <> "; Picking " <> _cabalPackageInfo_packageFile p

353 pure p

358 pure p

354

359

355 packageInfos <- case NE.nonEmpty $ toList unambiguous of

360 packageInfos <- case NE.nonEmpty $ toList unambiguous of

lib/command/src/Obelisk/Command/Thunk.hs+367−259

@@ -5,43 +5,17 @@

5{-# LANGUAGE MultiWayIf #-}

6{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE PatternGuards #-}

8+{-# LANGUAGE QuasiQuotes #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TypeApplications #-}

10{-# LANGUAGE TypeApplications #-}

10−module Obelisk.Command.Thunk

11+module Obelisk.Command.Thunk where

11− ( GitHubSource (..)

12− , GitUri (..)

13− , ReadThunkError (..)

14− , ThunkConfig (..)

15− , ThunkData (..)

16− , ThunkPackConfig (..)

17− , ThunkPtr (..)

18− , ThunkRev (..)

19− , ThunkSource (..)

20− , ThunkUpdateConfig (..)

21− , attrCacheFileName

22− , createThunk

23− , createThunkWithLatest

24− , getLatestRev

25− , getThunkGitBranch

26− , getThunkPtr

27− , gitUriToText

28− , nixBuildAttrWithCache

29− , nixBuildThunkAttrWithCache

30− , packThunk

31− , parseGitUri

32− , readThunk

33− , unpackThunk

34− , updateThunk

35− , updateThunkToLatest

36− , uriThunkPtr

37− ) where

39import Control.Applicative

13import Control.Applicative

40import Control.Exception (displayException, try)

14import Control.Exception (displayException, try)

41−import qualified Control.Lens as Lens

15+import Control.Lens (ifor, ifor_, (.~))

42−import Control.Lens.Indexed hiding ((<.>))

43import Control.Monad

16import Control.Monad

44−import Control.Monad.Catch (handle)

17+import Control.Monad.Extra (findM, unlessM, whenM)

18+import Control.Monad.Catch (MonadCatch, handle)

45import Control.Monad.Except

19import Control.Monad.Except

46import Data.Aeson ((.=))

20import Data.Aeson ((.=))

47import qualified Data.Aeson as Aeson

21import qualified Data.Aeson as Aeson

@@ -51,21 +25,27 @@ import qualified Data.ByteString.Lazy as LBS

51import Data.Containers.ListUtils (nubOrd)

25import Data.Containers.ListUtils (nubOrd)

52import Data.Default

26import Data.Default

53import Data.Either.Combinators (fromRight', rightToMaybe)

27import Data.Either.Combinators (fromRight', rightToMaybe)

28+import Data.Foldable (toList)

29+import Data.Function ((&))

30+import Data.Functor ((<&>))

54import Data.Git.Ref (Ref)

31import Data.Git.Ref (Ref)

55import qualified Data.Git.Ref as Ref

32import qualified Data.Git.Ref as Ref

56import qualified Data.List as L

33import qualified Data.List as L

57−import Data.List.NonEmpty (NonEmpty (..))

34+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

58import qualified Data.List.NonEmpty as NonEmpty

35import qualified Data.List.NonEmpty as NonEmpty

59import Data.Map (Map)

36import Data.Map (Map)

60import qualified Data.Map as Map

37import qualified Data.Map as Map

61import Data.Maybe

38import Data.Maybe

62import Data.Set (Set)

39import Data.Set (Set)

63import qualified Data.Set as Set

40import qualified Data.Set as Set

41+import Data.String.Here.Interpolated (i)

42+import Data.String.Here.Uninterpolated (here)

64import Data.Text (Text)

43import Data.Text (Text)

65import qualified Data.Text as T

44import qualified Data.Text as T

66import Data.Text.Encoding

45import Data.Text.Encoding

67import qualified Data.Text.IO as T

46import qualified Data.Text.IO as T

68import Data.Time.Clock.POSIX (posixSecondsToUTCTime)

47import Data.Time.Clock.POSIX (posixSecondsToUTCTime)

48+import Data.Traversable (for)

69import Data.Yaml (parseMaybe)

49import Data.Yaml (parseMaybe)

70import GitHub

50import GitHub

71import GitHub.Data.Name

51import GitHub.Data.Name

@@ -84,11 +64,10 @@ import Obelisk.Command.Utils

85--TODO: Support symlinked thunk data

65--TODO: Support symlinked thunk data

86data ThunkData

66data ThunkData

87− = ThunkData_Packed ThunkPtr

67+ = ThunkData_Packed ThunkSpec ThunkPtr

88 -- ^ Packed thunk

68 -- ^ Packed thunk

89− | ThunkData_Checkout (Maybe ThunkPtr)

69+ | ThunkData_Checkout

90 -- ^ Checked out thunk that was unpacked from this pointer

70 -- ^ Checked out thunk that was unpacked from this pointer

91− deriving (Show, Eq, Ord)

93-- | A reference to the exact data that a thunk should translate into

72-- | A reference to the exact data that a thunk should translate into

94data ThunkPtr = ThunkPtr

73data ThunkPtr = ThunkPtr

@@ -213,96 +192,117 @@ nixPrefetchGit uri rev fetchSubmodules =

213

192

214--TODO: Pretty print these

193--TODO: Pretty print these

215data ReadThunkError

194data ReadThunkError

216− = ReadThunkError_UnrecognizedFiles

195+ = ReadThunkError_UnrecognizedThunk

217− | ReadThunkError_AmbiguousFiles

196+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)

218− | ReadThunkError_UnrecognizedLoader Text

197+ | ReadThunkError_MissingPaths (NonEmpty FilePath)

219− | ReadThunkError_UnparseablePtr LBS.ByteString

198+ | ReadThunkError_UnparseablePtr FilePath String

199+ | ReadThunkError_FileError IOError

200+ | ReadThunkError_FileDoesNotMatch FilePath Text

201+ | ReadThunkError_UnrecognizedState String

202+ | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr

220− deriving (Show)

203+ deriving (Show)

221−

204+

222−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.

205+unpackedDirName :: FilePath

223−-- If the thunk is packed and additional data is present, fail.

206+unpackedDirName = "local"

224−readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)

225−readThunk thunkDir = do

226− files <- liftIO $ listDirectory thunkDir

227− case ".git" `elem` files of

228− True -> fmap ThunkData_Checkout <$> do

229− let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"

230− liftIO $ doesDirectoryExist origThunkPath >>= \case

231− True -> fmap Just <$> readPackedThunk origThunkPath

232− False -> return $ return Nothing

233− False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir

234

207

235attrCacheFileName :: FilePath

208attrCacheFileName :: FilePath

236attrCacheFileName = ".attr-cache"

209attrCacheFileName = ".attr-cache"

237

210

238−data ThunkType = ThunkType

211+-- | Specification for how a file in a thunk version works.

239− { _thunkType_loader :: FilePath

212+data ThunkFileSpec

240− , _thunkType_json :: FilePath

213+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data

241− , _thunkType_optional :: Set FilePath

214+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly

242− , _thunkType_loaderVersions :: NonEmpty Text

215+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked

243− , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr

216+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache

244− }

217+

245−

218+-- | Specification for how a set of files in a thunk version work.

246−gitHubThunkType :: ThunkType

219+data ThunkSpec = ThunkSpec

247−gitHubThunkType = ThunkType

220+ { _thunkSpec_name :: !Text

248− { _thunkType_loader = "default.nix"

221+ , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)

249− , _thunkType_json = "github.json"

250− , _thunkType_optional = Set.fromList [attrCacheFileName]

251− , _thunkType_loaderVersions = gitHubStandaloneLoaders

252− , _thunkType_parser = parseThunkPtr $ \v ->

253− ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v

254− }

255−

256−gitThunkType :: ThunkType

257−gitThunkType = ThunkType

258− { _thunkType_loader = "default.nix"

259− , _thunkType_json = "git.json"

260− , _thunkType_optional = Set.fromList [attrCacheFileName]

261− , _thunkType_loaderVersions = plainGitStandaloneLoaders

262− , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource

263 }

222 }

264

223

265−thunkTypes :: [ThunkType]

224+thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)

266−thunkTypes = [gitThunkType, gitHubThunkType]

225+thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]

267−

226+

268−findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)

227+-- | Attempts to match a 'ThunkSpec' to a given directory.

269−findThunkType types thunkDir = do

228+matchThunkSpecToDir

270− matches <- fmap catMaybes $ forM types $ \thunkType -> do

229+ :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)

271− let

230+ => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory

272− expectedContents = Set.fromList $ (thunkDir </>) <$>

231+ -> FilePath -- ^ Path to directory

273− [ _thunkType_loader thunkType

232+ -> Set FilePath -- ^ Set of file paths relative to the given directory

274− , _thunkType_json thunkType

233+ -> m ThunkData

275− ]

234+matchThunkSpecToDir thunkSpec dir dirFiles = do

276− optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)

235+ case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of

277−

236+ Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs

278− -- Ensure that there aren't any other files in the thunk

237+ Nothing -> pure ()

279− -- NB: System.Directory.listDirectory returns the contents without the directory path

238+ case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of

280− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir

239+ Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs

281− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)

240+ Nothing -> pure ()

282− missingContents = expectedContents `Set.difference` files

241+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case

283− pure $ if Set.null unexpectedContents && Set.null missingContents

242+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath

284− then Just thunkType

243+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case

285− else Nothing

244+ False -> Nothing

286−

245+ True -> Just ThunkData_Checkout

287− pure $ case matches of

246+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do

288− [singleMatch] -> Right singleMatch

247+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)

289− [] -> Left ReadThunkError_UnrecognizedFiles

248+ case T.strip expectedContents == T.strip actualContents of

290− _ -> Left ReadThunkError_AmbiguousFiles

249+ True -> pure Nothing

250+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents

251+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do

252+ let path = dir </> expectedPath

253+ liftIO (doesFileExist path) >>= \case

254+ False -> pure Nothing

255+ True -> do

256+ actualContents <- liftIO $ LBS.readFile path

257+ case parser actualContents of

258+ Right v -> pure $ Just (ThunkData_Packed thunkSpec v)

259+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e

260+

261+ case nonEmpty datas of

262+ Nothing -> throwError ReadThunkError_UnrecognizedThunk

263+ Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)

264+ where

265+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys

266+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath

267+

268+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec

269+

270+ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec

271+ isRequiredFileSpec = \case

272+ ThunkFileSpec_FileMatches _ -> True

273+ _ -> False

274+

275+ dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case

276+ True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []

277+ False -> pure ()

278+

279+ -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"

280+ mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout

281+ mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked

282+ mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked

283+ mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) =

284+ if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB

285+

286+ bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"

287+

288+ fold1WithM (x :| xs) f = foldM f x xs

289+

290+readThunkWith

291+ :: (MonadObelisk m)

292+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)

293+readThunkWith specTypes dir = do

294+ dirFiles <- Set.fromList <$> liftIO (listDirectory dir)

295+ let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering

296+ flip fix specs $ \loop -> \case

297+ [] -> pure $ Left ReadThunkError_UnrecognizedThunk

298+ spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case

299+ Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest

300+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]

291

301

292-- | Read a thunk and validate that it is exactly a packed thunk.

302-- | Read a thunk and validate that it is exactly a packed thunk.

293-- If additional data is present, fail.

303-- If additional data is present, fail.

294−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)

304+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)

295−readPackedThunk thunkDir = runExceptT $ do

305+readThunk = readThunkWith thunkSpecTypes

296− thunkType <- ExceptT $ findThunkType thunkTypes thunkDir

297− -- Ensure that we recognize the thunk loader

298− loader <- liftIO $ T.readFile $ thunkDir </> _thunkType_loader thunkType

299− unless (loader `elem` _thunkType_loaderVersions thunkType) $ do

300− throwError $ ReadThunkError_UnrecognizedLoader loader

301−

302− txt <- liftIO $ LBS.readFile $ thunkDir </> _thunkType_json thunkType

303− case parseMaybe (_thunkType_parser thunkType) =<< Aeson.decode txt of

304− Nothing -> throwError $ ReadThunkError_UnparseablePtr txt

305− Just ptr -> return ptr

306

307parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr

308parseThunkPtr parseSrc v = do

@@ -346,16 +346,18 @@ parseGitSource v = do

346overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()

347overwriteThunk target thunk = do

348 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)

349− Right _ <- readThunk target

349+ readThunk target >>= \case

350+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]

351+ Right _ -> pure ()

350

352

351 --TODO: Is there a safer way to do this overwriting?

353 --TODO: Is there a safer way to do this overwriting?

352− liftIO $ removeDirectoryRecursive target

354+ callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-r", target] -- target may be a symlink

353− liftIO $ createThunk target thunk

355+ createThunk target $ Right thunk

354

356

355−thunkPtrLoader :: ThunkPtr -> Text

357+thunkPtrToSpec :: ThunkPtr -> ThunkSpec

356−thunkPtrLoader thunk = case _thunkPtr_source thunk of

358+thunkPtrToSpec thunk = case _thunkPtr_source thunk of

357− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders

359+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs

358− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders

360+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs

359

361

360-- It's important that formatting be very consistent here, because

362-- It's important that formatting be very consistent here, because

361-- otherwise when people update thunks, their patches will be messy

363-- otherwise when people update thunks, their patches will be messy

@@ -402,35 +404,56 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

402 , confTrailingNewline = True

404 , confTrailingNewline = True

403 }

405 }

404

406

405−createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()

407+-- | Initialize a git repository to an unpacked thunk.

408+initThunk :: MonadObelisk m => FilePath -> m ()

409+initThunk target = withSpinner [i|Initializing thunk at ${target}|] $ do

410+ checkThunkDirectory target

411+ unlessM (liftIO $ doesDirectoryExist $ target </> ".git") $ failWith [i|${target} is not a git checkout.|]

412+ ptr <- getThunkPtr False target Nothing

413+ let tempThunkDir = target <.> "thunk-init"

414+ whenM (liftIO $ doesPathExist tempThunkDir) $

415+ failWith [i|A previous 'thunk init' left unfinished state at ${tempThunkDir}. You will need to rename or remove that path before trying again.|]

416+ createThunk tempThunkDir $ Left (thunkPtrToSpec ptr) -- Only write the skeleton, but skip the ptr itself since it's unpacked

417+ liftIO $ do

418+ renameDirectory target (tempThunkDir </> unpackedDirName)

419+ removePathForcibly target

420+ renameDirectory tempThunkDir target

421+

422+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()

406−createThunk target thunk = liftIO $ do

423+createThunk target ptrInfo =

407− createDirectoryIfMissing True (target </> attrCacheFileName)

424+ ifor_ (_thunkSpec_files spec) $ \path -> \case

408− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)

425+ ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content

409− let

426+ ThunkFileSpec_Ptr _ -> case ptrInfo of

410− jsonFileName = case _thunkPtr_source thunk of

427+ Left _ -> pure () -- We can't write the ptr without it

411− ThunkSource_GitHub _ -> "github"

412− ThunkSource_Git _ -> "git"

413− LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)

428+ Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)

429+ _ -> pure ()

430+ where

431+ spec = either id thunkPtrToSpec ptrInfo

432+ withReadyPath path f = do

433+ let fullPath = target </> path

434+ putLog Debug $ "Writing thunk file " <> T.pack fullPath

435+ liftIO $ createDirectoryIfMissing True $ takeDirectory fullPath

436+ f fullPath

414

437

415createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()

438createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()

416createThunkWithLatest target s = do

439createThunkWithLatest target s = do

417 rev <- getLatestRev s

440 rev <- getLatestRev s

418− createThunk target $ ThunkPtr

441+ createThunk target $ Right $ ThunkPtr

419 { _thunkPtr_source = s

442 { _thunkPtr_source = s

420 , _thunkPtr_rev = rev

443 , _thunkPtr_rev = rev

421 }

444 }

422

445

423updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()

446updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()

424−updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do

447+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do

425− checkThunkDirectory "ob thunk update directory cannot be '.'" target

448+ checkThunkDirectory target

426 -- check to see if thunk should be updated to a specific branch or just update it's current branch

449 -- check to see if thunk should be updated to a specific branch or just update it's current branch

427 case mBranch of

450 case mBranch of

428 Nothing -> do

451 Nothing -> do

429 (overwrite, ptr) <- readThunk target >>= \case

452 (overwrite, ptr) <- readThunk target >>= \case

430− Left err -> failWith $ T.pack $ "thunk update: " <> show err

453+ Left err -> failWith [i|Thunk update: ${err}|]

431 Right c -> case c of

454 Right c -> case c of

432− ThunkData_Packed t -> return (target, t)

455+ ThunkData_Packed _ t -> return (target, t)

433− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"

456+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"

434 let src = _thunkPtr_source ptr

457 let src = _thunkPtr_source ptr

435 rev <- getLatestRev src

458 rev <- getLatestRev src

436 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr

459 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr

@@ -438,14 +461,16 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner

438 , _thunkPtr_rev = rev

461 , _thunkPtr_rev = rev

439 }

462 }

440 Just branch -> readThunk target >>= \case

463 Just branch -> readThunk target >>= \case

441− Left err -> failWith $ T.pack $ "thunk update: " <> show err

464+ Left err -> failWith [i|Thunk update: ${err}|]

442 Right c -> case c of

465 Right c -> case c of

443− ThunkData_Packed t -> case _thunkPtr_source t of

466+ ThunkData_Packed _ t -> case _thunkPtr_source t of

444 ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch

467 ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch

445 ThunkSource_GitHub tsgh -> do

468 ThunkSource_GitHub tsgh -> do

446 let tsg = forgetGithub False tsgh

469 let tsg = forgetGithub False tsgh

447 setThunk thunkConfig target tsg branch

470 setThunk thunkConfig target tsg branch

448− ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> show target <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."

471+ ThunkData_Checkout -> failWith [i|Thunk located at ${target} is unpacked. Use 'ob thunk pack' on the desired directory and then try 'ob thunk update' again.|]

472+ where

473+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")

449

474

450setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()

475setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()

451setThunk thunkConfig target gs branch = do

476setThunk thunkConfig target gs branch = do

@@ -455,21 +480,21 @@ setThunk thunkConfig target gs branch = do

455

480

456-- | All recognized github standalone loaders, ordered from newest to oldest.

481-- | All recognized github standalone loaders, ordered from newest to oldest.

457-- This tool will only ever produce the newest one when it writes a thunk.

482-- This tool will only ever produce the newest one when it writes a thunk.

458−gitHubStandaloneLoaders :: NonEmpty Text

483+gitHubThunkSpecs :: NonEmpty ThunkSpec

459−gitHubStandaloneLoaders =

484+gitHubThunkSpecs =

460− gitHubStandaloneLoaderV4 :|

485+ gitHubThunkSpecV5 :|

461− [ gitHubStandaloneLoaderV3

486+ [ gitHubThunkSpecV4

462− , gitHubStandaloneLoaderV2

487+ , gitHubThunkSpecV3

463− , gitHubStandaloneLoaderV1

488+ , gitHubThunkSpecV2

489+ , gitHubThunkSpecV1

464 ]

490 ]

465

491

466−gitHubStandaloneLoaderV1 :: Text

492+gitHubThunkSpecV1 :: ThunkSpec

467−gitHubStandaloneLoaderV1 = T.unlines

493+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"

468− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"

494+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"

469− ]

470

495

471−gitHubStandaloneLoaderV2 :: Text

496+gitHubThunkSpecV2 :: ThunkSpec

472−gitHubStandaloneLoaderV2 = T.unlines

497+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines

473 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.

498 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.

474 , "import ((import <nixpkgs> {}).fetchFromGitHub ("

499 , "import ((import <nixpkgs> {}).fetchFromGitHub ("

475 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"

500 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"

@@ -479,8 +504,8 @@ gitHubStandaloneLoaderV2 = T.unlines

479 , "))"

504 , "))"

480 ]

505 ]

481

506

482−gitHubStandaloneLoaderV3 :: Text

507+gitHubThunkSpecV3 :: ThunkSpec

483−gitHubStandaloneLoaderV3 = T.unlines

508+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines

484 [ "# DO NOT HAND-EDIT THIS FILE"

509 [ "# DO NOT HAND-EDIT THIS FILE"

485 , "let"

510 , "let"

486 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"

511 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"

@@ -499,8 +524,8 @@ gitHubStandaloneLoaderV3 = T.unlines

499 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

524 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

500 ]

525 ]

501

526

502−gitHubStandaloneLoaderV4 :: Text

527+gitHubThunkSpecV4 :: ThunkSpec

503−gitHubStandaloneLoaderV4 = T.unlines

528+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines

504 [ "# DO NOT HAND-EDIT THIS FILE"

529 [ "# DO NOT HAND-EDIT THIS FILE"

505 , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"

530 , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"

506 , " if !fetchSubmodules && !private then builtins.fetchTarball {"

531 , " if !fetchSubmodules && !private then builtins.fetchTarball {"

@@ -511,24 +536,50 @@ gitHubStandaloneLoaderV4 = T.unlines

511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

536 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

512 ]

537 ]

513

538

514−plainGitStandaloneLoaders :: NonEmpty Text

539+legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec

515−plainGitStandaloneLoaders =

540+legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList

516− plainGitStandaloneLoaderV4 :|

541+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)

517− [ plainGitStandaloneLoaderV1

542+ , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)

518− , plainGitStandaloneLoaderV2

543+ , (attrCacheFileName, ThunkFileSpec_AttrCache)

519− , plainGitStandaloneLoaderV3

544+ , (".git", ThunkFileSpec_CheckoutIndicator)

520 ]

545 ]

521

546

522−plainGitStandaloneLoaderV1 :: Text

547+gitHubThunkSpecV5 :: ThunkSpec

523−plainGitStandaloneLoaderV1 = T.unlines

548+gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|

549+# DO NOT HAND-EDIT THIS FILE

550+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:

551+ if !fetchSubmodules && !private then builtins.fetchTarball {

552+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;

553+ } else (import <nixpkgs> {}).fetchFromGitHub {

554+ inherit owner repo rev sha256 fetchSubmodules private;

555+ };

556+ json = builtins.fromJSON (builtins.readFile ./github.json);

557+in if builtins.pathExists ./local then ./local else fetch json

558+|]

559+

560+parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr

561+parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->

562+ ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v

563+

564+gitThunkSpecs :: NonEmpty ThunkSpec

565+gitThunkSpecs =

566+ gitThunkSpecV5 :|

567+ [ gitThunkSpecV4

568+ , gitThunkSpecV3

569+ , gitThunkSpecV2

570+ , gitThunkSpecV1

571+ ]

572+

573+gitThunkSpecV1 :: ThunkSpec

574+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines

524 [ "# DO NOT HAND-EDIT THIS FILE"

575 [ "# DO NOT HAND-EDIT THIS FILE"

525 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"

576 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"

526 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"

577 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"

527 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

578 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

528 ]

579 ]

529

580

530−plainGitStandaloneLoaderV2 :: Text

581+gitThunkSpecV2 :: ThunkSpec

531−plainGitStandaloneLoaderV2 = T.unlines

582+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines

532 [ "# DO NOT HAND-EDIT THIS FILE"

583 [ "# DO NOT HAND-EDIT THIS FILE"

533 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"

584 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"

534 , " if builtins.hasAttr \"fetchGit\" builtins"

585 , " if builtins.hasAttr \"fetchGit\" builtins"

@@ -539,8 +590,8 @@ plainGitStandaloneLoaderV2 = T.unlines

539

590

540-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@

591-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@

541-- and will fail to find commits without this because it does shallow clones.

592-- and will fail to find commits without this because it does shallow clones.

542−plainGitStandaloneLoaderV3 :: Text

593+gitThunkSpecV3 :: ThunkSpec

543−plainGitStandaloneLoaderV3 = T.unlines

594+gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines

544 [ "# DO NOT HAND-EDIT THIS FILE"

595 [ "# DO NOT HAND-EDIT THIS FILE"

545 , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

596 , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

546 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

597 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

@@ -555,8 +606,8 @@ plainGitStandaloneLoaderV3 = T.unlines

555 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

606 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

556 ]

607 ]

557

608

558−plainGitStandaloneLoaderV4 :: Text

609+gitThunkSpecV4 :: ThunkSpec

559−plainGitStandaloneLoaderV4 = T.unlines

610+gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines

560 [ "# DO NOT HAND-EDIT THIS FILE"

611 [ "# DO NOT HAND-EDIT THIS FILE"

561 , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

612 , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

562 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

613 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

@@ -572,10 +623,52 @@ plainGitStandaloneLoaderV4 = T.unlines

572 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

623 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

573 ]

624 ]

574

625

575−thunkFileNames :: [FilePath]

626+legacyGitThunkSpec :: Text -> Text -> ThunkSpec

576−thunkFileNames = ["default.nix", "github.json", "git.json"]

627+legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList

628+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)

629+ , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)

630+ , (attrCacheFileName, ThunkFileSpec_AttrCache)

631+ , (".git", ThunkFileSpec_CheckoutIndicator)

632+ ]

577

633

578−--TODO: when checking something out, make a shallow clone

634+gitThunkSpecV5 :: ThunkSpec

635+gitThunkSpecV5 = mkThunkSpec "git-v5" "git.json" parseGitJsonBytes [here|

636+# DO NOT HAND-EDIT THIS FILE

637+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:

638+ let realUrl = let firstChar = builtins.substring 0 1 url; in

639+ if firstChar == "/" then /. + url

640+ else if firstChar == "." then ./. + url

641+ else url;

642+ in if !fetchSubmodules && private then builtins.fetchGit {

643+ url = realUrl; inherit rev;

644+ ${if branch == null then null else "ref"} = branch;

645+ } else (import <nixpkgs> {}).fetchgit {

646+ url = realUrl; inherit rev sha256;

647+ };

648+ json = builtins.fromJSON (builtins.readFile ./git.json);

649+in if builtins.pathExists ./local then ./local else fetch json

650+|]

651+

652+parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr

653+parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource

654+

655+mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec

656+mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList

657+ [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)

658+ , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)

659+ , (jsonFileName, ThunkFileSpec_Ptr parser)

660+ , (attrCacheFileName, ThunkFileSpec_AttrCache)

661+ , (unpackedDirName, ThunkFileSpec_CheckoutIndicator)

662+ ]

663+ where

664+ defaultNixViaSrc = [here|

665+# DO NOT HAND-EDIT THIS FILE

666+import (import ./thunk.nix)

667+|]

668+

669+

670+parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a

671+parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes

579

672

580-- | Checks a cache directory to see if there is a fresh symlink

673-- | Checks a cache directory to see if there is a fresh symlink

581-- to the result of building an attribute of a thunk.

674-- to the result of building an attribute of a thunk.

@@ -583,44 +676,49 @@ thunkFileNames = ["default.nix", "github.json", "git.json"]

583-- and the result is symlinked into the cache.

676-- and the result is symlinked into the cache.

584nixBuildThunkAttrWithCache

677nixBuildThunkAttrWithCache

585 :: MonadObelisk m

678 :: MonadObelisk m

679+ => ThunkSpec

586− => FilePath

680+ -> FilePath

587 -- ^ Path to directory containing Thunk

681 -- ^ Path to directory containing Thunk

588 -> String

682 -> String

589 -- ^ Attribute to build

683 -- ^ Attribute to build

590− -> m FilePath

684+ -> m (Maybe FilePath)

591 -- ^ Symlink to cached or built nix output

685 -- ^ Symlink to cached or built nix output

592-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'

686-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'

593-- the caching mechanism will fail as it merely measures the modification

687-- the caching mechanism will fail as it merely measures the modification

594-- time of the cache link and the expression to build.

688-- time of the cache link and the expression to build.

595−nixBuildThunkAttrWithCache thunkDir attr = do

689+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do

596− --NB: Expects thunkDir to be normalised with no trailing path separator.

597− --This should be guaranteed by the command argument parser.

598− let cacheErrHandler e

599− | isDoesNotExistError e = return Nothing -- expected from a cache miss

600− | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing

601− cacheDir = thunkDir </> attrCacheFileName

602− cachePath = cacheDir </> attr <.> "out"

603 latestChange <- liftIO $ do

690 latestChange <- liftIO $ do

604− createDirectoryIfMissing False cacheDir

691+ let

605− let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime

692+ getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime

693+ thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec

606− maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames

694+ maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames

695+

696+ let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $

697+ _thunkSpec_files thunkSpec

698+ for cachePaths' $ \cachePaths ->

699+ fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do

700+ let

701+ cachePath = cacheDir </> attr <.> "out"

702+ cacheErrHandler e

703+ | isDoesNotExistError e = pure Nothing -- expected from a cache miss

704+ | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)

607− cacheHit <- handle cacheErrHandler $ do

705+ cacheHit <- handle cacheErrHandler $ do

608− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath

706+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath

609− return $ if latestChange <= cacheTime

707+ pure $ if latestChange <= cacheTime

610− then Just cachePath

708+ then Just cachePath

611− else Nothing

709+ else Nothing

612− case cacheHit of

710+ case cacheHit of

613− Just c -> return c

711+ Just c -> pure c

614− Nothing -> do

712+ Nothing -> do

615− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

713+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

714+ liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)

616− _ <- nixCmd $ NixCmd_Build $ def

715+ (cachePath <$) $ nixCmd $ NixCmd_Build $ def

617− Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

716+ & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath

618− Lens.& nixCmdConfig_target Lens..~ Target

717+ & nixCmdConfig_target .~ Target

619− { _target_path = Just thunkDir

718+ { _target_path = Just thunkDir

620− , _target_attr = Just attr

719+ , _target_attr = Just attr

621− , _target_expr = Nothing

720+ , _target_expr = Nothing

622− }

721+ }

623− return cachePath

624

722

625-- | Build a nix attribute, and cache the result if possible

723-- | Build a nix attribute, and cache the result if possible

626nixBuildAttrWithCache

724nixBuildAttrWithCache

@@ -631,13 +729,15 @@ nixBuildAttrWithCache

631 -- ^ Attribute to build

729 -- ^ Attribute to build

632 -> m FilePath

730 -> m FilePath

633 -- ^ Symlink to cached or built nix output

731 -- ^ Symlink to cached or built nix output

634−nixBuildAttrWithCache exprPath attr = do

732+nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case

635− readThunk exprPath >>= \case

636− -- Only packed thunks are cached. in particular, checkouts are not

733+ -- Only packed thunks are cached. In particular, checkouts are not.

734+ Right (ThunkData_Packed spec _) ->

637− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr

735+ maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr

736+ _ -> build

737+ where

638− _ -> nixCmd $ NixCmd_Build $ def

738+ build = nixCmd $ NixCmd_Build $ def

639− Lens.& nixBuildConfig_outLink Lens..~ OutLink_None

739+ & nixBuildConfig_outLink .~ OutLink_None

640− Lens.& nixCmdConfig_target Lens..~ Target

740+ & nixCmdConfig_target .~ Target

641 { _target_path = Just exprPath

741 { _target_path = Just exprPath

642 , _target_attr = Just attr

742 , _target_attr = Just attr

643 , _target_expr = Nothing

743 , _target_expr = Nothing

@@ -658,7 +758,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

658 where

758 where

659 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case

759 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case

660 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)

760 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)

661− Right (ThunkData_Packed _) -> do

761+ Right ThunkData_Packed{} -> do

662 let tmpThunk = tmpDir </> "thunk"

762 let tmpThunk = tmpDir </> "thunk"

663 callProcessAndLogOutput (Notice, Error) $

763 callProcessAndLogOutput (Notice, Error) $

664 proc cp ["-r", "-T", thunkDir, tmpThunk]

764 proc cp ["-r", "-T", thunkDir, tmpThunk]

@@ -676,58 +776,64 @@ unpackThunk :: MonadObelisk m => FilePath -> m ()

676unpackThunk = unpackThunk' False

776unpackThunk = unpackThunk' False

677

777

678-- | Check that we are not somewhere inside the thunk directory

778-- | Check that we are not somewhere inside the thunk directory

679−checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()

779+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()

680−checkThunkDirectory msg thunkDir = do

780+checkThunkDirectory thunkDir = do

681 currentDir <- liftIO getCurrentDirectory

781 currentDir <- liftIO getCurrentDirectory

682 thunkDir' <- liftIO $ canonicalizePath thunkDir

782 thunkDir' <- liftIO $ canonicalizePath thunkDir

683− when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg

783+ when (thunkDir' `L.isInfixOf` currentDir) $

784+ failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]

785+

786+ -- Don't let thunk commands work when directly given an unpacked repo

787+ when (takeFileName thunkDir == unpackedDirName) $

788+ readThunk (takeDirectory thunkDir) >>= \case

789+ Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]

790+ Left _ -> pure ()

684

791

685unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()

792unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()

686−unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case

793+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case

687− Left err -> failWith $ "thunk unpack: " <> T.pack (show err)

794+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]

688 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty

795 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty

689− Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"

796+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]

690− Right (ThunkData_Packed tptr) -> do

797+ Right (ThunkData_Packed _ tptr) -> do

691 let (thunkParent, thunkName) = splitFileName thunkDir

798 let (thunkParent, thunkName) = splitFileName thunkDir

692− withTempDirectory thunkParent thunkName $ \tmpRepo -> do

799+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do

693− let obGitDir = tmpRepo </> ".git" </> "obelisk"

800+ let

694− s = case _thunkPtr_source tptr of

801+ (gitSrc, newSpec) = case _thunkPtr_source tptr of

695− ThunkSource_GitHub s' -> forgetGithub False s'

802+ ThunkSource_GitHub s' -> (forgetGithub False s', NonEmpty.head gitHubThunkSpecs)

696− ThunkSource_Git s' -> s'

803+ ThunkSource_Git s' -> (s', NonEmpty.head gitThunkSpecs)

697 withSpinner' ("Fetching thunk " <> T.pack thunkName)

804 withSpinner' ("Fetching thunk " <> T.pack thunkName)

698 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do

805 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do

699− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo

806+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc (tmpThunk </> unpackedDirName)

700 git $ [ "clone" ]

807 git $ [ "clone" ]

701− ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))

808+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]

702− ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]

809+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]

703− ++ do branch <- maybeToList $ _gitSource_branch s

810+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc

704 [ "--branch", T.unpack $ untagName branch ]

811 [ "--branch", T.unpack $ untagName branch ]

705 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

812 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

706− when (_gitSource_fetchSubmodules s) $

813+ when (_gitSource_fetchSubmodules gitSrc) $

707 git ["submodule", "update", "--recursive", "--init"]

814 git ["submodule", "update", "--recursive", "--init"]

708

815

709− liftIO $ createDirectory obGitDir

816+ createThunk tmpThunk $ Left newSpec

710− callProcessAndLogOutput (Notice, Error) $

817+

711− proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]

818+ liftIO $ do

712− callProcessAndLogOutput (Notice, Error) $

819+ removePathForcibly thunkDir

713− proc "rm" ["-r", thunkDir]

820+ renameDirectory tmpThunk thunkDir

714− callProcessAndLogOutput (Notice, Error) $

821+

715− proc "mv" ["-T", tmpRepo, thunkDir]

716

822

717--TODO: add a rollback mode to pack to the original thunk

823--TODO: add a rollback mode to pack to the original thunk

718packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr

824packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr

719packThunk = packThunk' False

825packThunk = packThunk' False

720

826

721packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr

827packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr

722−packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case

828+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case

723− Left err -> failWith $ T.pack $ "thunk pack: " <> show err

724− Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

829+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]

725− Right (ThunkData_Checkout _) -> do

830+ _ -> withSpinner'

726− withSpinner' ("Packing thunk " <> T.pack thunkDir)

831+ ("Packing thunk " <> T.pack thunkDir)

727− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do

832+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $

833+ do

728 thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)

834 thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)

729− callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]

835+ callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-rf", thunkDir] -- thunkDir may be a symlink

730− liftIO $ createThunk thunkDir thunkPtr

836+ createThunk thunkDir $ Right thunkPtr

731 pure thunkPtr

837 pure thunkPtr

732

838

733modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr

839modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr

@@ -739,28 +845,29 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of

739 }

845 }

740

846

741getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr

847getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr

742−getThunkPtr checkClean thunkDir mPrivate = do

848+getThunkPtr checkClean dir mPrivate = do

849+ let repoLocations = [(".git", "."), (unpackedDirName, unpackedDirName)]

850+ repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst

851+ thunkDir <- case repoLocation' of

852+ Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]

853+ Just (_, path) -> pure $ normalise $ dir </> path

854+

743 when checkClean $ ensureCleanGitRepo thunkDir True

855 when checkClean $ ensureCleanGitRepo thunkDir True

744 "thunk pack: thunk checkout contains unsaved modifications"

856 "thunk pack: thunk checkout contains unsaved modifications"

745

857

746 -- Check whether there are any stashes

858 -- Check whether there are any stashes

859+ when checkClean $ do

747− stashOutput <- readGitProcess thunkDir ["stash", "list"]

860+ stashOutput <- readGitProcess thunkDir ["stash", "list"]

748− when checkClean $ case T.null stashOutput of

861+ unless (T.null stashOutput) $

749− False -> do

750 failWith $ T.unlines $

862 failWith $ T.unlines $

751 [ "thunk pack: thunk checkout has stashes"

863 [ "thunk pack: thunk checkout has stashes"

752 , "git stash list:"

864 , "git stash list:"

753 ] ++ T.lines stashOutput

865 ] ++ T.lines stashOutput

754− True -> return ()

755

866

756 -- Get current branch

867 -- Get current branch

757 (mCurrentBranch, mCurrentCommit) <- do

868 (mCurrentBranch, mCurrentCommit) <- do

758− b <- listToMaybe

759− <$> T.lines

760− <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]

869+ b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]

761− c <- listToMaybe

762− <$> T.lines

763− <$> readGitProcess thunkDir ["rev-parse", "HEAD"]

870+ c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]

764 case b of

871 case b of

765 (Just "HEAD") -> failWith $ T.unlines

872 (Just "HEAD") -> failWith $ T.unlines

766 [ "thunk pack: You are in 'detached HEAD' state."

873 [ "thunk pack: You are in 'detached HEAD' state."

@@ -771,7 +878,7 @@ getThunkPtr checkClean thunkDir mPrivate = do

771

878

772 -- Get information on all branches and their (optional) designated upstream

879 -- Get information on all branches and their (optional) designated upstream

773 -- correspondents

880 -- correspondents

774− (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir

881+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir

775 [ "for-each-ref"

882 [ "for-each-ref"

776 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"

883 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"

777 , "refs/heads/"

884 , "refs/heads/"

@@ -817,7 +924,7 @@ getThunkPtr checkClean thunkDir mPrivate = do

817 ]

924 ]

818

925

819 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes

926 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes

820− stats <- iforM headUpstream $ \branch (upstream, _remote) -> do

927+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do

821 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir

928 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir

822 [ "rev-list", "--left-right"

929 [ "rev-list", "--left-right"

823 , T.unpack branch <> "..." <> T.unpack upstream

930 , T.unpack branch <> "..." <> T.unpack upstream

@@ -841,8 +948,9 @@ getThunkPtr checkClean thunkDir mPrivate = do

841 \pushed but this repo's remote tracking branches don't know it.)"

948 \pushed but this repo's remote tracking branches don't know it.)"

842 ]

949 ]

843

950

951+ when checkClean $ do

844− -- We assume it's safe to pack the thunk at this point

952+ -- We assume it's safe to pack the thunk at this point

845− putLog Informational "All changes safe in git remotes. OK to pack thunk."

953+ putLog Informational "All changes safe in git remotes. OK to pack thunk."

846

954

847 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

955 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

848

956

lib/command/src/Obelisk/Command/Utils.hs+17−2

@@ -10,19 +10,20 @@ module Obelisk.Command.Utils where

10import Control.Applicative hiding (many)

11import Control.Monad.Except

12import Data.Bool (bool)

13−import qualified Text.Megaparsec.Char.Lexer as ML

14import Data.Bifunctor

13import Data.Bifunctor

15import Data.Char

14import Data.Char

16import Data.Either

15import Data.Either

17−import Data.Semigroup ((<>))

16+import Data.List (isInfixOf)

18import Data.Map (Map)

17import Data.Map (Map)

19import qualified Data.Map as M

18import qualified Data.Map as M

20import Data.Maybe (maybeToList)

19import Data.Maybe (maybeToList)

20+import Data.Semigroup ((<>))

21import Data.Text (Text)

22import qualified Data.Text as T

23import Data.Void (Void)

24import System.Exit (ExitCode)

25import System.Which (staticWhich)

26+import qualified Text.Megaparsec.Char.Lexer as ML

26import Text.Megaparsec as MP

27import Text.Megaparsec as MP

27import Text.Megaparsec.Char as MP

28import Text.Megaparsec.Char as MP

@@ -32,6 +33,12 @@ import Obelisk.CliApp

32cp :: FilePath

33cp :: FilePath

33cp = $(staticWhich "cp")

34cp = $(staticWhich "cp")

36+mvPath :: FilePath

37+mvPath = $(staticWhich "mv")

38+

39+rmPath :: FilePath

40+rmPath = $(staticWhich "rm")

41+

35ghcidExePath :: FilePath

42ghcidExePath :: FilePath

36ghcidExePath = $(staticWhich "ghcid")

43ghcidExePath = $(staticWhich "ghcid")

@@ -47,6 +54,14 @@ nixBuildExePath = $(staticWhich "nix-build")

47jreKeyToolPath :: FilePath

54jreKeyToolPath :: FilePath

48jreKeyToolPath = $(staticWhich "keytool")

55jreKeyToolPath = $(staticWhich "keytool")

57+-- | Nix syntax requires relative paths to be prefixed by @./@ or

58+-- @../@. This will make a 'FilePath' that can be embedded in a Nix

59+-- expression.

60+toNixPath :: FilePath -> FilePath

61+toNixPath root | "/" `isInfixOf` root = root

62+ | otherwise = "./" <> root

63+

64+

50-- Check whether the working directory is clean

65-- Check whether the working directory is clean

51checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool

66checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool

52checkGitCleanStatus repo withIgnored = do

67checkGitCleanStatus repo withIgnored = do

lib/command/src/Obelisk/Command/VmBuilder.hs+2−1

@@ -21,6 +21,7 @@ import qualified System.Info

22import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

23import Obelisk.CliApp

24+import Obelisk.Command.Utils (rmPath)

25-- | Generate the `--builders` argument string to enable the VM builder after ensuring it is available.

26-- | Generate the `--builders` argument string to enable the VM builder after ensuring it is available.

26getNixBuildersArg :: MonadObelisk m => m String

27getNixBuildersArg :: MonadObelisk m => m String

@@ -95,7 +96,7 @@ setupNixDocker stateDir = withSpinner ("Creating Docker container named " <> con

96 -- Create new SSH keys for this container

97 -- Create new SSH keys for this container

97 callProcessAndLogOutput (Debug, Error) $

98 callProcessAndLogOutput (Debug, Error) $

98− proc "rm" ["-f", stateDir </> sshKeyFileName, stateDir </> sshKeyFileName <.> "pub"]

99+ proc rmPath ["-f", stateDir </> sshKeyFileName, stateDir </> sshKeyFileName <.> "pub"]

99 callProcessAndLogOutput (Debug, Error) $

100 callProcessAndLogOutput (Debug, Error) $

100 proc "ssh-keygen" ["-t", "ed25519", "-f", stateDir </> sshKeyFileName, "-P", ""]

101 proc "ssh-keygen" ["-t", "ed25519", "-f", stateDir </> sshKeyFileName, "-P", ""]

101

102

lib/selftest/obelisk-selftest.cabal+2

@@ -9,6 +9,8 @@ library

9 hs-source-dirs: src

10 build-depends:

11 base

12+ , bytestring

13+ , aeson

12 , containers

14 , containers

13 , directory

15 , directory

14 , filepath

16 , filepath

lib/selftest/src/Obelisk/SelfTest.hs+171−26

@@ -4,7 +4,7 @@

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE PatternGuards #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TemplateHaskell #-}

7+{-# LANGUAGE TemplateHaskell #-}

8{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE ViewPatterns #-}

10module Obelisk.SelfTest where

@@ -13,13 +13,19 @@ import Control.Concurrent (threadDelay)

13import Control.Exception (bracket, throw, try)

14import Control.Monad

15import Control.Monad.IO.Class

16+import qualified Data.Aeson as Aeson

17+import qualified Data.Aeson.Types as Aeson

16import Data.Bool (bool)

18import Data.Bool (bool)

19+import qualified Data.ByteString.Lazy as LBS

20+import Data.Foldable (for_)

17import Data.Function (fix)

21import Data.Function (fix)

22+import qualified Data.Map as Map

18import Data.Semigroup ((<>))

23import Data.Semigroup ((<>))

19import qualified Data.Set as Set

24import qualified Data.Set as Set

20import Data.String

25import Data.String

21import Data.Text (Text)

26import Data.Text (Text)

22import qualified Data.Text as T

27import qualified Data.Text as T

28+import qualified Data.Text.Encoding as T

23import qualified Data.Text.IO as T

29import qualified Data.Text.IO as T

24import qualified Network.HTTP.Client as HTTP

30import qualified Network.HTTP.Client as HTTP

25import qualified Network.HTTP.Types as HTTP

31import qualified Network.HTTP.Types as HTTP

@@ -64,9 +70,15 @@ chmodPath = $(staticWhich "chmod")

64whoamiPath :: FilePath

70whoamiPath :: FilePath

65whoamiPath = $(staticWhich "whoami")

71whoamiPath = $(staticWhich "whoami")

73+nixInstantiatePath :: FilePath

74+nixInstantiatePath = $(staticWhich "nix-instantiate")

75+

67nixBuildPath :: FilePath

76nixBuildPath :: FilePath

68nixBuildPath = $(staticWhich "nix-build")

77nixBuildPath = $(staticWhich "nix-build")

79+nixPrefetchGitPath :: FilePath

80+nixPrefetchGitPath = $(staticWhich "nix-prefetch-git")

81+

70lnPath :: FilePath

82lnPath :: FilePath

71lnPath = $(staticWhich "ln")

83lnPath = $(staticWhich "ln")

@@ -103,6 +115,17 @@ ob = "ob"

103augmentWithVerbosity :: (String -> [Text] -> a) -> String -> Bool -> [Text] -> a

115augmentWithVerbosity :: (String -> [Text] -> a) -> String -> Bool -> [Text] -> a

104augmentWithVerbosity runner executable isVerbose args = runner executable $ (if isVerbose then ("-v" :) else id) args

116augmentWithVerbosity runner executable isVerbose args = runner executable $ (if isVerbose then ("-v" :) else id) args

105

117

118+isolatedGitShell :: Bool -> FilePath -> (([Text] -> Sh Text) -> Sh a) -> IO a

119+isolatedGitShell isVerbose dir f = shelly $ bool silently verbosely isVerbose $ do

120+ setenv "HOME" "/dev/null"

121+ setenv "GIT_CONFIG_NOSYSTEM" "1"

122+ _ <- git ["init"]

123+ _ <- git ["config", "user.name", "SelfTest"]

124+ _ <- git ["config", "user.email", "self@test"]

125+ f git

126+ where

127+ git args = run gitPath $ ["-C", toTextIgnore dir] <> args

128+

106-- | Copies a git repo to a new location and "resets" the git history to include

129-- | Copies a git repo to a new location and "resets" the git history to include

107-- exactly one commit with all files added. It then restricts writing and reading

130-- exactly one commit with all files added. It then restricts writing and reading

108-- for group and user to make the repo ideal for being a valid git remote for thunks.

131-- for group and user to make the repo ideal for being a valid git remote for thunks.

@@ -110,21 +133,14 @@ augmentWithVerbosity runner executable isVerbose args = runner executable $ (if

110-- Using this allows dirty repos to be used as git remotes during the test since 'git clone'ing

133-- Using this allows dirty repos to be used as git remotes during the test since 'git clone'ing

111-- a dirty repo will not include the uncommitted changes.

134-- a dirty repo will not include the uncommitted changes.

112copyForGitRemote :: Bool -> FilePath -> FilePath -> IO ()

135copyForGitRemote :: Bool -> FilePath -> FilePath -> IO ()

113−copyForGitRemote isVerbose origDir copyDir = shelly $ bool silently verbosely isVerbose $ do

136+copyForGitRemote isVerbose origDir copyDir = isolatedGitShell isVerbose copyDir $ \git -> do

114− setenv "HOME" "/dev/null"

115− setenv "GIT_CONFIG_NOSYSTEM" "1"

116 run_ rsyncPath

137 run_ rsyncPath

117 [ "-r", "--no-perms", "--no-owner", "--no-group", "--exclude", ".git"

138 [ "-r", "--no-perms", "--no-owner", "--no-group", "--exclude", ".git"

118 , toTextIgnore (addTrailingPathSeparator origDir), toTextIgnore copyDir

139 , toTextIgnore (addTrailingPathSeparator origDir), toTextIgnore copyDir

119 ]

140 ]

120− git ["init"]

121− git ["config", "user.name", "SelfTest"]

122− git ["config", "user.email", "self@test"]

123− git ["add", "--all"]

141+ _ <- git ["add", "--all"]

124− git ["commit", "-m", "Copy repo"]

142+ _ <- git ["commit", "-m", "Copy repo"]

125 run_ chmodPath ["-R", "u-w,g-rw,o-rw", toTextIgnore copyDir] -- Freeze this state

143 run_ chmodPath ["-R", "u-w,g-rw,o-rw", toTextIgnore copyDir] -- Freeze this state

126− where

127− git args = run_ gitPath $ ["-C", toTextIgnore copyDir] <> args

128

144

129main :: IO ()

145main :: IO ()

130main = do

146main = do

@@ -241,7 +257,7 @@ main' isVerbose httpManager obeliskRepoReadOnly = withInitCache $ \initCache ->

241 run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]

257 run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]

242 runOb_ ["thunk", "pack", toTextIgnore dir]

258 runOb_ ["thunk", "pack", toTextIgnore dir]

243 runOb_ ["thunk", "unpack", toTextIgnore dir]

259 runOb_ ["thunk", "unpack", toTextIgnore dir]

244− branch' <- chdir dir $ run gitPath ["rev-parse", "--abbrev-ref", "HEAD"]

260+ branch' <- run gitPath ["-C", toTextIgnore $ dir </> unpackedDirName, "rev-parse", "--abbrev-ref", "HEAD"]

245 liftIO $ assertEqual "" branch (T.strip branch')

261 liftIO $ assertEqual "" branch (T.strip branch')

246

262

247 it "can pack and unpack plain git repos" $

263 it "can pack and unpack plain git repos" $

@@ -253,10 +269,10 @@ main' isVerbose httpManager obeliskRepoReadOnly = withInitCache $ \initCache ->

253 runOb_ ["thunk", "pack", repo]

269 runOb_ ["thunk", "pack", repo]

254 packedFiles <- Set.fromList <$> ls (fromText repo)

270 packedFiles <- Set.fromList <$> ls (fromText repo)

255 liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>

271 liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>

256− ["default.nix", "github.json", ".attr-cache" :: FilePath]

272+ ["default.nix", "thunk.nix", "github.json" :: FilePath]

257

273

258 runOb_ ["thunk", "unpack", repo]

274 runOb_ ["thunk", "unpack", repo]

259− chdir (fromText repo) $ do

275+ chdir (fromText repo </> unpackedDirName) $ do

260 unpackHash <- revParseHead

276 unpackHash <- revParseHead

261 assertRevEQ origHash unpackHash

277 assertRevEQ origHash unpackHash

262

278

@@ -265,6 +281,8 @@ main' isVerbose httpManager obeliskRepoReadOnly = withInitCache $ \initCache ->

265 it "aborts thunk pack when there are uncommitted files" $ inTmpObInitWithImplCopy $ \dir -> do

281 it "aborts thunk pack when there are uncommitted files" $ inTmpObInitWithImplCopy $ \dir -> do

266 testThunkPack' (dir </> thunk)

282 testThunkPack' (dir </> thunk)

267

283

284+ it "works on legacy git thunks" $ testLegacyGitThunks isVerbose

285+

268 describe "ob thunk update --branch" $ parallel $ do

286 describe "ob thunk update --branch" $ parallel $ do

269 it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do

287 it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do

270 let branch1 = "master"

288 let branch1 = "master"

@@ -309,10 +327,11 @@ main' isVerbose httpManager obeliskRepoReadOnly = withInitCache $ \initCache ->

309

327

310 withObeliskImplClean f =

328 withObeliskImplClean f =

311 withSystemTempDirectory "obelisk-impl-clean" $ \obeliskImpl -> do

329 withSystemTempDirectory "obelisk-impl-clean" $ \obeliskImpl -> do

312− void . shellyOb verbosity $ chdir obeliskImpl $ do

330+ void . shellyOb verbosity $ do

313 dirtyFiles <- T.strip <$> run gitPath ["-C", toTextIgnore obeliskRepoReadOnly, "diff", "--stat"]

331 dirtyFiles <- T.strip <$> run gitPath ["-C", toTextIgnore obeliskRepoReadOnly, "diff", "--stat"]

314 () <- when (dirtyFiles /= "") $ error "SelfTest does not work correctly with dirty obelisk repos as remote"

332 () <- when (dirtyFiles /= "") $ error "SelfTest does not work correctly with dirty obelisk repos as remote"

315 run_ gitPath ["clone", "file://" <> toTextIgnore obeliskRepoReadOnly, toTextIgnore obeliskImpl]

333 run_ gitPath ["clone", "file://" <> toTextIgnore obeliskRepoReadOnly, toTextIgnore obeliskImpl]

334+ runOb_ ["thunk", "init", toTextIgnore obeliskImpl]

316 f obeliskImpl

335 f obeliskImpl

317

336

318 withInitCache f =

337 withInitCache f =

@@ -374,28 +393,31 @@ testObRunInDir executable extraArgs mdir httpManager = maskExitSuccess $ do

374 else exit 0

393 else exit 0

375

394

376testThunkPack :: String -> [Text] -> FilePath -> Sh ()

395testThunkPack :: String -> [Text] -> FilePath -> Sh ()

377−testThunkPack executable args path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do

396+testThunkPack executable args path' = withTempFile repoDir "test-file" $ \file handle -> do

397+ let

378− let pack' = readProcessWithExitCode executable (T.unpack <$> ["thunk", "pack", toTextIgnore path'] ++ args) ""

398+ pack' = readProcessWithExitCode executable (["thunk", "pack", path'] ++ map T.unpack args) ""

379− ensureThunkPackFails q = liftIO $ pack' >>= \case

399+ ensureThunkPackFails q = liftIO $ pack' >>= \case

380− (code, out, err)

400+ (code, out, err)

381− | code == ExitSuccess -> fail $ "ob thunk pack succeeded when it should have failed with error '" <> show q <> "'"

401+ | code == ExitSuccess -> fail $ "ob thunk pack succeeded when it should have failed with error '" <> show q <> "'"

382− | q `T.isInfixOf` T.pack (out <> err) -> pure ()

402+ | q `T.isInfixOf` T.pack (out <> err) -> pure ()

383− | otherwise -> fail $ "ob thunk pack failed for an unexpected reason, expecting '" <> show q <> "', received: " <> show out <> "\nstderr: " <> err

403+ | otherwise -> fail $ "ob thunk pack failed for an unexpected reason, expecting '" <> show q <> "', received: " <> show out <> "\nstderr: " <> err

384− git = chdir path' . run gitPath

404+ git = chdir repoDir . run_ gitPath

385 -- Untracked files

405 -- Untracked files

386 ensureThunkPackFails "Untracked files"

406 ensureThunkPackFails "Untracked files"

387− void $ git ["add", T.pack file]

407+ git ["add", T.pack file]

388 -- Uncommitted files (staged)

408 -- Uncommitted files (staged)

389 ensureThunkPackFails "unsaved"

409 ensureThunkPackFails "unsaved"

390− chdir path' $ commit "test commit"

410+ chdir repoDir $ commit "test commit"

391 -- Non-pushed commits in any branch

411 -- Non-pushed commits in any branch

392 ensureThunkPackFails "not yet pushed"

412 ensureThunkPackFails "not yet pushed"

393 -- Uncommitted files (unstaged)

413 -- Uncommitted files (unstaged)

394 liftIO $ T.hPutStrLn handle "test file" >> hClose handle

414 liftIO $ T.hPutStrLn handle "test file" >> hClose handle

395 ensureThunkPackFails "modified"

415 ensureThunkPackFails "modified"

396 -- Existing stashes

416 -- Existing stashes

397− void $ git $ gitUserConfig <> [ "stash" ]

417+ git $ gitUserConfig <> [ "stash" ]

398 ensureThunkPackFails "has stashes"

418 ensureThunkPackFails "has stashes"

419+ where

420+ repoDir = path' </> unpackedDirName

399

421

400-- | Blocks until a non-empty line is available

422-- | Blocks until a non-empty line is available

401hGetLineSkipBlanks :: MonadIO m => Handle -> m Text

423hGetLineSkipBlanks :: MonadIO m => Handle -> m Text

@@ -456,3 +478,126 @@ getFreePorts n = Socket.withSocketsDo $ do

456 sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)

478 sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)

457 Socket.bind sock (Socket.addrAddress addr)

479 Socket.bind sock (Socket.addrAddress addr)

458 pure sock

480 pure sock

481+

482+testLegacyGitThunks :: Bool -> IO ()

483+testLegacyGitThunks isVerbose = withSystemTempDirectory "test-git-repo" $ \gitDir -> do

484+ isolatedGitShell isVerbose gitDir $ \git -> do

485+ writefile (gitDir </> ("default.nix" :: FilePath)) "{}: \"hello\""

486+ _ <- git ["add", "--all"]

487+ _ <- git ["commit", "-m", "Initial commit"]

488+ rev <- T.strip <$> git ["rev-parse", "HEAD"]

489+ sha256 :: Text

490+ <- either error pure

491+ =<< (Aeson.parseEither (Aeson..: "sha256") <=< Aeson.eitherDecodeStrict . T.encodeUtf8)

492+ <$> run nixPrefetchGitPath [toTextIgnore gitDir]

493+

494+ for_ (legacyGitThunks (GitThunkParams gitDir rev sha256)) $ \mkFiles ->

495+ withSystemTempDirectory "test-thunks" $ \thunkDir -> do

496+ let nixEval = run nixInstantiatePath ["--eval", toTextIgnore (thunkDir </> ("thunk.nix" :: FilePath))]

497+ liftIO $ mkFiles thunkDir

498+ run_ "ob" ["thunk", "unpack", toTextIgnore thunkDir]

499+ unpackedEval <- nixEval

500+ run_ "ob" ["thunk", "pack", toTextIgnore thunkDir]

501+ packedEval <- nixEval

502+ liftIO $ assertBool "Unpacked and packed thunk.nix should not eval to the same thing" $

503+ unpackedEval /= packedEval

504+

505+data GitThunkParams = GitThunkParams

506+ { _gitThunkParams_repo :: !FilePath

507+ , _gitThunkParams_rev :: !Text

508+ , _gitThunkParams_sha256 :: !Text

509+ } deriving Show

510+

511+legacyGitThunks :: GitThunkParams -> [FilePath -> IO ()]

512+legacyGitThunks (GitThunkParams repo' rev sha256) =

513+ [ mkLegacyIO

514+ (T.unlines

515+ [ "# DO NOT HAND-EDIT THIS FILE"

516+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"

517+ , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"

518+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

519+ ]

520+ )

521+ (Map.fromList

522+ [ ("url", repo)

523+ , ("rev", rev)

524+ , ("branch", "master")

525+ , ("sha256", sha256)

526+ ]

527+ )

528+ , mkLegacyIO

529+ (T.unlines

530+ [ "# DO NOT HAND-EDIT THIS FILE"

531+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"

532+ , " if builtins.hasAttr \"fetchGit\" builtins"

533+ , " then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"

534+ , " else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"

535+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

536+ ]

537+ )

538+ (Map.fromList

539+ [ ("url", repo)

540+ , ("rev", rev)

541+ , ("branch", "master")

542+ , ("sha256", sha256)

543+ ]

544+ )

545+ , mkLegacyIO

546+ (T.unlines

547+ [ "# DO NOT HAND-EDIT THIS FILE"

548+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

549+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

550+ , " if firstChar == \"/\" then /. + url"

551+ , " else if firstChar == \".\" then ./. + url"

552+ , " else url;"

553+ , " in if !fetchSubmodules && private then builtins.fetchGit {"

554+ , " url = realUrl; inherit rev;"

555+ , " } else (import <nixpkgs> {}).fetchgit {"

556+ , " url = realUrl; inherit rev sha256;"

557+ , " };"

558+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

559+ ]

560+ )

561+ (Map.fromList

562+ [ ("url", Aeson.String repo)

563+ , ("rev", Aeson.String rev)

564+ , ("branch", Aeson.String "master")

565+ , ("sha256", Aeson.String sha256)

566+ , ("private", Aeson.Bool False)

567+ ]

568+ )

569+ , mkLegacyIO

570+ (T.unlines

571+ [ "# DO NOT HAND-EDIT THIS FILE"

572+ , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

573+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

574+ , " if firstChar == \"/\" then /. + url"

575+ , " else if firstChar == \".\" then ./. + url"

576+ , " else url;"

577+ , " in if !fetchSubmodules && private then builtins.fetchGit {"

578+ , " url = realUrl; inherit rev;"

579+ , " ${if branch == null then null else \"ref\"} = branch;"

580+ , " } else (import <nixpkgs> {}).fetchgit {"

581+ , " url = realUrl; inherit rev sha256;"

582+ , " };"

583+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

584+ ]

585+ )

586+ (Map.fromList

587+ [ ("url", Aeson.String repo)

588+ , ("rev", Aeson.String rev)

589+ , ("branch", Aeson.String "master")

590+ , ("sha256", Aeson.String sha256)

591+ , ("private", Aeson.Bool False)

592+ ]

593+ )

594+ ]

595+ where

596+ repo = T.pack repo'

597+ mkLegacyIO :: Aeson.ToJSON v => Text -> Map.Map Text v -> FilePath -> IO ()

598+ mkLegacyIO defaultNix gitJson dir = do

599+ T.writeFile (dir </> ("default.nix" :: FilePath)) defaultNix

600+ LBS.writeFile (dir </> ("git.json" :: FilePath)) (Aeson.encode gitJson)

601+

602+unpackedDirName :: FilePath

603+unpackedDirName = "local"