git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/command/src/Obelisk/Command/Thunk.hs
935 lines 37 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 ScopedTypeVariables #-}
9{-# LANGUAGE TypeApplications #-}
10module Obelisk.Command.Thunk
11 ( ThunkPtr (..)
12 , ThunkRev (..)
13 , ThunkSource (..)
14 , ThunkData (..)
15 , ReadThunkError (..)
16 , GitHubSource (..)
17 , getThunkGitBranch
18 , getLatestRev
19 , updateThunkToLatest
20 , createThunk
21 , createThunkWithLatest
22 , nixBuildAttrWithCache
23 , nixBuildThunkAttrWithCache
24 , unpackThunk
25 , packThunk
26 , readThunk
27 , updateThunk
28 , getThunkPtr
29 , parseGitUri
30 , uriThunkPtr
31 ) where
33import Control.Applicative
34import Control.Exception (displayException, try)
35import qualified Control.Lens as Lens
36import Control.Lens.Indexed hiding ((<.>))
37import Control.Monad
38import Control.Monad.Catch (handle)
39import Control.Monad.Except
40import Data.Aeson ((.=))
41import qualified Data.Aeson as Aeson
42import Data.Aeson.Encode.Pretty
43import qualified Data.Aeson.Types as Aeson
44import qualified Data.ByteString.Lazy as LBS
45import Data.Default
46import Data.Either.Combinators (fromRight', rightToMaybe)
47import Data.Git.Ref (Ref)
48import qualified Data.Git.Ref as Ref
49import qualified Data.List as L
50import Data.List.NonEmpty (NonEmpty (..))
51import qualified Data.List.NonEmpty as NonEmpty
52import Data.Map (Map)
53import qualified Data.Map as Map
54import Data.Maybe
55import Data.Set (Set)
56import qualified Data.Set as Set
57import Data.Text (Text)
58import qualified Data.Text as T
59import Data.Text.Encoding
60import qualified Data.Text.IO as T
61import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
62import Data.Yaml (parseMaybe)
63import GitHub
64import GitHub.Data.Name
65import Obelisk.Command.Nix
66import System.Directory
67import System.FilePath
68import System.IO.Error
69import System.IO.Temp
70import System.Posix (getSymbolicLinkStatus, modificationTime)
71import System.Process (proc)
72import Text.URI
74import Obelisk.App (MonadObelisk)
75import Obelisk.CliApp
76import Obelisk.Command.Utils
78--TODO: Support symlinked thunk data
79data ThunkData
80 = ThunkData_Packed ThunkPtr
81 -- ^ Packed thunk
82 | ThunkData_Checkout (Maybe ThunkPtr)
83 -- ^ Checked out thunk that was unpacked from this pointer
84 deriving (Show, Eq, Ord)
86-- | A reference to the exact data that a thunk should translate into
87data ThunkPtr = ThunkPtr
88 { _thunkPtr_rev :: ThunkRev
89 , _thunkPtr_source :: ThunkSource
90 }
91 deriving (Show, Eq, Ord)
93type NixSha256 = Text --TODO: Use a smart constructor and make this actually verify itself
95-- | A specific revision of data; it may be available from multiple sources
96data ThunkRev = ThunkRev
97 { _thunkRev_commit :: Ref
98 , _thunkRev_nixSha256 :: NixSha256
99 }
100 deriving (Show, Eq, Ord)
102-- | A location from which a thunk's data can be retrieved
103data ThunkSource
104 -- | A source specialized for GitHub
105 = ThunkSource_GitHub GitHubSource
106 -- | A plain repo source
107 | ThunkSource_Git GitSource
108 deriving (Show, Eq, Ord)
110data GitHubSource = GitHubSource
111 { _gitHubSource_owner :: Name Owner
112 , _gitHubSource_repo :: Name Repo
113 , _gitHubSource_branch :: Maybe (Name Branch)
114 }
115 deriving (Show, Eq, Ord)
117data GitSource = GitSource
118 { _gitSource_url :: URI
119 , _gitSource_branch :: Maybe (Name Branch)
120 , _gitSource_fetchSubmodules :: Bool
121 }
122 deriving (Show, Eq, Ord)
124-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
125forgetGithub :: Bool -> GitHubSource -> GitSource
126forgetGithub useSsh s = GitSource
127 { _gitSource_url = URI
128 { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"
129 , uriAuthority = Right $ Authority
130 { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing
131 <$ guard useSsh
132 , authHost = fromRight' $ mkHost "github.com"
133 , authPort = Nothing
134 }
135 , uriPath = Just ( False
136 , fromRight' . mkPathPiece <$>
137 untagName (_gitHubSource_owner s)
138 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
139 )
140 , uriQuery = []
141 , uriFragment = Nothing
142 }
143 , _gitSource_branch = _gitHubSource_branch s
144 , _gitSource_fetchSubmodules = False
145 }
147getThunkGitBranch :: ThunkPtr -> Maybe Text
148getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
149 ThunkSource_GitHub s -> _gitHubSource_branch s
150 ThunkSource_Git s -> _gitSource_branch s
152commitNameToRef :: Name Commit -> Ref
153commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
155-- TODO: Use spinner here.
156getNixSha256ForUriUnpacked
157 :: MonadObelisk m
158 => URI
159 -> m NixSha256
160getNixSha256ForUriUnpacked uri =
161 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do
162 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
163 proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]
164 pure hash
166nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
167nixPrefetchGit uri rev fetchSubmodules =
168 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do
169 out <- readProcessAndLogStderr Debug $
170 proc "nix-prefetch-git" $ filter (/="")
171 [ "--url", T.unpack $ render uri
172 , "--rev", T.unpack rev
173 , if fetchSubmodules then "--fetch-submodules" else ""
174 , "--quiet"
175 ]
177 case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of
178 Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
179 Just x -> pure x
181--TODO: Pretty print these
182data ReadThunkError
183 = ReadThunkError_UnrecognizedFiles
184 | ReadThunkError_AmbiguousFiles
185 | ReadThunkError_UnrecognizedLoader Text
186 | ReadThunkError_UnparseablePtr LBS.ByteString
187 deriving (Show)
189-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
190-- If the thunk is packed and additional data is present, fail.
191readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
192readThunk thunkDir = do
193 files <- liftIO $ listDirectory thunkDir
194 case ".git" `elem` files of
195 True -> fmap ThunkData_Checkout <$> do
196 let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
197 liftIO $ doesDirectoryExist origThunkPath >>= \case
198 True -> fmap Just <$> readPackedThunk origThunkPath
199 False -> return $ return Nothing
200 False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
202data ThunkType = ThunkType
203 { _thunkType_loader :: FilePath
204 , _thunkType_json :: FilePath
205 , _thunkType_optional :: Set FilePath
206 , _thunkType_loaderVersions :: NonEmpty Text
207 , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr
208 }
210gitHubThunkType :: ThunkType
211gitHubThunkType = ThunkType
212 { _thunkType_loader = "default.nix"
213 , _thunkType_json = "github.json"
214 , _thunkType_optional = Set.fromList [".attr-cache"]
215 , _thunkType_loaderVersions = gitHubStandaloneLoaders
216 , _thunkType_parser = parseThunkPtr $ \v ->
217 ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
218 }
220gitThunkType :: ThunkType
221gitThunkType = ThunkType
222 { _thunkType_loader = "default.nix"
223 , _thunkType_json = "git.json"
224 , _thunkType_optional = Set.fromList [".attr-cache"]
225 , _thunkType_loaderVersions = plainGitStandaloneLoaders
226 , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
227 }
229thunkTypes :: [ThunkType]
230thunkTypes = [gitThunkType, gitHubThunkType]
232findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)
233findThunkType types thunkDir = do
234 matches <- fmap catMaybes $ forM types $ \thunkType -> do
235 let
236 expectedContents = Set.fromList $ (thunkDir </>) <$>
237 [ _thunkType_loader thunkType
238 , _thunkType_json thunkType
239 ]
240 optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)
242 -- Ensure that there aren't any other files in the thunk
243 -- NB: System.Directory.listDirectory returns the contents without the directory path
244 files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
245 let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
246 missingContents = expectedContents `Set.difference` files
247 pure $ if Set.null unexpectedContents && Set.null missingContents
248 then Just thunkType
249 else Nothing
251 pure $ case matches of
252 [singleMatch] -> Right singleMatch
253 [] -> Left ReadThunkError_UnrecognizedFiles
254 _ -> Left ReadThunkError_AmbiguousFiles
256-- | Read a thunk and validate that it is exactly a packed thunk.
257-- If additional data is present, fail.
258readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
259readPackedThunk thunkDir = runExceptT $ do
260 thunkType <- ExceptT $ findThunkType thunkTypes thunkDir
261 -- Ensure that we recognize the thunk loader
262 loader <- liftIO $ T.readFile $ thunkDir </> _thunkType_loader thunkType
263 unless (loader `elem` _thunkType_loaderVersions thunkType) $ do
264 throwError $ ReadThunkError_UnrecognizedLoader loader
266 txt <- liftIO $ LBS.readFile $ thunkDir </> _thunkType_json thunkType
267 case parseMaybe (_thunkType_parser thunkType) =<< Aeson.decode txt of
268 Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
269 Just ptr -> return ptr
271parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
272parseThunkPtr parseSrc v = do
273 rev <- v Aeson..: "rev"
274 sha256 <- v Aeson..: "sha256"
275 src <- parseSrc v
276 pure $ ThunkPtr
277 { _thunkPtr_rev = ThunkRev
278 { _thunkRev_commit = Ref.fromHexString rev
279 , _thunkRev_nixSha256 = sha256
280 }
281 , _thunkPtr_source = src
282 }
284parseGitHubSource :: Aeson.Object -> Aeson.Parser GitHubSource
285parseGitHubSource v = do
286 owner <- v Aeson..: "owner"
287 repo <- v Aeson..: "repo"
288 branch <- v Aeson..:! "branch"
289 pure $ GitHubSource
290 { _gitHubSource_owner = owner
291 , _gitHubSource_repo = repo
292 , _gitHubSource_branch = branch
293 }
295parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
296parseGitSource v = do
297 Just url <- parseGitUri <$> v Aeson..: "url"
298 branch <- v Aeson..:! "branch"
299 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
300 pure $ GitSource
301 { _gitSource_url = url
302 , _gitSource_branch = branch
303 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
304 }
306overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
307overwriteThunk target thunk = do
308 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
309 Right _ <- readThunk target
311 --TODO: Is there a safer way to do this overwriting?
312 liftIO $ removeDirectoryRecursive target
313 liftIO $ createThunk target thunk
315thunkPtrLoader :: ThunkPtr -> Text
316thunkPtrLoader thunk = case _thunkPtr_source thunk of
317 ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
318 ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
320-- It's important that formatting be very consistent here, because
321-- otherwise when people update thunks, their patches will be messy
322encodeThunkPtrData :: ThunkPtr -> LBS.ByteString
323encodeThunkPtrData (ThunkPtr rev src) = case src of
324 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
325 [ Just $ "owner" .= _gitHubSource_owner s
326 , Just $ "repo" .= _gitHubSource_repo s
327 , ("branch" .=) <$> _gitHubSource_branch s
328 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
329 , Just $ "sha256" .= _thunkRev_nixSha256 rev
330 ]
331 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
332 [ Just $ "url" .= render (_gitSource_url s)
333 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
334 , ("branch" .=) <$> _gitSource_branch s
335 , Just $ "sha256" .= _thunkRev_nixSha256 rev
336 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
337 ]
338 where
339 githubCfg = defConfig
340 { confIndent = Spaces 2
341 , confCompare = keyOrder
342 [ "owner"
343 , "repo"
344 , "branch"
345 , "private"
346 , "rev"
347 , "sha256"
348 ] <> compare
349 , confTrailingNewline = True
350 }
351 plainGitCfg = defConfig
352 { confIndent = Spaces 2
353 , confCompare = keyOrder
354 [ "url"
355 , "rev"
356 , "sha256"
357 , "fetchSubmodules"
358 ] <> compare
359 , confTrailingNewline = True
360 }
362createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
363createThunk target thunk = liftIO $ do
364 createDirectoryIfMissing True (target </> ".attr-cache")
365 T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
366 let
367 jsonFileName = case _thunkPtr_source thunk of
368 ThunkSource_GitHub _ -> "github"
369 ThunkSource_Git _ -> "git"
370 LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)
372createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
373createThunkWithLatest target s = do
374 rev <- getLatestRev s
375 createThunk target $ ThunkPtr
376 { _thunkPtr_source = s
377 , _thunkPtr_rev = rev
378 }
380updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()
381updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
382 checkThunkDirectory "ob thunk update directory cannot be '.'" target
383 -- check to see if thunk should be updated to a specific branch or just update it's current branch
384 case mBranch of
385 Nothing -> do
386 (overwrite, ptr) <- readThunk target >>= \case
387 Left err -> failWith $ T.pack $ "thunk update: " <> show err
388 Right c -> case c of
389 ThunkData_Packed t -> return (target, t)
390 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
391 let src = _thunkPtr_source ptr
392 rev <- getLatestRev src
393 overwriteThunk overwrite $ ThunkPtr
394 { _thunkPtr_source = src
395 , _thunkPtr_rev = rev
396 }
397 Just branch -> readThunk target >>= \case
398 Left err -> failWith $ T.pack $ "thunk update: " <> show err
399 Right c -> case c of
400 ThunkData_Packed t -> case _thunkPtr_source t of
401 ThunkSource_Git tsg -> setThunk target tsg branch
402 ThunkSource_GitHub tsgh -> do
403 let tsg = forgetGithub False tsgh
404 setThunk target tsg branch
405 ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> (show target) <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."
407setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()
408setThunk target gs branch = do
409 newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing
410 overwriteThunk target newThunkPtr
411 updateThunkToLatest target Nothing
413-- | All recognized github standalone loaders, ordered from newest to oldest.
414-- This tool will only ever produce the newest one when it writes a thunk.
415gitHubStandaloneLoaders :: NonEmpty Text
416gitHubStandaloneLoaders =
417 gitHubStandaloneLoaderV2 :|
418 [ gitHubStandaloneLoaderV3
419 , gitHubStandaloneLoaderV1
420 ]
422gitHubStandaloneLoaderV1 :: Text
423gitHubStandaloneLoaderV1 = T.unlines
424 [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
425 ]
427gitHubStandaloneLoaderV2 :: Text
428gitHubStandaloneLoaderV2 = T.unlines
429 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
430 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
431 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
432 , " in { inherit (json) owner repo rev sha256;"
433 , " private = json.private or false;"
434 , " }"
435 , "))"
436 ]
438gitHubStandaloneLoaderV3 :: Text
439gitHubStandaloneLoaderV3 = T.unlines
440 [ "# DO NOT HAND-EDIT THIS FILE"
441 , "let"
442 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
443 , " then fetchFromGitHubPrivate args"
444 , " else (import <nixpkgs> {}).fetchFromGitHub (builtins.removeAttrs args [\"branch\"]);"
445 , " fetchFromGitHubPrivate ="
446 , " { owner, repo, rev, branch ? null, name ? null, sha256 ? null, private ? false"
447 , " , fetchSubmodules ? false, githubBase ? \"github.com\", ..."
448 , " }: assert !fetchSubmodules;"
449 , " builtins.fetchGit ({"
450 , " url = \"ssh://git@${githubBase}/${owner}/${repo}.git\";"
451 , " inherit rev;"
452 , " }"
453 , " // (if branch == null then {} else { ref = branch; })"
454 , " // (if name == null then {} else { inherit name; }));"
455 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
456 ]
458plainGitStandaloneLoaders :: NonEmpty Text
459plainGitStandaloneLoaders =
460 plainGitStandaloneLoaderV1 :|
461 [ plainGitStandaloneLoaderV2
462 ]
464plainGitStandaloneLoaderV1 :: Text
465plainGitStandaloneLoaderV1 = T.unlines
466 [ "# DO NOT HAND-EDIT THIS FILE"
467 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
468 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
469 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
470 ]
472plainGitStandaloneLoaderV2 :: Text
473plainGitStandaloneLoaderV2 = T.unlines
474 [ "# DO NOT HAND-EDIT THIS FILE"
475 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
476 , " if builtins.hasAttr \"fetchGit\" builtins"
477 , " then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"
478 , " else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"
479 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
480 ]
482thunkFileNames :: [FilePath]
483thunkFileNames = ["default.nix", "github.json", "git.json"]
485--TODO: when checking something out, make a shallow clone
487-- | Checks a cache directory to see if there is a fresh symlink
488-- to the result of building an attribute of a thunk.
489-- If no cache hit is found, nix-build is called to build the attribute
490-- and the result is symlinked into the cache.
491nixBuildThunkAttrWithCache
492 :: MonadObelisk m
493 => FilePath
494 -- ^ Path to directory containing Thunk
495 -> String
496 -- ^ Attribute to build
497 -> m FilePath
498 -- ^ Symlink to cached or built nix output
499-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
500-- the caching mechanism will fail as it merely measures the modification
501-- time of the cache link and the expression to build.
502nixBuildThunkAttrWithCache thunkDir attr = do
503 --NB: Expects thunkDir to be normalised with no trailing path separator.
504 --This should be guaranteed by the command argument parser.
505 let cacheErrHandler e
506 | isDoesNotExistError e = return Nothing -- expected from a cache miss
507 | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
508 cacheDir = thunkDir </> ".attr-cache"
509 cachePath = cacheDir </> attr <.> "out"
510 latestChange <- liftIO $ do
511 createDirectoryIfMissing False cacheDir
512 let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
513 maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
514 cacheHit <- handle cacheErrHandler $ do
515 cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
516 return $ if latestChange <= cacheTime
517 then Just cachePath
518 else Nothing
519 case cacheHit of
520 Just c -> return c
521 Nothing -> do
522 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
523 _ <- nixCmd $ NixCmd_Build$ def
524 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
525 Lens.& nixCmdConfig_target Lens..~ Target
526 { _target_path = Just thunkDir
527 , _target_attr = Just attr
528 , _target_expr = Nothing
529 }
530 return cachePath
532-- | Build a nix attribute, and cache the result if possible
533nixBuildAttrWithCache
534 :: MonadObelisk m
535 => FilePath
536 -- ^ Path to directory containing Thunk
537 -> String
538 -- ^ Attribute to build
539 -> m FilePath
540 -- ^ Symlink to cached or built nix output
541nixBuildAttrWithCache exprPath attr = do
542 readThunk exprPath >>= \case
543 -- Only packed thunks are cached. in particular, checkouts are not
544 Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
545 _ -> nixCmd $ NixCmd_Build $ def
546 Lens.& nixBuildConfig_outLink Lens..~ OutLink_None
547 Lens.& nixCmdConfig_target Lens..~ Target
548 { _target_path = Just exprPath
549 , _target_attr = Just attr
550 , _target_expr = Nothing
551 }
553-- | Safely update thunk using a custom action
554--
555-- A temporary working space is used to do any update. When the custom
556-- action successfully completes, the resulting (packed) thunk is copied
557-- back to the original location.
558updateThunk :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
559updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
560 p' <- copyThunkToTmp tmpDir p
561 unpackThunk' True p'
562 result <- f p'
563 updateThunkFromTmp p'
564 return result
565 where
566 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
567 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
568 Right (ThunkData_Packed _) -> do
569 let tmpThunk = tmpDir </> "thunk"
570 callProcessAndLogOutput (Notice, Error) $
571 proc "cp" ["-r", "-T", thunkDir, tmpThunk]
572 return tmpThunk
573 Right _ -> failWith $ "Thunk is not packed"
574 updateThunkFromTmp p' = do
575 _ <- packThunk' True False p'
576 callProcessAndLogOutput (Notice, Error) $
577 proc "cp" ["-r", "-T", p', p]
579finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
580finalMsg noTrail s = if noTrail then Nothing else Just s
582unpackThunk :: MonadObelisk m => FilePath -> m ()
583unpackThunk = unpackThunk' False
585-- | Check that we are not somewhere inside the thunk directory
586checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
587checkThunkDirectory msg thunkDir = do
588 currentDir <- liftIO getCurrentDirectory
589 thunkDir' <- liftIO $ canonicalizePath thunkDir
590 when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg
592unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
593unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
594 Left err -> failWith $ "thunk unpack: " <> T.pack (show err)
595 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
596 Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
597 Right (ThunkData_Packed tptr) -> do
598 let (thunkParent, thunkName) = splitFileName thunkDir
599 withTempDirectory thunkParent thunkName $ \tmpRepo -> do
600 let obGitDir = tmpRepo </> ".git" </> "obelisk"
601 s = case _thunkPtr_source tptr of
602 ThunkSource_GitHub s' -> forgetGithub False s'
603 ThunkSource_Git s' -> s'
604 withSpinner' ("Fetching thunk " <> T.pack thunkName)
605 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
606 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
607 git $ [ "clone" ]
608 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
609 ++ [ T.unpack $ render $ _gitSource_url s ]
610 ++ do branch <- maybeToList $ _gitSource_branch s
611 [ "--branch", T.unpack $ untagName branch ]
612 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
613 when (_gitSource_fetchSubmodules s) $
614 git ["submodule", "update", "--recursive", "--init"]
616 liftIO $ createDirectory obGitDir
617 callProcessAndLogOutput (Notice, Error) $
618 proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
619 callProcessAndLogOutput (Notice, Error) $
620 proc "rm" ["-r", thunkDir]
621 callProcessAndLogOutput (Notice, Error) $
622 proc "mv" ["-T", tmpRepo, thunkDir]
624--TODO: add a rollback mode to pack to the original thunk
625packThunk :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr
626packThunk = packThunk' False
628packThunk' :: MonadObelisk m => Bool -> Bool -> FilePath -> m ThunkPtr
629packThunk' noTrail force thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
630 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
631 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
632 Right (ThunkData_Checkout _) -> do
633 withSpinner' ("Packing thunk " <> T.pack thunkDir)
634 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
635 thunkPtr <- getThunkPtr (not force) thunkDir
636 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
637 liftIO $ createThunk thunkDir thunkPtr
638 pure thunkPtr
640getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
641getThunkPtr checkClean thunkDir = do
642 when checkClean $ ensureCleanGitRepo thunkDir True $
643 "thunk pack: thunk checkout contains unsaved modifications"
645 -- Check whether there are any stashes
646 stashOutput <- readGitProcess thunkDir ["stash", "list"]
647 when checkClean $ case T.null stashOutput of
648 False -> do
649 failWith $ T.unlines $
650 [ "thunk pack: thunk checkout has stashes"
651 , "git stash list:"
652 ] ++ T.lines stashOutput
653 True -> return ()
655 -- Get current branch ``
656 (mCurrentBranch, mCurrentCommit) <- do
657 b <- listToMaybe
658 <$> T.lines
659 <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
660 c <- listToMaybe
661 <$> T.lines
662 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
663 case b of
664 (Just "HEAD") -> failWith $ T.unlines $
665 [ "thunk pack: You are in 'detached HEAD' state."
666 , "If you want to pack at the current ref \
667 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
668 ]
669 _ -> return (b, c)
671 -- Get information on all branches and their (optional) designated upstream
672 -- correspondents
673 (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
674 [ "for-each-ref"
675 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
676 , "refs/heads/"
677 ]
679 (headInfo :: Map Text (Maybe (Text, Text)))
680 <- fmap Map.fromList $ forM headDump $ \line -> do
681 (branch : restOfLine) <- pure $ T.words line
682 mUpstream <- case restOfLine of
683 [] -> pure Nothing
684 [u, r] -> pure $ Just (u, r)
685 (_:_) -> failWith "git for-each-ref invalid output"
686 pure (branch, mUpstream)
688 putLog Debug $ "branches: " <> T.pack (show headInfo)
690 let errorMap :: Map Text ()
691 headUpstream :: Map Text (Text, Text)
692 (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
693 Nothing -> Left ()
694 Just b -> Right b
696 putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)
698 -- Check that every branch has a remote equivalent
699 when checkClean $ do
700 let untrackedBranches = Map.keys errorMap
701 when (not $ L.null untrackedBranches) $ failWith $ T.unlines $
702 [ "thunk pack: Certain branches in the thunk have no upstream branch \
703 \set. This means we don't know to check whether all your work is \
704 \saved. The offending branches are:"
705 , ""
706 , T.unwords untrackedBranches
707 , ""
708 , "To fix this, you probably want to do:"
709 , ""
710 ] ++
711 ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++
712 [ ""
713 , "These will push the branches to the default remote under the same \
714 \name, and (thanks to the `-u`) remember that choice so you don't \
715 \get this error again."
716 ]
718 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
719 stats <- iforM headUpstream $ \branch (upstream, _remote) -> do
720 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
721 [ "rev-list", "--left-right"
722 , T.unpack branch <> "..." <> T.unpack upstream
723 ]
724 let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
725 behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
726 pure (upstream, (ahead, behind))
728 -- Those branches which have commits ahead of, i.e. not on, the upstream
729 -- branch. Purely being behind is fine.
730 let nonGood = Map.filter ((/= 0) . fst . snd) stats
732 when (not $ Map.null nonGood) $ failWith $ T.unlines $
733 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
734 , ""
735 ] ++
736 (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat
737 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
738 [ ""
739 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
740 \pushed but this repo's remote tracking branches don't know it.)"
741 ]
743 -- We assume it's safe to pack the thunk at this point
744 putLog Informational $ "All changes safe in git remotes. OK to pack thunk."
746 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
748 [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
749 [ "config"
750 , "--get"
751 , "remote." <> T.unpack remote <> ".url"
752 ]
754 remoteUri <- case parseGitUri remoteUri' of
755 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
756 Just uri -> pure uri
757 uriThunkPtr remoteUri mCurrentBranch mCurrentCommit
759-- | Get the latest revision available from the given source
760getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
761getLatestRev os = do
762 let gitS = case os of
763 ThunkSource_GitHub s -> forgetGithub False s
764 ThunkSource_Git s -> s
765 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
766 case os of
767 ThunkSource_GitHub s -> githubThunkRev s commit
768 ThunkSource_Git s -> gitThunkRev s commit
770-- | Convert a URI to a thunk
771--
772-- If the URL is a github URL, we try to just download an archive for
773-- performance. If that doesn't work (e.g. authentication issue), we fall back
774-- on just doing things the normal way for git repos in general, and save it as
775-- a regular git thunk.
776uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr
777uriThunkPtr uri mbranch mcommit = do
778 commit <- case mcommit of
779 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
780 (Just c) -> return c
781 (src, rev) <- case uriToThunkSource uri mbranch of
782 ThunkSource_GitHub s -> do
783 rev <- runExceptT $ githubThunkRev s commit
784 case rev of
785 Right r -> pure (ThunkSource_GitHub s, r)
786 Left e -> do
787 putLog Warning $ "\
788\Failed to fetch archive from GitHub. This is probably a private repo. \
789\Falling back on normal fetchgit. Original failure:"
790 errorToWarning e
791 let s' = forgetGithub True s
792 (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
793 ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
794 pure $ ThunkPtr
795 { _thunkPtr_rev = rev
796 , _thunkPtr_source = src
797 }
799-- | N.B. Cannot infer all fields.
800--
801-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
802-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
803-- should be employed, and so we respect that.
804uriToThunkSource :: URI -> Maybe Text -> ThunkSource
805uriToThunkSource u
806 | Right uriAuth <- uriAuthority u
807 , Just scheme <- unRText <$> uriScheme u
808 , case scheme of
809 "ssh" -> uriAuth == Authority
810 { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing
811 , authHost = fromRight' $ mkHost "github.com"
812 , authPort = Nothing
813 }
814 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
815 && unRText (authHost uriAuth) == "github.com"
816 , Just (_, owner :| [repoish]) <- uriPath u
817 = \mbranch -> ThunkSource_GitHub $ GitHubSource
818 { _gitHubSource_owner = N $ unRText owner
819 , _gitHubSource_repo = N $ let
820 repoish' = unRText repoish
821 in case T.stripSuffix ".git" repoish' of
822 Just repo -> repo
823 Nothing -> repoish'
824 , _gitHubSource_branch = N <$> mbranch
825 }
827 | otherwise = \mbranch -> ThunkSource_Git $ GitSource
828 { _gitSource_url = u
829 , _gitSource_branch = N <$> mbranch
830 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
831 }
833-- Funny signature indicates no effects depend on the optional branch name.
834githubThunkRev
835 :: forall m
836 . MonadObelisk m
837 => GitHubSource
838 -> Text
839 -> m ThunkRev
840githubThunkRev s commit = do
841 owner <- forcePP $ _gitHubSource_owner s
842 repo <- forcePP $ _gitHubSource_repo s
843 revTarball <- mkPathPiece $ commit <> ".tar.gz"
844 let archiveUri = URI
845 { uriScheme = Just $ fromRight' $ mkScheme "https"
846 , uriAuthority = Right $ Authority
847 { authUserInfo = Nothing
848 , authHost = fromRight' $ mkHost "github.com"
849 , authPort = Nothing
850 }
851 , uriPath = Just ( False
852 , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]
853 )
854 , uriQuery = []
855 , uriFragment = Nothing
856 }
857 hash <- getNixSha256ForUriUnpacked archiveUri
858 putLog Debug $ "Nix sha256 is " <> hash
859 return $ ThunkRev
860 { _thunkRev_commit = commitNameToRef $ N commit
861 , _thunkRev_nixSha256 = hash
862 }
863 where
864 forcePP :: Name entity -> m (RText 'PathPiece)
865 forcePP = mkPathPiece . untagName
867gitThunkRev
868 :: MonadObelisk m
869 => GitSource
870 -> Text
871 -> m ThunkRev
872gitThunkRev s commit = do
873 let u = _gitSource_url s
874 protocols = ["https", "ssh", "git"]
875 Just scheme <- pure $ unRText <$> uriScheme u
876 unless (T.toLower scheme `elem` protocols) $
877 failWith $ "obelisk currently only supports "
878 <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
879 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
880 putLog Informational $ "Nix sha256 is " <> hash
881 pure $ ThunkRev
882 { _thunkRev_commit = commitNameToRef (N commit)
883 , _thunkRev_nixSha256 = hash
884 }
886-- | Given the URI to a git remote, and an optional branch name, return the name
887-- of the branch along with the hash of the commit at tip of that branch.
888--
889-- If the branch name is passed in, it is returned exactly as-is. If it is not
890-- passed it, the default branch of the repo is used instead.
891gitGetCommitBranch
892 :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
893gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
894 (_, bothMaps) <- gitLsRemote
895 (T.unpack $ render uri)
896 (GitRef_Branch <$> mbranch)
897 Nothing
898 branch <- case mbranch of
899 Nothing -> withExitFailMessage "Failed to find default branch" $ do
900 b <- rethrowE $ gitLookupDefaultBranch bothMaps
901 putLog Debug $ "Default branch for remote repo " <> uriMsg <> " is " <> b
902 pure b
903 Just b -> pure b
904 commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)
905 putLog Informational $ "Latest commit in branch " <> branch
906 <> " from remote repo " <> uriMsg
907 <> " is " <> commit
908 pure (branch, commit)
909 where
910 rethrowE = either failWith pure
911 uriMsg = render uri
913parseGitUri :: Text -> Maybe URI
914parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x
916parseAbsoluteURI :: Text -> Maybe URI
917parseAbsoluteURI uri = do
918 parsedUri <- mkURI uri
919 guard $ isPathAbsolute parsedUri
920 pure $ parsedUri
922parseSshShorthand :: Text -> Maybe URI
923parseSshShorthand uri = do
924 -- This is what git does to check that the remote
925 -- is not a local file path when parsing shorthand.
926 -- Last referenced from here:
927 -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
928 let
929 (authAndHostname, colonAndPath) = T.break (== ':') uri
930 properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
931 -- Shorthand is valid iff a colon is present and it occurs before the first slash
932 -- This check is used to disambiguate a filepath containing a colon from shorthand
933 guard $ isNothing (T.findIndex (=='/') authAndHostname)
934 && not (T.null colonAndPath)
935 mkURI properUri