git.iko.soy/obelisk
on ae@static-which-prefetch help sign in
obelisk/lib/command/src/Obelisk/Command/Thunk.hs
1191 lines 49 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiWayIf #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE QuasiQuotes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeApplications #-}
11module Obelisk.Command.Thunk where
13import Control.Applicative
14import Control.Exception (displayException, try)
15import Control.Lens (ifor, ifor_, (.~))
16import Control.Monad
17import Control.Monad.Extra (findM)
18import Control.Monad.Catch (MonadCatch, handle)
19import Control.Monad.Except
20import Data.Aeson ((.=))
21import qualified Data.Aeson as Aeson
22import Data.Aeson.Encode.Pretty
23import qualified Data.Aeson.Types as Aeson
24import Data.Bifunctor (first)
25import qualified Data.ByteString.Lazy as LBS
26import Data.Containers.ListUtils (nubOrd)
27import Data.Default
28import Data.Either.Combinators (fromRight', rightToMaybe)
29import Data.Foldable (toList)
30import Data.Function ((&))
31import Data.Functor ((<&>))
32import Data.Git.Ref (Ref)
33import qualified Data.Git.Ref as Ref
34import qualified Data.List as L
35import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
36import qualified Data.List.NonEmpty as NonEmpty
37import Data.Map (Map)
38import qualified Data.Map as Map
39import Data.Maybe
40import Data.Set (Set)
41import qualified Data.Set as Set
42import Data.String.Here.Interpolated (i)
43import Data.String.Here.Uninterpolated (here)
44import Data.Text (Text)
45import qualified Data.Text as T
46import Data.Text.Encoding
47import qualified Data.Text.IO as T
48import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
49import Data.Traversable (for)
50import Data.Yaml (parseMaybe)
51import GitHub
52import GitHub.Data.Name
53import Obelisk.Command.Nix
54import System.Directory
55import System.Exit
56import System.FilePath
57import System.IO.Error
58import System.IO.Temp
59import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
60import qualified Text.URI as URI
62import Obelisk.App (MonadObelisk)
63import Obelisk.CliApp
64import Obelisk.Command.Utils
66--TODO: Support symlinked thunk data
67data ThunkData
68 = ThunkData_Packed ThunkSpec ThunkPtr
69 -- ^ Packed thunk
70 | ThunkData_Checkout
71 -- ^ Checked out thunk that was unpacked from this pointer
73-- | A reference to the exact data that a thunk should translate into
74data ThunkPtr = ThunkPtr
75 { _thunkPtr_rev :: ThunkRev
76 , _thunkPtr_source :: ThunkSource
77 }
78 deriving (Show, Eq, Ord)
80type NixSha256 = Text --TODO: Use a smart constructor and make this actually verify itself
82-- | A specific revision of data; it may be available from multiple sources
83data ThunkRev = ThunkRev
84 { _thunkRev_commit :: Ref Ref.SHA1
85 , _thunkRev_nixSha256 :: NixSha256
86 }
87 deriving (Show, Eq, Ord)
89-- | A location from which a thunk's data can be retrieved
90data ThunkSource
91 -- | A source specialized for GitHub
92 = ThunkSource_GitHub GitHubSource
93 -- | A plain repo source
94 | ThunkSource_Git GitSource
95 deriving (Show, Eq, Ord)
97thunkSourceToGitSource :: ThunkSource -> GitSource
98thunkSourceToGitSource = \case
99 ThunkSource_GitHub s -> forgetGithub False s
100 ThunkSource_Git s -> s
102data GitHubSource = GitHubSource
103 { _gitHubSource_owner :: Name Owner
104 , _gitHubSource_repo :: Name Repo
105 , _gitHubSource_branch :: Maybe (Name Branch)
106 , _gitHubSource_private :: Bool
107 }
108 deriving (Show, Eq, Ord)
110newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
112gitUriToText :: GitUri -> Text
113gitUriToText (GitUri uri)
114 | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"
115 , Just (_, path) <- URI.uriPath uri
116 = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)
117 | otherwise = URI.render uri
119data GitSource = GitSource
120 { _gitSource_url :: GitUri
121 , _gitSource_branch :: Maybe (Name Branch)
122 , _gitSource_fetchSubmodules :: Bool
123 , _gitSource_private :: Bool
124 }
125 deriving (Show, Eq, Ord)
127newtype ThunkConfig = ThunkConfig
128 { _thunkConfig_private :: Maybe Bool
129 } deriving Show
131data ThunkUpdateConfig = ThunkUpdateConfig
132 { _thunkUpdateConfig_branch :: Maybe String
133 , _thunkUpdateConfig_config :: ThunkConfig
134 } deriving Show
136data ThunkPackConfig = ThunkPackConfig
137 { _thunkPackConfig_force :: Bool
138 , _thunkPackConfig_config :: ThunkConfig
139 } deriving Show
141-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
142forgetGithub :: Bool -> GitHubSource -> GitSource
143forgetGithub useSsh s = GitSource
144 { _gitSource_url = GitUri $ URI.URI
145 { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"
146 , URI.uriAuthority = Right $ URI.Authority
147 { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
148 <$ guard useSsh
149 , URI.authHost = fromRight' $ URI.mkHost "github.com"
150 , URI.authPort = Nothing
151 }
152 , URI.uriPath = Just ( False
153 , fromRight' . URI.mkPathPiece <$>
154 untagName (_gitHubSource_owner s)
155 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
156 )
157 , URI.uriQuery = []
158 , URI.uriFragment = Nothing
159 }
160 , _gitSource_branch = _gitHubSource_branch s
161 , _gitSource_fetchSubmodules = False
162 , _gitSource_private = _gitHubSource_private s
163 }
165getThunkGitBranch :: ThunkPtr -> Maybe Text
166getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
167 ThunkSource_GitHub s -> _gitHubSource_branch s
168 ThunkSource_Git s -> _gitSource_branch s
170commitNameToRef :: Name Commit -> Ref Ref.SHA1
171commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
173-- TODO: Use spinner here.
174getNixSha256ForUriUnpacked
175 :: MonadObelisk m
176 => GitUri
177 -> m NixSha256
178getNixSha256ForUriUnpacked uri =
179 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
180 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
181 proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
182 pure hash
184nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
185nixPrefetchGit uri rev fetchSubmodules =
186 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
187 out <- readProcessAndLogStderr Debug $
188 proc nixPrefetchGitPath $ filter (/="")
189 [ "--url", T.unpack $ gitUriToText uri
190 , "--rev", T.unpack rev
191 , if fetchSubmodules then "--fetch-submodules" else ""
192 , "--quiet"
193 ]
195 case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of
196 Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
197 Just x -> pure x
199--TODO: Pretty print these
200data ReadThunkError
201 = ReadThunkError_UnrecognizedThunk
202 | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
203 | ReadThunkError_MissingPaths (NonEmpty FilePath)
204 | ReadThunkError_UnparseablePtr FilePath String
205 | ReadThunkError_FileError IOError
206 | ReadThunkError_FileDoesNotMatch FilePath Text
207 | ReadThunkError_UnrecognizedState String
208 | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
209 deriving (Show)
211unpackedDirName :: FilePath
212unpackedDirName = "."
214attrCacheFileName :: FilePath
215attrCacheFileName = ".attr-cache"
217-- | Specification for how a file in a thunk version works.
218data ThunkFileSpec
219 = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
220 | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
221 | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
222 | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
224-- | Specification for how a set of files in a thunk version work.
225data ThunkSpec = ThunkSpec
226 { _thunkSpec_name :: !Text
227 , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
228 }
230thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
231thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
233-- | Attempts to match a 'ThunkSpec' to a given directory.
234matchThunkSpecToDir
235 :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
236 => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
237 -> FilePath -- ^ Path to directory
238 -> Set FilePath -- ^ Set of file paths relative to the given directory
239 -> m ThunkData
240matchThunkSpecToDir thunkSpec dir dirFiles = do
241 case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
242 Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
243 Nothing -> pure ()
244 case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
245 Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
246 Nothing -> pure ()
247 datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
248 ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
249 ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
250 False -> Nothing
251 True -> Just ThunkData_Checkout
252 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
253 actualContents <- liftIO (T.readFile $ dir </> expectedPath)
254 case T.strip expectedContents == T.strip actualContents of
255 True -> pure Nothing
256 False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
257 ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
258 let path = dir </> expectedPath
259 liftIO (doesFileExist path) >>= \case
260 False -> pure Nothing
261 True -> do
262 actualContents <- liftIO $ LBS.readFile path
263 case parser actualContents of
264 Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
265 Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
267 case nonEmpty datas of
268 Nothing -> throwError ReadThunkError_UnrecognizedThunk
269 Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
270 where
271 rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272 takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
274 expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
276 requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
277 isRequiredFileSpec = \case
278 ThunkFileSpec_FileMatches _ -> True
279 _ -> False
281 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
282 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
283 False -> pure ()
285 -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
286 mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout
287 mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked
288 mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked
289 mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) =
290 if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB
292 bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
294 fold1WithM (x :| xs) f = foldM f x xs
296readThunkWith
297 :: (MonadObelisk m)
298 => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
299readThunkWith specTypes dir = do
300 dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
301 let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
302 flip fix specs $ \loop -> \case
303 [] -> pure $ Left ReadThunkError_UnrecognizedThunk
304 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
305 Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
306 x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
308-- | Read a thunk and validate that it is exactly a packed thunk.
309-- If additional data is present, fail.
310readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
311readThunk = readThunkWith thunkSpecTypes
313parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
314parseThunkPtr parseSrc v = do
315 rev <- v Aeson..: "rev"
316 sha256 <- v Aeson..: "sha256"
317 src <- parseSrc v
318 pure $ ThunkPtr
319 { _thunkPtr_rev = ThunkRev
320 { _thunkRev_commit = Ref.fromHexString rev
321 , _thunkRev_nixSha256 = sha256
322 }
323 , _thunkPtr_source = src
324 }
326parseGitHubSource :: Aeson.Object -> Aeson.Parser GitHubSource
327parseGitHubSource v = do
328 owner <- v Aeson..: "owner"
329 repo <- v Aeson..: "repo"
330 branch <- v Aeson..:! "branch"
331 private <- v Aeson..:? "private"
332 pure $ GitHubSource
333 { _gitHubSource_owner = owner
334 , _gitHubSource_repo = repo
335 , _gitHubSource_branch = branch
336 , _gitHubSource_private = fromMaybe False private
337 }
339parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
340parseGitSource v = do
341 Just url <- parseGitUri <$> v Aeson..: "url"
342 branch <- v Aeson..:! "branch"
343 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
344 private <- v Aeson..:? "private"
345 pure $ GitSource
346 { _gitSource_url = url
347 , _gitSource_branch = branch
348 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
349 , _gitSource_private = fromMaybe False private
350 }
352overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
353overwriteThunk target thunk = do
354 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
355 readThunk target >>= \case
356 Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
357 Right _ -> pure ()
359 --TODO: Is there a safer way to do this overwriting?
360 liftIO $ removePathForcibly target
361 createThunk target $ Right thunk
363thunkPtrToSpec :: ThunkPtr -> ThunkSpec
364thunkPtrToSpec thunk = case _thunkPtr_source thunk of
365 ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
366 ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
368-- It's important that formatting be very consistent here, because
369-- otherwise when people update thunks, their patches will be messy
370encodeThunkPtrData :: ThunkPtr -> LBS.ByteString
371encodeThunkPtrData (ThunkPtr rev src) = case src of
372 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
373 [ Just $ "owner" .= _gitHubSource_owner s
374 , Just $ "repo" .= _gitHubSource_repo s
375 , ("branch" .=) <$> _gitHubSource_branch s
376 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
377 , Just $ "sha256" .= _thunkRev_nixSha256 rev
378 , Just $ "private" .= _gitHubSource_private s
379 ]
380 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
381 [ Just $ "url" .= gitUriToText (_gitSource_url s)
382 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
383 , ("branch" .=) <$> _gitSource_branch s
384 , Just $ "sha256" .= _thunkRev_nixSha256 rev
385 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
386 , Just $ "private" .= _gitSource_private s
387 ]
388 where
389 githubCfg = defConfig
390 { confIndent = Spaces 2
391 , confCompare = keyOrder
392 [ "owner"
393 , "repo"
394 , "branch"
395 , "private"
396 , "rev"
397 , "sha256"
398 ] <> compare
399 , confTrailingNewline = True
400 }
401 plainGitCfg = defConfig
402 { confIndent = Spaces 2
403 , confCompare = keyOrder
404 [ "url"
405 , "rev"
406 , "sha256"
407 , "private"
408 , "fetchSubmodules"
409 ] <> compare
410 , confTrailingNewline = True
411 }
413createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
414createThunk target ptrInfo =
415 ifor_ (_thunkSpec_files spec) $ \path -> \case
416 ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
417 ThunkFileSpec_Ptr _ -> case ptrInfo of
418 Left _ -> pure () -- We can't write the ptr without it
419 Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
420 _ -> pure ()
421 where
422 spec = either id thunkPtrToSpec ptrInfo
423 withReadyPath path f = do
424 let fullPath = target </> path
425 putLog Debug $ "Writing thunk file " <> T.pack fullPath
426 liftIO $ createDirectoryIfMissing True $ takeDirectory fullPath
427 f fullPath
429createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
430createThunkWithLatest target s = do
431 rev <- getLatestRev s
432 createThunk target $ Right $ ThunkPtr
433 { _thunkPtr_source = s
434 , _thunkPtr_rev = rev
435 }
437updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
438updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
439 checkThunkDirectory target
440 -- check to see if thunk should be updated to a specific branch or just update it's current branch
441 case mBranch of
442 Nothing -> do
443 (overwrite, ptr) <- readThunk target >>= \case
444 Left err -> failWith [i|Thunk update: ${err}|]
445 Right c -> case c of
446 ThunkData_Packed _ t -> return (target, t)
447 ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
448 let src = _thunkPtr_source ptr
449 rev <- getLatestRev src
450 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
451 { _thunkPtr_source = src
452 , _thunkPtr_rev = rev
453 }
454 Just branch -> readThunk target >>= \case
455 Left err -> failWith [i|Thunk update: ${err}|]
456 Right c -> case c of
457 ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
458 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.|]
459 where
460 spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
462setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
463setThunk thunkConfig target gs branch = do
464 newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing
465 overwriteThunk target newThunkPtr
466 updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
468-- | All recognized github standalone loaders, ordered from newest to oldest.
469-- This tool will only ever produce the newest one when it writes a thunk.
470gitHubThunkSpecs :: NonEmpty ThunkSpec
471gitHubThunkSpecs =
472 gitHubThunkSpecV5 :|
473 [ gitHubThunkSpecV4
474 , gitHubThunkSpecV3
475 , gitHubThunkSpecV2
476 , gitHubThunkSpecV1
477 ]
479gitHubThunkSpecV1 :: ThunkSpec
480gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
481 "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
483gitHubThunkSpecV2 :: ThunkSpec
484gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
485 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
488 , " in { inherit (json) owner repo rev sha256;"
489 , " private = json.private or false;"
490 , " }"
491 , "))"
492 ]
494gitHubThunkSpecV3 :: ThunkSpec
495gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
496 [ "# DO NOT HAND-EDIT THIS FILE"
497 , "let"
498 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
499 , " then fetchFromGitHubPrivate args"
500 , " else (import <nixpkgs> {}).fetchFromGitHub (builtins.removeAttrs args [\"branch\"]);"
501 , " fetchFromGitHubPrivate ="
502 , " { owner, repo, rev, branch ? null, name ? null, sha256 ? null, private ? false"
503 , " , fetchSubmodules ? false, githubBase ? \"github.com\", ..."
504 , " }: assert !fetchSubmodules;"
505 , " builtins.fetchGit ({"
506 , " url = \"ssh://git@${githubBase}/${owner}/${repo}.git\";"
507 , " inherit rev;"
508 , " }"
509 , " // (if branch == null then {} else { ref = branch; })"
510 , " // (if name == null then {} else { inherit name; }));"
511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
512 ]
514gitHubThunkSpecV4 :: ThunkSpec
515gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
516 [ "# DO NOT HAND-EDIT THIS FILE"
517 , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
518 , " if !fetchSubmodules && !private then builtins.fetchTarball {"
519 , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
520 , " } else (import <nixpkgs> {}).fetchFromGitHub {"
521 , " inherit owner repo rev sha256 fetchSubmodules private;"
522 , " };"
523 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
524 ]
526legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
527legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
528 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
529 , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
530 , (attrCacheFileName, ThunkFileSpec_AttrCache)
531 , (".git", ThunkFileSpec_CheckoutIndicator)
532 ]
534gitHubThunkSpecV5 :: ThunkSpec
535gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|
536# DO NOT HAND-EDIT THIS FILE
537let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
538 if !fetchSubmodules && !private then builtins.fetchTarball {
539 url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
540 } else (import <nixpkgs> {}).fetchFromGitHub {
541 inherit owner repo rev sha256 fetchSubmodules private;
542 };
543 json = builtins.fromJSON (builtins.readFile ./github.json);
544in fetch json
545|]
547parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
548parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->
549 ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
551gitThunkSpecs :: NonEmpty ThunkSpec
552gitThunkSpecs =
553 gitThunkSpecV5 :|
554 [ gitThunkSpecV4
555 , gitThunkSpecV3
556 , gitThunkSpecV2
557 , gitThunkSpecV1
558 ]
560gitThunkSpecV1 :: ThunkSpec
561gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
562 [ "# DO NOT HAND-EDIT THIS FILE"
563 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
564 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
565 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
566 ]
568gitThunkSpecV2 :: ThunkSpec
569gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
570 [ "# DO NOT HAND-EDIT THIS FILE"
571 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
572 , " if builtins.hasAttr \"fetchGit\" builtins"
573 , " then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"
574 , " else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"
575 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
576 ]
578-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
579-- and will fail to find commits without this because it does shallow clones.
580gitThunkSpecV3 :: ThunkSpec
581gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
582 [ "# DO NOT HAND-EDIT THIS FILE"
583 , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
584 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
585 , " if firstChar == \"/\" then /. + url"
586 , " else if firstChar == \".\" then ./. + url"
587 , " else url;"
588 , " in if !fetchSubmodules && private then builtins.fetchGit {"
589 , " url = realUrl; inherit rev;"
590 , " } else (import <nixpkgs> {}).fetchgit {"
591 , " url = realUrl; inherit rev sha256;"
592 , " };"
593 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
594 ]
596gitThunkSpecV4 :: ThunkSpec
597gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines
598 [ "# DO NOT HAND-EDIT THIS FILE"
599 , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
600 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
601 , " if firstChar == \"/\" then /. + url"
602 , " else if firstChar == \".\" then ./. + url"
603 , " else url;"
604 , " in if !fetchSubmodules && private then builtins.fetchGit {"
605 , " url = realUrl; inherit rev;"
606 , " ${if branch == null then null else \"ref\"} = branch;"
607 , " } else (import <nixpkgs> {}).fetchgit {"
608 , " url = realUrl; inherit rev sha256;"
609 , " };"
610 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
611 ]
613legacyGitThunkSpec :: Text -> Text -> ThunkSpec
614legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList
615 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
616 , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
617 , (attrCacheFileName, ThunkFileSpec_AttrCache)
618 , (".git", ThunkFileSpec_CheckoutIndicator)
619 ]
621gitThunkSpecV5 :: ThunkSpec
622gitThunkSpecV5 = mkThunkSpec "git-v5" "git.json" parseGitJsonBytes [here|
623# DO NOT HAND-EDIT THIS FILE
624let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
625 let realUrl = let firstChar = builtins.substring 0 1 url; in
626 if firstChar == "/" then /. + url
627 else if firstChar == "." then ./. + url
628 else url;
629 in if !fetchSubmodules && private then builtins.fetchGit {
630 url = realUrl; inherit rev;
631 ${if branch == null then null else "ref"} = branch;
632 } else (import <nixpkgs> {}).fetchgit {
633 url = realUrl; inherit rev sha256;
634 };
635 json = builtins.fromJSON (builtins.readFile ./git.json);
636in fetch json
637|]
639parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
640parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
642mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
643mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
644 [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
645 , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)
646 , (jsonFileName, ThunkFileSpec_Ptr parser)
647 , (attrCacheFileName, ThunkFileSpec_AttrCache)
648 , (normalise $ unpackedDirName </> ".git", ThunkFileSpec_CheckoutIndicator)
649 ]
650 where
651 defaultNixViaSrc = [here|
652# DO NOT HAND-EDIT THIS FILE
653import (import ./thunk.nix)
654|]
657parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
658parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
660-- | Checks a cache directory to see if there is a fresh symlink
661-- to the result of building an attribute of a thunk.
662-- If no cache hit is found, nix-build is called to build the attribute
663-- and the result is symlinked into the cache.
664nixBuildThunkAttrWithCache
665 :: MonadObelisk m
666 => ThunkSpec
667 -> FilePath
668 -- ^ Path to directory containing Thunk
669 -> String
670 -- ^ Attribute to build
671 -> m (Maybe FilePath)
672 -- ^ Symlink to cached or built nix output
673-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
674-- the caching mechanism will fail as it merely measures the modification
675-- time of the cache link and the expression to build.
676nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
677 latestChange <- liftIO $ do
678 let
679 getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
680 thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
681 maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
683 let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
684 _thunkSpec_files thunkSpec
685 for cachePaths' $ \cachePaths ->
686 fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
687 let
688 cachePath = thunkDir </> cacheDir </> attr <.> "out"
689 cacheErrHandler e
690 | isDoesNotExistError e = pure Nothing -- expected from a cache miss
691 | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
692 cacheHit <- handle cacheErrHandler $ do
693 cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
694 pure $ if latestChange <= cacheTime
695 then Just cachePath
696 else Nothing
697 case cacheHit of
698 Just c -> pure c
699 Nothing -> do
700 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
701 liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
702 (cachePath <$) $ nixCmd $ NixCmd_Build $ def
703 & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath
704 & nixCmdConfig_target .~ Target
705 { _target_path = Just thunkDir
706 , _target_attr = Just attr
707 , _target_expr = Nothing
708 }
710-- | Build a nix attribute, and cache the result if possible
711nixBuildAttrWithCache
712 :: MonadObelisk m
713 => FilePath
714 -- ^ Path to directory containing Thunk
715 -> String
716 -- ^ Attribute to build
717 -> m FilePath
718 -- ^ Symlink to cached or built nix output
719nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
720 -- Only packed thunks are cached. In particular, checkouts are not.
721 Right (ThunkData_Packed spec _) ->
722 maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
723 _ -> build
724 where
725 build = nixCmd $ NixCmd_Build $ def
726 & nixBuildConfig_outLink .~ OutLink_None
727 & nixCmdConfig_target .~ Target
728 { _target_path = Just exprPath
729 , _target_attr = Just attr
730 , _target_expr = Nothing
731 }
733-- | Safely update thunk using a custom action
734--
735-- A temporary working space is used to do any update. When the custom
736-- action successfully completes, the resulting (packed) thunk is copied
737-- back to the original location.
738updateThunk :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
739updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
740 p' <- copyThunkToTmp tmpDir p
741 unpackThunk' True p'
742 result <- f p'
743 updateThunkFromTmp p'
744 return result
745 where
746 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
747 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
748 Right ThunkData_Packed{} -> do
749 let tmpThunk = tmpDir </> "thunk"
750 callProcessAndLogOutput (Notice, Error) $
751 proc cp ["-r", "-T", thunkDir, tmpThunk]
752 return tmpThunk
753 Right _ -> failWith "Thunk is not packed"
754 updateThunkFromTmp p' = do
755 _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
756 callProcessAndLogOutput (Notice, Error) $
757 proc cp ["-r", "-T", p', p]
759finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
760finalMsg noTrail s = if noTrail then Nothing else Just s
762-- | Check that we are not somewhere inside the thunk directory
763checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764checkThunkDirectory thunkDir = do
765 currentDir <- liftIO getCurrentDirectory
766 thunkDir' <- liftIO $ canonicalizePath thunkDir
767 when (thunkDir' `L.isInfixOf` currentDir) $
768 failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
770 -- Don't let thunk commands work when directly given an unpacked repo
771 when (takeFileName thunkDir == unpackedDirName) $
772 readThunk (takeDirectory thunkDir) >>= \case
773 Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
774 Left _ -> pure ()
776unpackThunk :: MonadObelisk m => FilePath -> m ()
777unpackThunk = unpackThunk' False
779unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
780unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
781 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
782 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
783 Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
784 Right (ThunkData_Packed _ tptr) -> do
785 let (thunkParent, thunkName) = splitFileName thunkDir
786 withTempDirectory thunkParent thunkName $ \tmpThunk -> do
787 let
788 gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
789 newSpec = case _thunkPtr_source tptr of
790 ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
791 ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
792 withSpinner' ("Fetching thunk " <> T.pack thunkName)
793 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
794 let unpackedPath = tmpThunk </> unpackedDirName
795 gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
797 let normalizeMore = dropTrailingPathSeparator . normalise
798 when (normalizeMore unpackedPath /= normalizeMore tmpThunk) $ -- Only write meta data if the checkout is not inplace
799 createThunk tmpThunk $ Left newSpec
801 liftIO $ do
802 removePathForcibly thunkDir
803 renameDirectory tmpThunk thunkDir
805gitCloneForThunkUnpack
806 :: MonadObelisk m
807 => GitSource -- ^ Git source to use
808 -> Ref hash -- ^ Commit hash to reset to
809 -> FilePath -- ^ Directory to clone into
810 -> m ()
811gitCloneForThunkUnpack gitSrc commit dir = do
812 let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
813 git $ [ "clone" ]
814 ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
815 ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
816 ++ do branch <- maybeToList $ _gitSource_branch gitSrc
817 [ "--branch", T.unpack $ untagName branch ]
818 git ["reset", "--hard", Ref.toHexString commit]
819 when (_gitSource_fetchSubmodules gitSrc) $
820 git ["submodule", "update", "--recursive", "--init"]
822--TODO: add a rollback mode to pack to the original thunk
823packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
824packThunk = packThunk' False
826packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
827packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
828 Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
829 _ -> withSpinner'
830 ("Packing thunk " <> T.pack thunkDir)
831 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
832 do
833 let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
834 thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
835 liftIO $ removePathForcibly thunkDir
836 createThunk thunkDir $ Right thunkPtr
837 pure thunkPtr
839modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
840modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
841 Nothing -> ptr
842 Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of
843 ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }
844 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
845 }
847data CheckClean
848 = CheckClean_FullCheck
849 -- ^ Check that the repo is clean, including .gitignored files
850 | CheckClean_NotIgnored
851 -- ^ Check that the repo is clean, not including .gitignored files
852 | CheckClean_NoCheck
853 -- ^ Don't check that the repo is clean
855getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
856getThunkPtr gitCheckClean dir mPrivate = do
857 let repoLocations = nubOrd $ map (first normalise)
858 [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]
859 repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
860 thunkDir <- case repoLocation' of
861 Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
862 Just (_, path) -> pure $ normalise $ dir </> path
864 let (checkClean, checkIgnored) = case gitCheckClean of
865 CheckClean_FullCheck -> (True, True)
866 CheckClean_NotIgnored -> (True, False)
867 CheckClean_NoCheck -> (False, False)
868 when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
869 "thunk pack: thunk checkout contains unsaved modifications"
871 -- Check whether there are any stashes
872 when checkClean $ do
873 stashOutput <- readGitProcess thunkDir ["stash", "list"]
874 unless (T.null stashOutput) $
875 failWith $ T.unlines $
876 [ "thunk pack: thunk checkout has stashes"
877 , "git stash list:"
878 ] ++ T.lines stashOutput
880 -- Get current branch
881 (mCurrentBranch, mCurrentCommit) <- do
882 b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
883 c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
884 case b of
885 (Just "HEAD") -> failWith $ T.unlines
886 [ "thunk pack: You are in 'detached HEAD' state."
887 , "If you want to pack at the current ref \
888 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
889 ]
890 _ -> return (b, c)
892 -- Get information on all branches and their (optional) designated upstream
893 -- correspondents
894 headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
895 [ "for-each-ref"
896 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
897 , "refs/heads/"
898 ]
900 (headInfo :: Map Text (Maybe (Text, Text)))
901 <- fmap Map.fromList $ forM headDump $ \line -> do
902 (branch : restOfLine) <- pure $ T.words line
903 mUpstream <- case restOfLine of
904 [] -> pure Nothing
905 [u, r] -> pure $ Just (u, r)
906 (_:_) -> failWith "git for-each-ref invalid output"
907 pure (branch, mUpstream)
909 putLog Debug $ "branches: " <> T.pack (show headInfo)
911 let errorMap :: Map Text ()
912 headUpstream :: Map Text (Text, Text)
913 (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
914 Nothing -> Left ()
915 Just b -> Right b
917 putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)
919 -- Check that every branch has a remote equivalent
920 when checkClean $ do
921 let untrackedBranches = Map.keys errorMap
922 when (not $ L.null untrackedBranches) $ failWith $ T.unlines $
923 [ "thunk pack: Certain branches in the thunk have no upstream branch \
924 \set. This means we don't know to check whether all your work is \
925 \saved. The offending branches are:"
926 , ""
927 , T.unwords untrackedBranches
928 , ""
929 , "To fix this, you probably want to do:"
930 , ""
931 ] ++
932 ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++
933 [ ""
934 , "These will push the branches to the default remote under the same \
935 \name, and (thanks to the `-u`) remember that choice so you don't \
936 \get this error again."
937 ]
939 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
940 stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
941 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
942 [ "rev-list", "--left-right"
943 , T.unpack branch <> "..." <> T.unpack upstream
944 ]
945 let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
946 behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
947 pure (upstream, (ahead, behind))
949 -- Those branches which have commits ahead of, i.e. not on, the upstream
950 -- branch. Purely being behind is fine.
951 let nonGood = Map.filter ((/= 0) . fst . snd) stats
953 when (not $ Map.null nonGood) $ failWith $ T.unlines $
954 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
955 , ""
956 ] ++
957 flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
958 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
959 [ ""
960 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
961 \pushed but this repo's remote tracking branches don't know it.)"
962 ]
964 when checkClean $ do
965 -- We assume it's safe to pack the thunk at this point
966 putLog Informational "All changes safe in git remotes. OK to pack thunk."
968 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
970 [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
971 [ "config"
972 , "--get"
973 , "remote." <> T.unpack remote <> ".url"
974 ]
976 remoteUri <- case parseGitUri remoteUri' of
977 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
978 Just uri -> pure uri
979 uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
981-- | Get the latest revision available from the given source
982getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
983getLatestRev os = do
984 let gitS = thunkSourceToGitSource os
985 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
986 case os of
987 ThunkSource_GitHub s -> githubThunkRev s commit
988 ThunkSource_Git s -> gitThunkRev s commit
990-- | Convert a URI to a thunk
991--
992-- If the URL is a github URL, we try to just download an archive for
993-- performance. If that doesn't work (e.g. authentication issue), we fall back
994-- on just doing things the normal way for git repos in general, and save it as
995-- a regular git thunk.
996uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
997uriThunkPtr uri mPrivate mbranch mcommit = do
998 commit <- case mcommit of
999 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
1000 (Just c) -> return c
1001 (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
1002 ThunkSource_GitHub s -> do
1003 rev <- runExceptT $ githubThunkRev s commit
1004 case rev of
1005 Right r -> pure (ThunkSource_GitHub s, r)
1006 Left e -> do
1007 putLog Warning "\
1008\Failed to fetch archive from GitHub. This is probably a private repo. \
1009\Falling back on normal fetchgit. Original failure:"
1010 errorToWarning e
1011 let s' = forgetGithub True s
1012 (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
1013 ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
1014 pure $ ThunkPtr
1015 { _thunkPtr_rev = rev
1016 , _thunkPtr_source = src
1019-- | N.B. Cannot infer all fields.
1021-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
1022-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
1023-- should be employed, and so we respect that.
1024uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
1025uriToThunkSource (GitUri u) mPrivate
1026 | Right uriAuth <- URI.uriAuthority u
1027 , Just scheme <- URI.unRText <$> URI.uriScheme u
1028 , case scheme of
1029 "ssh" -> uriAuth == URI.Authority
1030 { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
1031 , URI.authHost = fromRight' $ URI.mkHost "github.com"
1032 , URI.authPort = Nothing
1034 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
1035 && URI.unRText (URI.authHost uriAuth) == "github.com"
1036 , Just (_, owner :| [repoish]) <- URI.uriPath u
1037 = \mbranch -> do
1038 isPrivate <- getIsPrivate
1039 pure $ ThunkSource_GitHub $ GitHubSource
1040 { _gitHubSource_owner = N $ URI.unRText owner
1041 , _gitHubSource_repo = N $ let
1042 repoish' = URI.unRText repoish
1043 in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
1044 , _gitHubSource_branch = N <$> mbranch
1045 , _gitHubSource_private = isPrivate
1048 | otherwise = \mbranch -> do
1049 isPrivate <- getIsPrivate
1050 pure $ ThunkSource_Git $ GitSource
1051 { _gitSource_url = GitUri u
1052 , _gitSource_branch = N <$> mbranch
1053 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
1054 , _gitSource_private = isPrivate
1056 where
1057 getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
1059guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
1060guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
1061 [] -> pure True
1062 uriAttempt:xs -> do
1063 result <- readCreateProcessWithExitCode $
1064 isolateGitProc $
1065 gitProcNoRepo
1066 [ "ls-remote"
1067 , "--quiet"
1068 , "--exit-code"
1069 , "--symref"
1070 , T.unpack $ gitUriToText uriAttempt
1072 case result of
1073 (ExitSuccess, _, _) -> pure False -- Must be a public repo
1074 _ -> loop xs
1075 where
1076 urisToTry = nubOrd $
1077 -- Include the original URI if it isn't using SSH because SSH will certainly fail.
1078 [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>
1079 [changeScheme "https" uri, changeScheme "http" uri]
1080 changeScheme scheme (GitUri u) = GitUri $ u
1081 { URI.uriScheme = URI.mkScheme scheme
1082 , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u
1085-- Funny signature indicates no effects depend on the optional branch name.
1086githubThunkRev
1087 :: forall m
1088 . MonadObelisk m
1089 => GitHubSource
1090 -> Text
1091 -> m ThunkRev
1092githubThunkRev s commit = do
1093 owner <- forcePP $ _gitHubSource_owner s
1094 repo <- forcePP $ _gitHubSource_repo s
1095 revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
1096 let archiveUri = GitUri $ URI.URI
1097 { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
1098 , URI.uriAuthority = Right $ URI.Authority
1099 { URI.authUserInfo = Nothing
1100 , URI.authHost = fromRight' $ URI.mkHost "github.com"
1101 , URI.authPort = Nothing
1103 , URI.uriPath = Just ( False
1104 , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
1106 , URI.uriQuery = []
1107 , URI.uriFragment = Nothing
1109 hash <- getNixSha256ForUriUnpacked archiveUri
1110 putLog Debug $ "Nix sha256 is " <> hash
1111 return $ ThunkRev
1112 { _thunkRev_commit = commitNameToRef $ N commit
1113 , _thunkRev_nixSha256 = hash
1115 where
1116 forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
1117 forcePP = URI.mkPathPiece . untagName
1119gitThunkRev
1120 :: MonadObelisk m
1121 => GitSource
1122 -> Text
1123 -> m ThunkRev
1124gitThunkRev s commit = do
1125 let u = _gitSource_url s
1126 protocols = ["file", "https", "ssh", "git"]
1127 scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
1128 unless (T.toLower scheme `elem` protocols) $
1129 failWith $ "obelisk currently only supports "
1130 <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
1131 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
1132 putLog Informational $ "Nix sha256 is " <> hash
1133 pure $ ThunkRev
1134 { _thunkRev_commit = commitNameToRef (N commit)
1135 , _thunkRev_nixSha256 = hash
1138-- | Given the URI to a git remote, and an optional branch name, return the name
1139-- of the branch along with the hash of the commit at tip of that branch.
1141-- If the branch name is passed in, it is returned exactly as-is. If it is not
1142-- passed it, the default branch of the repo is used instead.
1144gitGetCommitBranch
1145 :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
1146gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
1147 (_, bothMaps) <- gitLsRemote
1148 (T.unpack $ gitUriToText uri)
1149 (GitRef_Branch <$> mbranch)
1150 Nothing
1151 branch <- case mbranch of
1152 Nothing -> withExitFailMessage "Failed to find default branch" $ do
1153 b <- rethrowE $ gitLookupDefaultBranch bothMaps
1154 putLog Debug $ "Default branch for remote repo " <> uriMsg <> " is " <> b
1155 pure b
1156 Just b -> pure b
1157 commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)
1158 putLog Informational $ "Latest commit in branch " <> branch
1159 <> " from remote repo " <> uriMsg
1160 <> " is " <> commit
1161 pure (branch, commit)
1162 where
1163 rethrowE = either failWith pure
1164 uriMsg = gitUriToText uri
1166parseGitUri :: Text -> Maybe GitUri
1167parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
1169parseFileURI :: Text -> Maybe URI.URI
1170parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
1172parseAbsoluteURI :: Text -> Maybe URI.URI
1173parseAbsoluteURI uri = do
1174 parsedUri <- URI.mkURI uri
1175 guard $ URI.isPathAbsolute parsedUri
1176 pure parsedUri
1178parseSshShorthand :: Text -> Maybe URI.URI
1179parseSshShorthand uri = do
1180 -- This is what git does to check that the remote
1181 -- is not a local file path when parsing shorthand.
1182 -- Last referenced from here:
1183 -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
1184 let
1185 (authAndHostname, colonAndPath) = T.break (== ':') uri
1186 properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
1187 -- Shorthand is valid iff a colon is present and it occurs before the first slash
1188 -- This check is used to disambiguate a filepath containing a colon from shorthand
1189 guard $ isNothing (T.findIndex (=='/') authAndHostname)
1190 && not (T.null colonAndPath)
1191 URI.mkURI properUri