d8e4d7a · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge pull request #247 from obsidiansystems/ls-remote

d8e4d7aLuigy Leon8 years ago

lib/cliapp/src/Obelisk/CliApp.hs+1

compare with master

unifiedsplit

@@ -41,6 +41,7 @@ module Obelisk.CliApp

41 , createProcess_

42 , callProcess

43 , callCommand

44+ , reconstructCommand

44 ) where

45 ) where

46import Control.Monad.Log (Severity (..))

47import Control.Monad.Log (Severity (..))

lib/cliapp/src/Obelisk/CliApp/Process.hs+2−1

@@ -18,6 +18,7 @@ module Obelisk.CliApp.Process

18 , createProcess_

19 , callProcess

20 , callCommand

21+ , reconstructCommand

21 ) where

22 ) where

23import Control.Monad ((<=<), join, void)

24import Control.Monad ((<=<), join, void)

@@ -31,7 +32,6 @@ import Data.Monoid ((<>))

31import Data.Text (Text)

32import Data.Text (Text)

32import qualified Data.Text as T

33import qualified Data.Text as T

33import qualified Data.Text.Encoding as T

34import qualified Data.Text.Encoding as T

34−--import qualified Data.Text.IO as T

35import System.Exit (ExitCode (..))

36import System.IO (Handle)

37import System.IO.Streams (InputStream, handleToInputStream)

@@ -167,6 +167,7 @@ streamToLog stream = fix $ \loop -> do

167 Nothing -> return ()

168 Just (sev, line) -> putLogRaw sev (T.decodeUtf8 line) >> loop

169

170+-- | Pretty print a 'CmdSpec'

170reconstructCommand :: Process.CmdSpec -> Text

171reconstructCommand :: Process.CmdSpec -> Text

171reconstructCommand (Process.ShellCommand str) = T.pack str

172reconstructCommand (Process.ShellCommand str) = T.pack str

172reconstructCommand (Process.RawCommand c as) = processToShellString c as

173reconstructCommand (Process.RawCommand c as) = processToShellString c as

lib/command/obelisk-command.cabal+1

@@ -31,6 +31,7 @@ library

31 , modern-uri

32 , monad-loops

33 , mtl

34+ , megaparsec

34 , network

35 , network

35 , network-uri

36 , network-uri

36 , optparse-applicative

37 , optparse-applicative

lib/command/src/Obelisk/Command.hs+5−22

@@ -171,7 +171,6 @@ deployInitOpts = DeployInitOpts

171 <*> strOption (long "route" <> metavar "PUBLICROUTE" <> help "Publicly accessible URL of your app")

172 <*> strOption (long "admin-email" <> metavar "ADMINEMAIL" <> help "Email address where administrative alerts will be sent")

173 <*> flag True False (long "disable-https" <> help "Disable automatic https configuration for the backend")

174− <*> strOption (long "upstream" <> value "origin" <> metavar "REMOTE" <> help "git remote to use for the src thunk" <> showDefault)

175

174

176type TeamID = String

175type TeamID = String

177data PlatformDeployment = Android | IOS TeamID

176data PlatformDeployment = Android | IOS TeamID

@@ -194,7 +193,6 @@ data DeployInitOpts = DeployInitOpts

194 , _deployInitOpts_route :: String

193 , _deployInitOpts_route :: String

195 , _deployInitOpts_adminEmail :: String

194 , _deployInitOpts_adminEmail :: String

196 , _deployInitOpts_enableHttps :: Bool

195 , _deployInitOpts_enableHttps :: Bool

197− , _deployInitOpts_remote :: String

198 }

196 }

199 deriving Show

197 deriving Show

200

198

@@ -212,32 +210,17 @@ thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgumen

212 , help "Path to directory containing thunk data"

210 , help "Path to directory containing thunk data"

213 ]

211 ]

214

212

215−data ThunkPackOpts = ThunkPackOpts

216− { _thunkPackOpts_directory :: FilePath

217− , _thunkPackOpts_upstream :: String

218− }

219− deriving Show

220−

221data ThunkCommand

213data ThunkCommand

222 = ThunkCommand_Update [FilePath]

214 = ThunkCommand_Update [FilePath]

223 | ThunkCommand_Unpack [FilePath]

215 | ThunkCommand_Unpack [FilePath]

224− | ThunkCommand_Pack [ThunkPackOpts]

216+ | ThunkCommand_Pack [FilePath]

225 deriving Show

217 deriving Show

226

218

227−thunkPackOpts :: Parser ThunkPackOpts

228−thunkPackOpts = (ThunkPackOpts <$> thunkDirectoryParser <*>) . strOption $ mconcat

229− [ long "upstream"

230− , value "origin"

231− , metavar "REMOTE"

232− , help "Git remote that packed thunk will point to"

233− , showDefault

234− ]

235−

236thunkCommand :: Parser ThunkCommand

219thunkCommand :: Parser ThunkCommand

237thunkCommand = hsubparser $ mconcat

220thunkCommand = hsubparser $ mconcat

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

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

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

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

240− , command "pack" $ info (ThunkCommand_Pack <$> some thunkPackOpts) $ progDesc "Pack git checkout into thunk that points at given upstream"

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

241 ]

224 ]

242

225

243parserPrefs :: ParserPrefs

226parserPrefs :: ParserPrefs

@@ -265,7 +248,7 @@ mkObeliskConfig = do

265-- liftIO $ exitWith $ ExitFailure 2

248-- liftIO $ exitWith $ ExitFailure 2

266 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

249 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

267 ObeliskError_ProcessError (ProcessFailure p code) ann ->

250 ObeliskError_ProcessError (ProcessFailure p code) ann ->

268− ( "Process exited with code " <> T.pack (show code) <> "; " <> T.pack (show p)

251+ ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p

269 <> maybe "" ("\n\n" <>) ann

252 <> maybe "" ("\n\n" <>) ann

270 , 2

253 , 2

271 )

254 )

@@ -352,7 +335,7 @@ ob = \case

352 Right (ThunkData_Packed ptr) -> return ptr

335 Right (ThunkData_Packed ptr) -> return ptr

353 Right (ThunkData_Checkout (Just ptr)) -> return ptr

336 Right (ThunkData_Checkout (Just ptr)) -> return ptr

354 Right (ThunkData_Checkout Nothing) ->

337 Right (ThunkData_Checkout Nothing) ->

355− getThunkPtr' False root (T.pack $ _deployInitOpts_remote deployOpts)

338+ getThunkPtr' False root

356 let sshKeyPath = _deployInitOpts_sshKey deployOpts

339 let sshKeyPath = _deployInitOpts_sshKey deployOpts

357 hostname = _deployInitOpts_hostname deployOpts

340 hostname = _deployInitOpts_hostname deployOpts

358 route = _deployInitOpts_route deployOpts

341 route = _deployInitOpts_route deployOpts

@@ -373,7 +356,7 @@ ob = \case

373 ObCommand_Thunk tc -> case tc of

356 ObCommand_Thunk tc -> case tc of

374 ThunkCommand_Update thunks -> mapM_ updateThunkToLatest thunks

357 ThunkCommand_Update thunks -> mapM_ updateThunkToLatest thunks

375 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

358 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

376− ThunkCommand_Pack thunks -> forM_ thunks $ \(ThunkPackOpts dir upstream) -> packThunk dir (T.pack upstream)

359+ ThunkCommand_Pack thunks -> forM_ thunks packThunk

377 ObCommand_Repl -> runRepl

360 ObCommand_Repl -> runRepl

378 ObCommand_Watch -> inNixShell' $ static runWatch

361 ObCommand_Watch -> inNixShell' $ static runWatch

379 ObCommand_Internal icmd -> case icmd of

362 ObCommand_Internal icmd -> case icmd of

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

@@ -113,7 +113,7 @@ deployPush deployPath getNixBuilders = do

113 checkGitCleanStatus srcPath True >>= \case

114 True -> do

115 result <- build

116− packThunk srcPath "origin" -- get upstream

116+ packThunk srcPath

117 return result

118 False -> do

119 _ <- 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

@@ -48,7 +48,6 @@ obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource

48 { _gitHubSource_owner = "obsidiansystems"

49 , _gitHubSource_repo = "obelisk"

50 , _gitHubSource_branch = Just branch

51− , _gitHubSource_private = False

52 }

51 }

54data InitSource

53data InitSource

lib/command/src/Obelisk/Command/Thunk.hs+338−261

@@ -27,10 +27,13 @@ module Obelisk.Command.Thunk

27 , updateThunk

28 , getThunkPtr

29 , getThunkPtr'

30+ , parseGitUri

31+ , uriThunkPtr

30 ) where

32 ) where

32import Control.Applicative

34import Control.Applicative

33−import Control.Exception (displayException, throwIO, try)

35+import Control.Exception (displayException, try)

36+import Control.Lens.Indexed hiding ((<.>))

34import Control.Monad

37import Control.Monad

35import Control.Monad.Catch (handle)

38import Control.Monad.Catch (handle)

36import Control.Monad.Except

39import Control.Monad.Except

@@ -40,13 +43,13 @@ import Data.Aeson.Encode.Pretty

40import qualified Data.Aeson.Types as Aeson

43import qualified Data.Aeson.Types as Aeson

41import qualified Data.ByteString.Lazy as LBS

44import qualified Data.ByteString.Lazy as LBS

42import Data.Default

45import Data.Default

43−import Data.Either.Combinators (rightToMaybe)

46+import Data.Either.Combinators (fromRight', rightToMaybe)

44−import Data.Foldable

45import Data.Git.Ref (Ref)

47import Data.Git.Ref (Ref)

46import qualified Data.Git.Ref as Ref

48import qualified Data.Git.Ref as Ref

47import qualified Data.List as L

49import qualified Data.List as L

48import Data.List.NonEmpty (NonEmpty (..))

50import Data.List.NonEmpty (NonEmpty (..))

49import qualified Data.List.NonEmpty as NonEmpty

51import qualified Data.List.NonEmpty as NonEmpty

52+import Data.Map (Map)

50import qualified Data.Map as Map

53import qualified Data.Map as Map

51import Data.Maybe

54import Data.Maybe

52import Data.Set (Set)

55import Data.Set (Set)

@@ -56,12 +59,9 @@ import qualified Data.Text as T

56import Data.Text.Encoding

59import Data.Text.Encoding

57import qualified Data.Text.IO as T

60import qualified Data.Text.IO as T

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

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

59−import Data.Yaml (parseMaybe, (.:))

62+import Data.Yaml (parseMaybe)

60−import qualified Data.Yaml as Yaml

61import GitHub

63import GitHub

62import GitHub.Data.Name

64import GitHub.Data.Name

63−import GitHub.Endpoints.Repos.Contents (archiveForR)

64−import Network.URI

65import Obelisk.Command.Nix

66import System.Directory

67import System.FilePath

@@ -69,6 +69,7 @@ import System.IO.Error

69import System.IO.Temp

70import System.Posix (getSymbolicLinkStatus, modificationTime)

71import System.Process (proc)

72+import Text.URI

73import Obelisk.App (MonadObelisk)

74import Obelisk.App (MonadObelisk)

74import Obelisk.CliApp

75import Obelisk.CliApp

@@ -111,21 +112,43 @@ data GitHubSource = GitHubSource

111 { _gitHubSource_owner :: Name Owner

112 { _gitHubSource_owner :: Name Owner

112 , _gitHubSource_repo :: Name Repo

113 , _gitHubSource_repo :: Name Repo

113 , _gitHubSource_branch :: Maybe (Name Branch)

114 , _gitHubSource_branch :: Maybe (Name Branch)

114− , _gitHubSource_private :: Bool

115 }

116 deriving (Show, Eq, Ord)

117

118data GitSource = GitSource

119 { _gitSource_url :: URI

120− , _gitSource_branch :: Name Branch

120+ , _gitSource_branch :: Maybe (Name Branch)

121 , _gitSource_fetchSubmodules :: Bool

122 }

123 deriving (Show, Eq, Ord)

124

125+-- | Convert a GitHub source to a regular Git source. Assumes no submodules.

126+forgetGithub :: Bool -> GitHubSource -> GitSource

127+forgetGithub useSsh s = GitSource

128+ { _gitSource_url = URI

129+ { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"

130+ , uriAuthority = Right $ Authority

131+ { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing

132+ <$ guard useSsh

133+ , authHost = fromRight' $ mkHost "github.com"

134+ , authPort = Nothing

135+ }

136+ , uriPath = Just ( False

137+ , fromRight' . mkPathPiece <$>

138+ untagName (_gitHubSource_owner s)

139+ :| [ untagName (_gitHubSource_repo s) <> ".git" ]

140+ )

141+ , uriQuery = []

142+ , uriFragment = Nothing

143+ }

144+ , _gitSource_branch = _gitHubSource_branch s

145+ , _gitSource_fetchSubmodules = False

146+ }

147+

125getThunkGitBranch :: ThunkPtr -> Maybe Text

148getThunkGitBranch :: ThunkPtr -> Maybe Text

126getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of

149getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of

127 ThunkSource_GitHub s -> _gitHubSource_branch s

150 ThunkSource_GitHub s -> _gitHubSource_branch s

128− ThunkSource_Git s -> Just $ _gitSource_branch s

151+ ThunkSource_Git s -> _gitSource_branch s

129

152

130commitNameToRef :: Name Commit -> Ref

153commitNameToRef :: Name Commit -> Ref

131commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

154commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

@@ -136,17 +159,17 @@ getNixSha256ForUriUnpacked

136 => URI

159 => URI

137 -> m NixSha256

160 -> m NixSha256

138getNixSha256ForUriUnpacked uri =

161getNixSha256ForUriUnpacked uri =

139− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> T.pack (show uri)) $ do

162+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do

140− [hash] <- fmap T.lines $ withNixRemoteCheck $ readProcessAndLogStderr Debug $

163+ [hash] <- fmap T.lines $ withNixRemoteCheck $ readProcessAndLogOutput (Debug, Debug) $

141− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]

164+ proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]

142 pure hash

165 pure hash

143

166

144nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256

167nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256

145nixPrefetchGit uri rev fetchSubmodules =

168nixPrefetchGit uri rev fetchSubmodules =

146− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> T.pack (show uri) <> " at " <> rev) $ do

169+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do

147 out <- withNixRemoteCheck $ readProcessAndLogStderr Debug $

170 out <- withNixRemoteCheck $ readProcessAndLogStderr Debug $

148 proc "nix-prefetch-git" $ filter (/="")

171 proc "nix-prefetch-git" $ filter (/="")

149− [ "--url", show uri

172+ [ "--url", T.unpack $ render uri

150 , "--rev", T.unpack rev

173 , "--rev", T.unpack rev

151 , if fetchSubmodules then "--fetch-submodules" else ""

174 , if fetchSubmodules then "--fetch-submodules" else ""

152 , "--quiet"

175 , "--quiet"

@@ -156,56 +179,6 @@ nixPrefetchGit uri rev fetchSubmodules =

156 Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out

179 Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out

157 Just x -> pure x

180 Just x -> pure x

158

181

159−getLatestGitRev :: MonadObelisk m => GitSource -> m ThunkRev

160−getLatestGitRev s = withSystemTempDirectory "git-clone" $ \tmpDir -> do

161− withExitFailMessage ("Unable to determine latest git revision for branch " <> branch) $ do

162− let git = readProcessAndLogStderr Debug . gitProc tmpDir

163− out <- liftA2 (<>)

164− (git ["clone", "--no-checkout", show $ _gitSource_url s]) -- Might be able to use --bare here instead to go faster.

165− (git ["log", T.unpack branch, "--max-count=1", "--format=%H"])

166−

167− case T.strip <$> safeLast (T.lines out) of

168− Nothing -> failWith $ "Unable to parse git log: " <> out

169− Just rev -> do

170− putLog Debug $ "Latest commit in " <> branch <> " is " <> rev

171− sha <- nixPrefetchGit (_gitSource_url s) rev (_gitSource_fetchSubmodules s)

172− putLog Debug $ "Nix sha256 is " <> sha

173− pure $ ThunkRev

174− { _thunkRev_commit = Ref.fromHexString $ T.unpack rev

175− , _thunkRev_nixSha256 = sha

176− }

177− where

178− remote :: Text = "origin"

179− branch :: Text = remote <> "/" <> untagName (_gitSource_branch s)

180−

181− safeLast [] = Nothing

182− safeLast xs = Just $ last xs

183−

184−-- | Get the latest revision available from the given source

185−getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev

186−getLatestRev = \case

187− ThunkSource_GitHub s -> do

188− auth <- liftIO $ getHubAuth "github.com"

189− commitsResult <- liftIO $ executeRequestMaybe auth $ commitsWithOptionsForR

190− (_gitHubSource_owner s)

191− (_gitHubSource_repo s)

192− (FetchAtLeast 1)

193− $ case _gitHubSource_branch s of

194− Nothing -> []

195− Just b -> [CommitQuerySha $ untagName b]

196− commitInfos <- either (liftIO . throwIO) return commitsResult

197− commitInfo : _ <- return $ toList commitInfos

198− let commit = commitSha commitInfo

199− putLog Debug $ "Latest commit is " <> untagName commit

200− Right archiveUri <- liftIO $ executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit

201− nixSha256 <- getNixSha256ForUriUnpacked archiveUri

202− putLog Debug $ "Nix sha256 is " <> nixSha256

203− return $ ThunkRev

204− { _thunkRev_commit = commitNameToRef commit

205− , _thunkRev_nixSha256 = nixSha256

206− }

207− ThunkSource_Git s -> getLatestGitRev s

208−

209--TODO: Pretty print these

182--TODO: Pretty print these

210data ReadThunkError

183data ReadThunkError

211 = ReadThunkError_UnrecognizedFiles

184 = ReadThunkError_UnrecognizedFiles

@@ -314,18 +287,16 @@ parseGitHubSource v = do

314 owner <- v Aeson..: "owner"

287 owner <- v Aeson..: "owner"

315 repo <- v Aeson..: "repo"

288 repo <- v Aeson..: "repo"

316 branch <- v Aeson..:! "branch"

289 branch <- v Aeson..:! "branch"

317− mPrivate <- v Aeson..:! "private"

318 pure $ GitHubSource

290 pure $ GitHubSource

319 { _gitHubSource_owner = owner

291 { _gitHubSource_owner = owner

320 , _gitHubSource_repo = repo

292 , _gitHubSource_repo = repo

321 , _gitHubSource_branch = branch

293 , _gitHubSource_branch = branch

322− , _gitHubSource_private = fromMaybe False mPrivate

323 }

294 }

324

295

325parseGitSource :: Aeson.Object -> Aeson.Parser GitSource

296parseGitSource :: Aeson.Object -> Aeson.Parser GitSource

326parseGitSource v = do

297parseGitSource v = do

327 Just url <- parseGitUri <$> v Aeson..: "url"

298 Just url <- parseGitUri <$> v Aeson..: "url"

328− branch <- v Aeson..: "branch"

299+ branch <- v Aeson..:! "branch"

329 fetchSubmodules <- v Aeson..:! "fetchSubmodules"

300 fetchSubmodules <- v Aeson..:! "fetchSubmodules"

330 pure $ GitSource

301 pure $ GitSource

331 { _gitSource_url = url

302 { _gitSource_url = url

@@ -354,20 +325,14 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

354 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes

325 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes

355 [ Just $ "owner" .= _gitHubSource_owner s

326 [ Just $ "owner" .= _gitHubSource_owner s

356 , Just $ "repo" .= _gitHubSource_repo s

327 , Just $ "repo" .= _gitHubSource_repo s

357− , case _gitHubSource_branch s of

328+ , ("branch" .=) <$> _gitHubSource_branch s

358− Just b -> Just $ "branch" .= b

359− Nothing -> Nothing

360− , if _gitHubSource_private s

361− then Just $ "private" .= True

362− else Nothing

363 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

329 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

364 , Just $ "sha256" .= _thunkRev_nixSha256 rev

330 , Just $ "sha256" .= _thunkRev_nixSha256 rev

365 ]

331 ]

366 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes

332 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes

367− --TODO: Is this safe? read/show is jank for `URI`

368− [ Just $ "url" .= show (_gitSource_url s)

333+ [ Just $ "url" .= render (_gitSource_url s)

369 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

334 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

370− , Just $ "branch" .= _gitSource_branch s

335+ , ("branch" .=) <$> _gitSource_branch s

371 , Just $ "sha256" .= _thunkRev_nixSha256 rev

336 , Just $ "sha256" .= _thunkRev_nixSha256 rev

372 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

337 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

373 ]

338 ]

@@ -499,20 +464,6 @@ plainGitStandaloneLoaderV2 = T.unlines

499thunkFileNames :: [FilePath]

464thunkFileNames :: [FilePath]

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

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

501

466

502−-- | Look for authentication info from the 'hub' command

503−getHubAuth

504− :: Text -- ^ Domain name

505− -> IO (Maybe Auth)

506−getHubAuth domain = do

507− hubConfig <- getXdgDirectory XdgConfig "hub"

508− Yaml.decodeFileEither hubConfig >>= \case

509− Left _ -> return Nothing

510− Right v -> return $ flip parseMaybe v $ \v' -> do

511− Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means

512− [Yaml.Object domainConfig] <- return $ toList domainConfigs

513− token <- domainConfig .: "oauth_token"

514− return $ OAuth $ encodeUtf8 token

515−

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

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

517

468

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

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

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

591 p' <- copyThunkToTmp tmpDir p

542 p' <- copyThunkToTmp tmpDir p

592 unpackThunk' True p'

543 unpackThunk' True p'

593 result <- f p'

544 result <- f p'

594− updateThunkFromTmp p' "origin" -- TODO: stop hardcoding remote

545+ updateThunkFromTmp p'

595 return result

546 return result

596 where

547 where

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

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

@@ -602,8 +553,8 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

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

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

603 return tmpThunk

554 return tmpThunk

604 Right _ -> failWith $ "Thunk is not packed"

555 Right _ -> failWith $ "Thunk is not packed"

605− updateThunkFromTmp p' remote = do

556+ updateThunkFromTmp p' = do

606− packThunk' True p' remote

557+ packThunk' True p'

607 callProcessAndLogOutput (Notice, Error) $

558 callProcessAndLogOutput (Notice, Error) $

608 proc "cp" ["-r", "-T", p', p]

559 proc "cp" ["-r", "-T", p', p]

609

560

@@ -622,190 +573,316 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case

622 let (thunkParent, thunkName) = splitFileName thunkDir

573 let (thunkParent, thunkName) = splitFileName thunkDir

623 withTempDirectory thunkParent thunkName $ \tmpRepo -> do

574 withTempDirectory thunkParent thunkName $ \tmpRepo -> do

624 let obGitDir = tmpRepo </> ".git" </> "obelisk"

575 let obGitDir = tmpRepo </> ".git" </> "obelisk"

625− case _thunkPtr_source tptr of

576+ s = case _thunkPtr_source tptr of

626− ThunkSource_GitHub s -> do

577+ ThunkSource_GitHub s' -> forgetGithub False s'

627− mauth <- liftIO $ getHubAuth "github.com"

628− repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)

629− githubURI <- either (liftIO . throwIO) (return . repoSshUrl) repoResult >>= \case

630− Nothing -> failWith "Cannot determine clone URI for thunk source"

631− Just c -> return $ T.unpack $ getUrl c

632−

633− withSpinner' ("Fetching thunk " <> T.pack thunkDir)

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

635− callProcessAndLogOutput (Debug, Debug) $

636− proc "hub" ["clone", "-n", githubURI, tmpRepo]

637− --If this directory already exists then something is weird and we should fail

638− liftIO $ createDirectory obGitDir

639− callProcessAndLogOutput (Debug, Error) $

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

641−

642− -- Checkout

643− putLog Debug $ "Checking out " <> T.pack (show $ maybe "" untagName $ _gitHubSource_branch s)

644− callProcessAndLogOutput (Debug, Debug) $

645− proc "hub" $ concat

646− [ ["-C", tmpRepo]

647− , pure "checkout"

648− , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)

649− , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr

650− ]

651− -- Set upstream branch

652− forM_ (_gitHubSource_branch s) $ \branch ->

653− callProcessAndLogOutput (Debug, Error) $

654− proc "hub" ["-C", tmpRepo, "branch", "-u", "origin/" <> T.unpack (untagName branch)]

655− callProcessAndLogOutput (Notice, Error) $ proc "rm" ["-r", thunkDir]

656− callProcessAndLogOutput (Notice, Error) $ proc "mv" ["-T", tmpRepo, thunkDir]

657−

658− ThunkSource_Git s -> do

578+ ThunkSource_Git s' -> s'

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

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

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

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

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

581+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo

582+ git $ [ "clone" ]

662− git ["clone", if _gitSource_fetchSubmodules s then "--recursive" else "", show (_gitSource_url s)]

583+ ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))

584+ ++ [ T.unpack $ render $ _gitSource_url s ]

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

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

664− when (_gitSource_fetchSubmodules s) $

586+ when (_gitSource_fetchSubmodules s) $

665− git ["submodule", "update", "--recursive", "--init"]

587+ git ["submodule", "update", "--recursive", "--init"]

666− git ["branch", "-u", "origin/" <> T.unpack (untagName $ _gitSource_branch s)]

588+ case _gitSource_branch s of

667−

589+ Just b -> git ["branch", "-u", "origin/" <> T.unpack (untagName $ b)]

590+ Nothing -> pure ()

591+

668− liftIO $ createDirectory obGitDir

592+ liftIO $ createDirectory obGitDir

669− callProcessAndLogOutput (Notice, Error) $

593+ callProcessAndLogOutput (Notice, Error) $

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

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

671− callProcessAndLogOutput (Notice, Error) $

595+ callProcessAndLogOutput (Notice, Error) $

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

596+ proc "rm" ["-r", thunkDir]

673− callProcessAndLogOutput (Notice, Error) $

597+ callProcessAndLogOutput (Notice, Error) $

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

598+ proc "mv" ["-T", tmpRepo, thunkDir]

675

599

676--TODO: add force mode to pack even if changes are present

600--TODO: add force mode to pack even if changes are present

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

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

678−packThunk :: MonadObelisk m => FilePath -> Text -> m ()

602+packThunk :: MonadObelisk m => FilePath -> m ()

679packThunk = packThunk' False

603packThunk = packThunk' False

680

604

681−packThunk' :: MonadObelisk m => Bool -> FilePath -> Text -> m ()

605+packThunk' :: MonadObelisk m => Bool -> FilePath -> m ()

682−packThunk' noTrail thunkDir upstream = readThunk thunkDir >>= \case

606+packThunk' noTrail thunkDir = readThunk thunkDir >>= \case

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

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

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

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

685 Right (ThunkData_Checkout _) -> do

609 Right (ThunkData_Checkout _) -> do

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

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

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

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

688− thunkPtr <- getThunkPtr thunkDir upstream

612+ thunkPtr <- getThunkPtr thunkDir

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

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

690 liftIO $ createThunk thunkDir thunkPtr

614 liftIO $ createThunk thunkDir thunkPtr

691

615

692−getThunkPtr :: MonadObelisk m => FilePath -> Text -> m ThunkPtr

616+getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr

693getThunkPtr = getThunkPtr' True

617getThunkPtr = getThunkPtr' True

694

618

695−getThunkPtr' :: MonadObelisk m => Bool -> FilePath -> Text -> m ThunkPtr

619+getThunkPtr' :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr

696−getThunkPtr' checkClean thunkDir upstream = do

620+getThunkPtr' checkClean thunkDir = do

697− when checkClean $ ensureCleanGitRepo thunkDir True $

621+ when checkClean $ ensureCleanGitRepo thunkDir True $

698− "thunk pack: thunk checkout contains unsaved modifications"

622+ "thunk pack: thunk checkout contains unsaved modifications"

699−

623+

700− -- Check whether there are any stashes

624+ -- Check whether there are any stashes

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

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

702− when checkClean $ case T.null stashOutput of

626+ when checkClean $ case T.null stashOutput of

703− False -> do

627+ False -> do

704− failWith $ T.unlines $

628+ failWith $ T.unlines $

705− [ "thunk pack: thunk checkout has stashes"

629+ [ "thunk pack: thunk checkout has stashes"

706− , "git stash list:"

630+ , "git stash list:"

707− ] ++ T.lines stashOutput

631+ ] ++ T.lines stashOutput

708− True -> return ()

632+ True -> return ()

709−

633+

710− --Check whether all local heads are pushed

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

635+ -- correspondents

711− repoHeads <- T.lines <$> readGitProcess thunkDir ["for-each-ref", "--format=%(refname:short)", "refs/heads/"]

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

712− remotes <- T.lines <$> readGitProcess thunkDir ["remote"]

637+ [ "for-each-ref"

713− --Check that the upstream specified actually exists

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

714− case L.find (== upstream) remotes of

639+ , "refs/heads/"

715− Nothing -> failWith $ "thunk pack: upstream " <> upstream <> " does not exist. Available upstreams are " <> T.intercalate ", " remotes

640+ ]

716− Just _ -> return ()

641+

717− -- iterate over cartesian product

642+ (headInfo :: Map Text (Maybe (Text, Text)))

643+ <- fmap Map.fromList $ forM headDump $ \line -> do

644+ (branch : restOfLine) <- pure $ T.words line

645+ mUpstream <- case restOfLine of

646+ [] -> pure Nothing

647+ [u, r] -> pure $ Just (u, r)

648+ (_:_) -> failWith "git for-each-ref invalid output"

649+ pure (branch, mUpstream)

650+

651+ putLog Debug $ "branches: " <> T.pack (show headInfo)

652+

653+ let errorMap :: Map Text ()

654+ headUpstream :: Map Text (Text, Text)

655+ (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case

656+ Nothing -> Left ()

657+ Just b -> Right b

658+

659+ putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)

660+

661+ -- Check that every branch has a remote equivalent

718− when checkClean $ forM_ repoHeads $ \hd -> do

662+ when checkClean $ do

719− [localRev] <- T.lines <$> readGitProcess thunkDir ["rev-parse", T.unpack hd]

663+ let untrackedBranches = Map.keys errorMap

720− forM_ remotes $ \rm -> do

664+ when (not $ L.null untrackedBranches) $ failWith $ T.unlines $

721− --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly

665+ [ "thunk pack: Certain branches in the thunk have no upstream branch \

722− [remoteMergeRev] <- fmap T.lines $ readGitProcess thunkDir

666+ \set. This means don't know to check whether all your work is \

723− ["merge-base", T.unpack localRev, "remotes/" <> T.unpack rm <> "/" <> T.unpack hd]

667+ \saved. The offending branches are:"

724− case remoteMergeRev == localRev of

668+ , ""

725− False -> failWith $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]

669+ , T.unwords untrackedBranches

726− True -> return ()

670+ , ""

727−

671+ , "To fix this, you probably want to do:"

672+ , ""

673+ ] ++

674+ ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++

675+ [ ""

676+ , "These will push the branches to the default remote under the same \

677+ \name, and (thanks to the `-u`) remember that choice so you don't \

678+ \get this error again."

679+ ]

680+

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

682+ stats <- iforM headUpstream $ \branch (upstream, _remote) -> do

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

684+ [ "rev-list", "--left-right"

685+ , T.unpack branch <> "..." <> T.unpack upstream

686+ ]

687+ let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]

688+ behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]

689+ pure (upstream, (ahead, behind))

690+

691+ -- Those branches which have commits ahead of, i.e. not on, the upstream

692+ -- branch. Purely being behind is fine.

693+ let nonGood = Map.filter ((/= 0) . fst . snd) stats

694+

695+ when (not $ Map.null nonGood) $ failWith $ T.unlines $

696+ [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"

697+ , ""

698+ ] ++

699+ (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat

700+ [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++

701+ [ ""

702+ , "Please push these upstream and try again. (Or just fetch, if they are somehow \

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

704+ ]

705+

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

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

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

708+

709+ -- Get current branch ``

710+ mCurrentBranch <- listToMaybe

711+ <$> T.lines

712+ <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]

713+

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

715+

729− [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir ["config", "--get", "remote." <> T.unpack upstream <> ".url"]

716+ [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir

730−

717+ [ "config"

718+ , "--get"

719+ , "remote." <> T.unpack remote <> ".url"

720+ ]

721+

722+ remoteUri <- case parseGitUri remoteUri' of

731− let uriParseFailure = "Could not identify git remote: " <> remoteUri'

723+ Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'

732− mRemoteUri = parseGitUri remoteUri'

724+ Just uri -> pure uri

733− case mRemoteUri of

725+ uriThunkPtr remoteUri mCurrentBranch

734− Nothing -> failWith uriParseFailure

726+

735− Just remoteUri -> do

727+-- | Get the latest revision available from the given source

736− refs <- fmap (map (refsToTuples . T.words) . T.lines) $ readGitProcess thunkDir ["show-ref", "--head"]

728+getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev

737− -- safe because exactly one hash is associated with HEAD

729+getLatestRev os = do

738− let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs

730+ let gitS = case os of

739− remoteHeads = Map.fromList $ catMaybes $ fmap

731+ ThunkSource_GitHub s -> forgetGithub False s

740− (\(x,y) -> (,) x <$> T.stripPrefix ("refs/remotes/" <> upstream <> "/") y)

732+ ThunkSource_Git s -> s

741− refs

733+ (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)

742− localHeads = Map.fromList $ catMaybes $ fmap

734+ case os of

743− (\(x,y) -> (,) x <$> T.stripPrefix "refs/heads/" y)

735+ ThunkSource_GitHub s -> githubThunkRev s commit

744− refs

736+ ThunkSource_Git s -> gitThunkRev s commit

745− currentUpstreamBranch = Map.lookup currentHead remoteHeads

737+

746− <|> Map.lookup currentHead localHeads

738+-- | Convert a URI to a thunk

747− if isGithubThunk remoteUri

739+--

748− then githubThunkPtr remoteUri currentHead currentUpstreamBranch

740+-- If the URL is a github URL, we try to just download an archive for

749− else gitThunkPtr remoteUri currentHead currentUpstreamBranch

741+-- performance. If that doesn't work (e.g. authentication issue), we fall back

750− where

742+-- on just doing things the normal way for git repos in general, and save it as

751− refsToTuples [x, y] = (x, y)

743+-- a regular git thunk.

752− refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x

744+uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> m ThunkPtr

753− isGithubThunk u

745+uriThunkPtr uri mbranch = do

754− | Just uriAuth <- uriAuthority u

746+ (_, commit) <- gitGetCommitBranch uri mbranch

755− = case uriScheme u of

747+ (src, rev) <- case uriToThunkSource uri mbranch of

756− "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""

748+ ThunkSource_GitHub s -> do

757− s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"

749+ rev <- runExceptT $ githubThunkRev s commit

758− && uriRegName uriAuth == "github.com"

750+ case rev of

759− | otherwise = False

751+ Right r -> pure (ThunkSource_GitHub s, r)

760− githubThunkPtr u commit' branch' = do

752+ Left e -> do

761− ["/", owner', repo'] <- return $ splitDirectories (uriPath u)

753+ putLog Warning $ "\

762− let owner = N (T.pack owner')

754+\Failed to fetch archive from GitHub. This is probably a private repo. \

763− dropGitExtension r = fromMaybe r $ T.stripSuffix ".git" r

755+\Falling back on normal fetchgit. Original failure:\n\n"

764− repo = N $ dropGitExtension $ T.pack repo'

756+ errorToWarning e

765− commit = N commit'

757+ let s' = forgetGithub True s

766− branch = N <$> branch'

758+ (,) (ThunkSource_Git s') <$> gitThunkRev s' commit

767− mauth <- liftIO $ getHubAuth "github.com"

759+ ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit

768− repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR owner repo

760+ pure $ ThunkPtr

769− repoIsPrivate <- either (liftIO . throwIO) (return . repoPrivate) repoResult

761+ { _thunkPtr_rev = rev

770− archiveResult <- liftIO $ executeRequestMaybe mauth $

762+ , _thunkPtr_source = src

771− archiveForR owner repo ArchiveFormatTarball (Just (untagName commit))

763+ }

772− archiveUri <- either (liftIO . throwIO) return archiveResult

764+

773− hash <- getNixSha256ForUriUnpacked archiveUri

765+-- | N.B. Cannot infer all fields.

774− return $ ThunkPtr

766+--

775− { _thunkPtr_rev = ThunkRev

767+-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with

776− { _thunkRev_commit = commitNameToRef commit

768+-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method

777− , _thunkRev_nixSha256 = hash

769+-- should be employed, and so we respect that.

778− }

770+uriToThunkSource :: URI -> Maybe Text -> ThunkSource

779− , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource

771+uriToThunkSource u

780− { _gitHubSource_owner = owner

772+ | Right uriAuth <- uriAuthority u

781− , _gitHubSource_repo = repo

773+ , Just scheme <- unRText <$> uriScheme u

782− , _gitHubSource_branch = branch

774+ , case scheme of

783− , _gitHubSource_private = repoIsPrivate

775+ "ssh" -> uriAuth == Authority

784− }

776+ { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing

785− }

777+ , authHost = fromRight' $ mkHost "github.com"

786− gitThunkPtr u commit branch' = do

778+ , authPort = Nothing

787− let protocols = ["https:", "ssh:", "git:"]

788− unless (T.toLower (T.pack $ uriScheme u) `elem` protocols) $

789− failWith $ "thunk pack: obelisk currently only supports "

790− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"

791− hash <- nixPrefetchGit u commit False

792− branch <- case branch' of

793− Nothing -> failWith "thunk pack: git thunks must track a branch"

794− Just b -> pure $ N b

795− pure $ ThunkPtr

796− { _thunkPtr_rev = ThunkRev

797− { _thunkRev_commit = commitNameToRef (N commit)

798− , _thunkRev_nixSha256 = hash

799− }

800− , _thunkPtr_source = ThunkSource_Git $ GitSource

801− { _gitSource_url = u

802− , _gitSource_branch = branch

803− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?

804 }

779 }

780+ s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"

781+ && unRText (authHost uriAuth) == "github.com"

782+ , Just (_, owner :| [repoish]) <- uriPath u

783+ = \mbranch -> ThunkSource_GitHub $ GitHubSource

784+ { _gitHubSource_owner = N $ unRText owner

785+ , _gitHubSource_repo = N $ let

786+ repoish' = unRText repoish

787+ in case T.stripSuffix ".git" repoish' of

788+ Just repo -> repo

789+ Nothing -> repoish'

790+ , _gitHubSource_branch = N <$> mbranch

805− }

791+ }

792+

793+ | otherwise = \mbranch -> ThunkSource_Git $ GitSource

794+ { _gitSource_url = u

795+ , _gitSource_branch = N <$> mbranch

796+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?

797+ }

798+

799+-- Funny signature indicates no effects depend on the optional branch name.

800+githubThunkRev

801+ :: forall m

802+ . MonadObelisk m

803+ => GitHubSource

804+ -> Text

805+ -> m ThunkRev

806+githubThunkRev s commit = do

807+ owner <- forcePP $ _gitHubSource_owner s

808+ repo <- forcePP $ _gitHubSource_repo s

809+ revTarball <- mkPathPiece $ commit <> ".tar.gz"

810+ let archiveUri = URI

811+ { uriScheme = Just $ fromRight' $ mkScheme "https"

812+ , uriAuthority = Right $ Authority

813+ { authUserInfo = Nothing

814+ , authHost = fromRight' $ mkHost "github.com"

815+ , authPort = Nothing

816+ }

817+ , uriPath = Just ( False

818+ , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]

819+ )

820+ , uriQuery = []

821+ , uriFragment = Nothing

822+ }

823+ hash <- getNixSha256ForUriUnpacked archiveUri

824+ putLog Debug $ "Nix sha256 is " <> hash

825+ return $ ThunkRev

826+ { _thunkRev_commit = commitNameToRef $ N commit

827+ , _thunkRev_nixSha256 = hash

828+ }

829+ where

830+ forcePP :: Name entity -> m (RText 'PathPiece)

831+ forcePP = mkPathPiece . untagName

832+

833+gitThunkRev

834+ :: MonadObelisk m

835+ => GitSource

836+ -> Text

837+ -> m ThunkRev

838+gitThunkRev s commit = do

839+ let u = _gitSource_url s

840+ protocols = ["https", "ssh", "git"]

841+ Just scheme <- pure $ unRText <$> uriScheme u

842+ unless (T.toLower scheme `elem` protocols) $

843+ failWith $ "obelisk currently only supports "

844+ <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"

845+ hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s

846+ putLog Informational $ "Nix sha256 is " <> hash

847+ pure $ ThunkRev

848+ { _thunkRev_commit = commitNameToRef (N commit)

849+ , _thunkRev_nixSha256 = hash

850+ }

851+

852+-- | Given the URI to a git remote, and an optional branch name, return the name

853+-- of the branch along with the hash of the commit at tip of that branch.

854+--

855+-- If the branch name is passed in, it is returned exactly as-is. If it is not

856+-- passed it, the default branch of the repo is used instead.

857+gitGetCommitBranch

858+ :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)

859+gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do

860+ bothMaps <- gitLsRemote

861+ (T.unpack $ render uri)

862+ (GitRef_Branch <$> mbranch)

863+ branch <- case mbranch of

864+ Nothing -> withExitFailMessage "Failed to find default branch" $ do

865+ b <- rethrowE $ gitLookupDefaultBranch bothMaps

866+ putLog Debug $ "Default branch for remote repo " <> uriMsg <> " is " <> b

867+ pure b

868+ Just b -> pure b

869+ commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)

870+ putLog Informational $ "Latest commit in branch " <> branch

871+ <> " from remote repo " <> uriMsg

872+ <> " is " <> commit

873+ pure (branch, commit)

874+ where

875+ rethrowE = either failWith pure

876+ uriMsg = render uri

806

877

807parseGitUri :: Text -> Maybe URI

878parseGitUri :: Text -> Maybe URI

808−parseGitUri x = parseURIReference (T.unpack x) <|> parseSshShorthand x

879+parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x

880+

881+parseAbsoluteURI :: Text -> Maybe URI

882+parseAbsoluteURI uri = do

883+ parsedUri <- mkURI uri

884+ guard $ isPathAbsolute parsedUri

885+ pure $ parsedUri

809

886

810parseSshShorthand :: Text -> Maybe URI

887parseSshShorthand :: Text -> Maybe URI

811parseSshShorthand uri = do

888parseSshShorthand uri = do

@@ -820,4 +897,4 @@ parseSshShorthand uri = do

820 -- This check is used to disambiguate a filepath containing a colon from shorthand

897 -- This check is used to disambiguate a filepath containing a colon from shorthand

821 guard $ isNothing (T.findIndex (=='/') authAndHostname)

898 guard $ isNothing (T.findIndex (=='/') authAndHostname)

822 && not (T.null colonAndPath)

899 && not (T.null colonAndPath)

823− parseURI $ T.unpack properUri

900+ mkURI properUri

lib/command/src/Obelisk/Command/Utils.hs+103−5

@@ -1,16 +1,30 @@

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE MultiWayIf #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE PatternGuards #-}

4module Obelisk.Command.Utils where

7module Obelisk.Command.Utils where

6−import Control.Applicative (liftA2)

9+import Control.Applicative hiding (many)

10+import Control.Monad.Except

7import Data.Bool (bool)

11import Data.Bool (bool)

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

13+import Data.Bifunctor

14+import Data.Char

15+import Data.Either

8import Data.Semigroup ((<>))

16import Data.Semigroup ((<>))

17+import Data.Map (Map)

18+import qualified Data.Map as M

19+import Data.Maybe (maybeToList)

9import Data.Text (Text)

20import Data.Text (Text)

10import qualified Data.Text as T

21import qualified Data.Text as T

22+import Data.Void (Void)

11import System.Directory (canonicalizePath)

23import System.Directory (canonicalizePath)

12import System.Environment (getExecutablePath)

24import System.Environment (getExecutablePath)

13import qualified System.Process as P

25import qualified System.Process as P

26+import Text.Megaparsec as MP

27+import Text.Megaparsec.Char as MP

15import Obelisk.App (MonadObelisk)

29import Obelisk.App (MonadObelisk)

16import Obelisk.CliApp

30import Obelisk.CliApp

@@ -46,9 +60,11 @@ initGit repo = do

46 git ["add", "."]

60 git ["add", "."]

47 git ["commit", "-m", "Initial commit."]

61 git ["commit", "-m", "Initial commit."]

63+gitProcNoRepo :: [String] -> P.CreateProcess

64+gitProcNoRepo = P.proc "git"

65+

49gitProc :: FilePath -> [String] -> P.CreateProcess

66gitProc :: FilePath -> [String] -> P.CreateProcess

50−gitProc repo argsRaw =

67+gitProc repo = gitProcNoRepo . runGitInDir

51− P.proc "git" $ runGitInDir argsRaw

52 where

68 where

53 runGitInDir args' = case filter (not . null) args' of

69 runGitInDir args' = case filter (not . null) args' of

54 args@("clone":_) -> args <> [repo]

70 args@("clone":_) -> args <> [repo]

@@ -60,7 +76,7 @@ copyDir src dest =

60 (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }

76 (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }

62readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

78readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

63−readGitProcess repo = readProcessAndLogStderr Notice . gitProc repo

79+readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

65processToShellString :: FilePath -> [String] -> String

81processToShellString :: FilePath -> [String] -> String

66processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

82processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

@@ -76,7 +92,89 @@ runProcSilently = callProcessAndLogOutput (Debug, Debug)

77-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.

93-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.

78readProc :: MonadObelisk m => P.CreateProcess -> m Text

94readProc :: MonadObelisk m => P.CreateProcess -> m Text

79−readProc = readProcessAndLogStderr Error

95+readProc = readProcessAndLogOutput (Debug, Error)

81tshow :: Show a => a -> Text

97tshow :: Show a => a -> Text

82tshow = T.pack . show

98tshow = T.pack . show

99+

100+gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text

101+gitLookupDefaultBranch (refs, _) = do

102+ ref <- case M.lookup GitRef_Head refs of

103+ Just ref -> pure ref

104+ Nothing -> throwError

105+ "No symref entry for HEAD. \

106+ \ Is your git version at least 1.8.5? \

107+ \ Otherwise `git ls-remote --symref` will not work."

108+ case ref of

109+ GitRef_Branch b -> pure b

110+ _ -> throwError $

111+ "Default ref " <> showGitRef ref <> " is not a branch!"

112+

113+gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId

114+gitLookupCommitForRef (_, commits) ref = case M.lookup ref commits of

115+ Just a -> pure a

116+ Nothing -> throwError $ "Did not find commit for " <> showGitRef ref

117+

118+gitLsRemote

119+ :: MonadObelisk m

120+ => String

121+ -> Maybe GitRef

122+ -> m GitLsRemoteMaps

123+gitLsRemote repository mRef = do

124+ t <- readProc $ gitProcNoRepo $

125+ ["ls-remote", "--symref", repository]

126+ ++ (maybeToList $ T.unpack . showGitRef <$> mRef)

127+ maps <- case MP.runParser parseLsRemote "" t of

128+ Left err -> failWith $ T.pack $ MP.parseErrorPretty' t err

129+ Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table

130+ putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

131+ pure maps

132+

133+lexeme :: Parsec Void Text a -> Parsec Void Text a

134+lexeme = ML.lexeme $ void $ MP.takeWhileP (Just "within-line white space") $

135+ flip elem [' ', '\t']

136+

137+-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD

138+-- ref: refs/heads/master HEAD

139+-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5 refs/heads/master

140+parseLsRemote :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, CommitId)]

141+parseLsRemote =

142+ many ((fmap Left (try parseRef) <|> fmap Right parseCommit) <* try MP.eol) <* MP.eof

143+ where

144+ parseRef :: Parsec Void Text (GitRef, GitRef)

145+ parseRef = MP.label "ref and symbolic ref" $ do

146+ _ <- lexeme "ref:"

147+ ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace

148+ symbolicRef <- lexeme $ MP.takeWhileP (Just "symbolic ref") $ not . isSpace

149+ return (toGitRef symbolicRef, toGitRef ref)

150+ parseCommit :: Parsec Void Text (GitRef, CommitId)

151+ parseCommit = MP.label "commit and ref" $ do

152+ commitId <- lexeme $ MP.takeWhileP (Just "commit id") $ not . isSpace

153+ ref <- lexeme $ MP.takeWhileP (Just "ref") $ not . isSpace

154+ return (toGitRef ref, commitId)

155+

156+data GitRef

157+ = GitRef_Head

158+ | GitRef_Branch Text

159+ | GitRef_Tag Text

160+ | GitRef_Other Text

161+ deriving (Show, Eq, Ord)

162+

163+showGitRef :: GitRef -> Text

164+showGitRef = \case

165+ GitRef_Head -> "HEAD"

166+ GitRef_Branch x -> "refs/heads/" <> x

167+ GitRef_Tag x -> "refs/tags/" <> x

168+ GitRef_Other x -> x

169+

170+toGitRef :: Text -> GitRef

171+toGitRef = \case

172+ "HEAD" -> GitRef_Head

173+ r -> if

174+ | Just s <- "refs/heads/" `T.stripPrefix` r -> GitRef_Branch s

175+ | Just s <- "refs/tags/" `T.stripPrefix` r -> GitRef_Tag s

176+ | otherwise -> GitRef_Other r

177+

178+type CommitId = Text

179+

180+type GitLsRemoteMaps = (Map GitRef GitRef, Map GitRef CommitId)

lib/command/src/Obelisk/Command/VmBuilder.hs+8−4

@@ -1,11 +1,12 @@

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE QuasiQuotes #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

4module Obelisk.Command.VmBuilder where

5module Obelisk.Command.VmBuilder where

6import Control.Applicative (liftA2)

7import Control.Applicative (liftA2)

7import Control.Monad (unless)

8import Control.Monad (unless)

8−import Control.Monad.Catch (try)

9+import Control.Monad.Catch (try, handle)

9import Control.Monad.IO.Class (liftIO)

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

10import Data.Either (isRight)

11import Data.Either (isRight)

11import Data.Monoid ((<>))

12import Data.Monoid ((<>))

@@ -42,13 +43,16 @@ containerName = "obelisk-docker-nix-builder"

43-- | Check to see if the Docker container exists. This will exit with a helpful message if Docker is not installed.

44-- | Check to see if the Docker container exists. This will exit with a helpful message if Docker is not installed.

44containerExists :: MonadObelisk m => m Bool

45containerExists :: MonadObelisk m => m Bool

45−containerExists = withExitFailMessage needDockerMsg $ do

46+containerExists = handle (\(_ :: IOError) -> failWith needDockerMsg) $ do

46 containerNames <- fmap (map T.strip . T.lines) $

47 containerNames <- fmap (map T.strip . T.lines) $

47 readProcessAndLogStderr Error $

48 readProcessAndLogStderr Error $

48 proc "docker" ["container", "list", "--all", "--format", "{{.Names}}"]

49 proc "docker" ["container", "list", "--all", "--format", "{{.Names}}"]

49 pure $ containerName `elem` containerNames

50 pure $ containerName `elem` containerNames

50 where

51 where

52+ needDockerMsg = T.intercalate "\n"

51− needDockerMsg = "This feature requires that you have Docker installed and the `docker` command available on your PATH. Please go https://docs.docker.com/ to install Docker and try this command again."

53+ [ "This feature requires that you have Docker installed and the `docker` command available on your PATH."

54+ , "Please go https://docs.docker.com/ to install Docker and try this command again."

55+ ]

53-- | SSH port on localhost that connects to the container.

57-- | SSH port on localhost that connects to the container.

54containerSshPort :: Int

58containerSshPort :: Int

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

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

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

76 -- Build the docker container (which uses the SSH keys in the 'ssh' folder)

80 -- Build the docker container (which uses the SSH keys in the 'ssh' folder)

77− containerId <- readProcessAndLogStderr Error $

81+ containerId <- fmap T.strip $ readProcessAndLogStderr Error $

78 proc "docker" ["build", stateDir, "--quiet"]

82 proc "docker" ["build", stateDir, "--quiet"]

79 callProcessAndLogOutput (Debug, Error) $ proc "docker"

83 callProcessAndLogOutput (Debug, Error) $ proc "docker"

80 [ "run"

84 [ "run"