@@ -1,74 +1,77 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiWayIf #-}
3{-# LANGUAGE MultiWayIf #-}
6{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE PatternGuards #-}
8−{-# LANGUAGE QuasiQuotes #-}
6+{-# LANGUAGE TemplateHaskell #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
7+
10−{-# LANGUAGE TypeApplications #-}
8+module Obelisk.Command.Thunk
11−module Obelisk.Command.Thunk where
9+ ( ThunkPtr (..)
15+ , updateThunkToLatest
17+ , createThunkWithLatest
18+ , nixBuildAttrWithCache
19+ , nixBuildThunkAttrWithCache
13import Control.Applicative
26import Control.Applicative
14−import Control.Exception (displayException, try)
27+import Control.Exception
15−import Control.Lens (ifor, ifor_, (.~))
16import Control.Monad
28import Control.Monad
17−import Control.Monad.Extra (findM)
18−import Control.Monad.Catch (MonadCatch, handle)
19import Control.Monad.Except
29import Control.Monad.Except
20−import Data.Aeson ((.=))
30+import Data.Aeson as Aeson
21−import qualified Data.Aeson as Aeson
22import Data.Aeson.Encode.Pretty
31import Data.Aeson.Encode.Pretty
23−import qualified Data.Aeson.Types as Aeson
24−import Data.Bifunctor (first)
25import qualified Data.ByteString.Lazy as LBS
32import qualified Data.ByteString.Lazy as LBS
26−import Data.Containers.ListUtils (nubOrd)
27import Data.Default
33import Data.Default
28−import Data.Either.Combinators (fromRight', rightToMaybe)
34+import Data.Foldable
29−import Data.Foldable (toList)
30−import Data.Function ((&))
31−import Data.Functor ((<&>))
32import Data.Git.Ref (Ref)
35import Data.Git.Ref (Ref)
33import qualified Data.Git.Ref as Ref
36import qualified Data.Git.Ref as Ref
34import qualified Data.List as L
37import qualified Data.List as L
35−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
38+import Data.List.NonEmpty (NonEmpty (..))
36import qualified Data.List.NonEmpty as NonEmpty
39import qualified Data.List.NonEmpty as NonEmpty
38import qualified Data.Map as Map
40import qualified Data.Map as Map
39import Data.Maybe
41import Data.Maybe
40import Data.Set (Set)
43import Data.Set (Set)
41import qualified Data.Set as Set
44import qualified Data.Set as Set
42−import Data.String.Here.Interpolated (i)
43−import Data.String.Here.Uninterpolated (here)
44import Data.Text (Text)
45import Data.Text (Text)
45import qualified Data.Text as T
46import qualified Data.Text as T
46import Data.Text.Encoding
47import Data.Text.Encoding
47import qualified Data.Text.IO as T
48import qualified Data.Text.IO as T
48import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
49import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
49−import Data.Traversable (for)
50+import Data.Yaml (parseMaybe, (.:))
50−import Data.Yaml (parseMaybe)
51+import qualified Data.Yaml as Yaml
51import GitHub
52import GitHub
52import GitHub.Data.Name
53import GitHub.Data.Name
54+import GitHub.Endpoints.Repos.Contents (archiveForR)
53import Obelisk.Command.Nix
56import Obelisk.Command.Nix
54import System.Directory
57import System.Directory
55import System.Exit
58import System.Exit
56import System.FilePath
59import System.FilePath
57import System.IO.Error
61import System.IO.Error
58import System.IO.Temp
62import System.IO.Temp
59−import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
63+import System.Posix (getSymbolicLinkStatus, modificationTime)
60−import qualified Text.URI as URI
64+import System.Process
62−import Obelisk.App (MonadObelisk)
66+import Development.Placeholders
64−import Obelisk.Command.Utils
66--TODO: Support symlinked thunk data
68--TODO: Support symlinked thunk data
67data ThunkData
69data ThunkData
68− = ThunkData_Packed ThunkSpec ThunkPtr
70+ = ThunkData_Packed ThunkPtr
69 -- ^ Packed thunk
71 -- ^ Packed thunk
70− | ThunkData_Checkout
72+ | ThunkData_Checkout (Maybe ThunkPtr)
71 -- ^ Checked out thunk that was unpacked from this pointer
73 -- ^ Checked out thunk that was unpacked from this pointer
74+ deriving (Show, Eq, Ord)
73-- | A reference to the exact data that a thunk should translate into
76-- | A reference to the exact data that a thunk should translate into
74data ThunkPtr = ThunkPtr
77data ThunkPtr = ThunkPtr
@@ -81,7 +84,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
82-- | A specific revision of data; it may be available from multiple sources
85-- | A specific revision of data; it may be available from multiple sources
83data ThunkRev = ThunkRev
86data ThunkRev = ThunkRev
84− { _thunkRev_commit :: Ref Ref.SHA1
87+ { _thunkRev_commit :: Ref
85 , _thunkRev_nixSha256 :: NixSha256
88 , _thunkRev_nixSha256 :: NixSha256
87 deriving (Show, Eq, Ord)
90 deriving (Show, Eq, Ord)
@@ -94,11 +97,6 @@ data ThunkSource
94 | ThunkSource_Git GitSource
97 | ThunkSource_Git GitSource
95 deriving (Show, Eq, Ord)
98 deriving (Show, Eq, Ord)
97−thunkSourceToGitSource :: ThunkSource -> GitSource
98−thunkSourceToGitSource = \case
99− ThunkSource_GitHub s -> forgetGithub False s
100− ThunkSource_Git s -> s
102data GitHubSource = GitHubSource
100data GitHubSource = GitHubSource
103 { _gitHubSource_owner :: Name Owner
101 { _gitHubSource_owner :: Name Owner
104 , _gitHubSource_repo :: Name Repo
102 , _gitHubSource_repo :: Name Repo
@@ -107,263 +105,157 @@ data GitHubSource = GitHubSource
108 deriving (Show, Eq, Ord)
106 deriving (Show, Eq, Ord)
110−newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
112−gitUriToText :: GitUri -> Text
113−gitUriToText (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
108data GitSource = GitSource
120− { _gitSource_url :: GitUri
109+ { _gitSource_url :: URI
110+ --TODO: Is it ok to use the types from the GitHub api bindings?
121 , _gitSource_branch :: Maybe (Name Branch)
111 , _gitSource_branch :: Maybe (Name Branch)
122 , _gitSource_fetchSubmodules :: Bool
112 , _gitSource_fetchSubmodules :: Bool
123− , _gitSource_private :: Bool
125 deriving (Show, Eq, Ord)
114 deriving (Show, Eq, Ord)
127−newtype ThunkConfig = ThunkConfig
116+commitNameToRef :: Name Commit -> Ref
128− { _thunkConfig_private :: Maybe Bool
131−data ThunkUpdateConfig = ThunkUpdateConfig
132− { _thunkUpdateConfig_branch :: Maybe String
133− , _thunkUpdateConfig_config :: ThunkConfig
136−data ThunkPackConfig = ThunkPackConfig
137− { _thunkPackConfig_force :: Bool
138− , _thunkPackConfig_config :: ThunkConfig
141−-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
142−forgetGithub :: Bool -> GitHubSource -> GitSource
143−forgetGithub 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
149− , URI.authHost = fromRight' $ URI.mkHost "github.com"
150− , URI.authPort = Nothing
152− , URI.uriPath = Just ( False
153− , fromRight' . URI.mkPathPiece <$>
154− untagName (_gitHubSource_owner s)
155− :| [ untagName (_gitHubSource_repo s) <> ".git" ]
158− , URI.uriFragment = Nothing
160− , _gitSource_branch = _gitHubSource_branch s
161− , _gitSource_fetchSubmodules = False
162− , _gitSource_private = _gitHubSource_private s
165−getThunkGitBranch :: ThunkPtr -> Maybe Text
166−getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
167− ThunkSource_GitHub s -> _gitHubSource_branch s
168− ThunkSource_Git s -> _gitSource_branch s
170−commitNameToRef :: Name Commit -> Ref Ref.SHA1
171commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
117commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
173−-- TODO: Use spinner here.
119+getNixSha256ForUriUnpacked :: URI -> IO NixSha256
174−getNixSha256ForUriUnpacked
120+getNixSha256ForUriUnpacked uri = do
175− :: MonadObelisk m
121+ --TODO: Make this package depend on nix-prefetch-url properly
176− => GitUri
122+ let cmd = proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
177− -> m NixSha256
123+ (_, Just out, Just err, p) <- createProcess cmd
178−getNixSha256ForUriUnpacked uri =
124+ { std_out = CreatePipe
179− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
125+ , std_err = CreatePipe
180− [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
126+ }
181− proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
127+ --TODO: Deal with errors here; usually they're HTTP errors
182− pure hash
128+ waitForProcess p >>= \case
183−
129+ ExitSuccess -> return ()
184−nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
130+ _ -> do
185−nixPrefetchGit uri rev fetchSubmodules =
131+ hPutStrLn stdout =<< hGetContents out
186− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
132+ hPutStrLn stderr =<< hGetContents err
187− out <- readProcessAndLogStderr Debug $
133+ --TODO: actual error
188− proc nixPrefetchGitPath $ filter (/="")
134+ fail $ "nix-prefetch-url"
189− [ "--url", T.unpack $ gitUriToText uri
135+ T.strip <$> T.hGetContents out
190− , "--rev", T.unpack rev
191− , if fetchSubmodules then "--fetch-submodules" else ""
195− case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of
137+-- | Get the latest revision available from the given source
196− Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
138+getLatestRev :: ThunkSource -> IO ThunkRev
197− Just x -> pure x
139+getLatestRev = \case
140+ ThunkSource_GitHub s -> do
141+ auth <- getHubAuth "github.com"
142+ commitsResult <- executeRequestMaybe auth $ commitsWithOptionsForR
143+ (_gitHubSource_owner s)
144+ (_gitHubSource_repo s)
146+ $ case _gitHubSource_branch s of
148+ Just b -> [CommitQuerySha $ untagName b]
149+ commitInfos <- either throwIO return commitsResult
150+ commitInfo : _ <- return $ toList commitInfos
151+ let commit = commitSha commitInfo
152+ Right archiveUri <- executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit
153+ nixSha256 <- getNixSha256ForUriUnpacked archiveUri
155+ { _thunkRev_commit = commitNameToRef commit
156+ , _thunkRev_nixSha256 = nixSha256
158+ ThunkSource_Git _s -> do
199--TODO: Pretty print these
161--TODO: Pretty print these
200data ReadThunkError
162data ReadThunkError
201− = ReadThunkError_UnrecognizedThunk
163+ = ReadThunkError_WrongContents (Set String) (Set String)
202− | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
164+ | ReadThunkError_UnrecognizedLoader Text
203− | ReadThunkError_MissingPaths (NonEmpty FilePath)
165+ | ReadThunkError_UnparseablePtr LBS.ByteString
204− | ReadThunkError_UnparseablePtr FilePath String
166+ deriving (Show)
205− | ReadThunkError_FileError IOError
167+
206− | ReadThunkError_FileDoesNotMatch FilePath Text
168+-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
207− | ReadThunkError_UnrecognizedState String
169+-- If the thunk is packed and additional data is present, fail.
208− | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
170+readThunk :: FilePath -> IO (Either ReadThunkError ThunkData)
209− deriving (Show)
171+readThunk thunkDir = do
210−
172+ files <- listDirectory thunkDir
211−unpackedDirName :: FilePath
173+ case ".git" `elem` files of
212−unpackedDirName = "."
174+ True -> fmap ThunkData_Checkout <$> do
213−
175+ let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
214−attrCacheFileName :: FilePath
176+ doesDirectoryExist origThunkPath >>= \case
215−attrCacheFileName = ".attr-cache"
177+ True -> fmap Just <$> readPackedThunk origThunkPath
216−
178+ False -> return $ return Nothing
217−-- | Specification for how a file in a thunk version works.
179+ False -> fmap ThunkData_Packed <$> readPackedThunk thunkDir
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.
225−data ThunkSpec = ThunkSpec
226− { _thunkSpec_name :: !Text
227− , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
230−thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
231−thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
233−-- | Attempts to match a 'ThunkSpec' to a given directory.
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
240−matchThunkSpecToDir thunkSpec dir dirFiles = do
241− case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
242− Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
244− case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
245− Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
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
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
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)
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
281− dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
282− True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
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
298− => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
299−readThunkWith 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.
181-- | Read a thunk and validate that it is exactly a packed thunk.
309-- If additional data is present, fail.
182-- If additional data is present, fail.
310−readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
183+readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
311−readThunk = readThunkWith thunkSpecTypes
184+readPackedThunk thunkDir = runExceptT $ do
312−
185+ let thunkLoader = thunkDir </> "default.nix"
313−parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
186+ githubJson = thunkDir </> "github.json"
314−parseThunkPtr parseSrc v = do
187+ attrCache = thunkDir </> ".attr-cache"
315− rev <- v Aeson..: "rev"
188+ expectedContents = Set.fromList $
316− sha256 <- v Aeson..: "sha256"
189+ [ githubJson
317− src <- parseSrc v
190+ , thunkLoader
318− pure $ ThunkPtr
191+ ]
319− { _thunkPtr_rev = ThunkRev
192+ optionalContents = Set.fromList $
320− { _thunkRev_commit = Ref.fromHexString rev
193+ [ attrCache
321− , _thunkRev_nixSha256 = sha256
194+ ]
323− , _thunkPtr_source = src
326−parseGitHubSource :: Aeson.Object -> Aeson.Parser GitHubSource
327−parseGitHubSource v = do
328− owner <- v Aeson..: "owner"
329− repo <- v Aeson..: "repo"
330− branch <- v Aeson..:! "branch"
331− private <- v Aeson..:? "private"
333− { _gitHubSource_owner = owner
334− , _gitHubSource_repo = repo
335− , _gitHubSource_branch = branch
336− , _gitHubSource_private = fromMaybe False private
339−parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
196+ -- Ensure that there aren't any other files in the thunk
340−parseGitSource v = do
197+ -- NB: System.Directory.listDirectory returns the contents without the directory path
341− Just url <- parseGitUri <$> v Aeson..: "url"
198+ files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
342− branch <- v Aeson..:! "branch"
199+ let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
343− fetchSubmodules <- v Aeson..:! "fetchSubmodules"
200+ missingContents = expectedContents `Set.difference` files
344− private <- v Aeson..:? "private"
201+ unless (Set.null unexpectedContents && Set.null missingContents) $ do
345− pure $ GitSource
202+ throwError $ ReadThunkError_WrongContents unexpectedContents missingContents
346− { _gitSource_url = url
203+
347− , _gitSource_branch = branch
204+ -- Ensure that we recognize the thunk loader
348− , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
205+ loader <- liftIO $ T.readFile thunkLoader
349− , _gitSource_private = fromMaybe False private
206+ unless (loader `elem` gitHubStandaloneLoaders) $ do
350− }
207+ throwError $ ReadThunkError_UnrecognizedLoader loader
209+ txt <- liftIO $ LBS.readFile githubJson
210+ let parseThunk v = do
211+ rev <- v Aeson..: "rev"
212+ sha256 <- v Aeson..: "sha256"
213+ src <- parseGitHubSource v
214+ <|> parseGitSource v
216+ { _thunkPtr_rev = ThunkRev
217+ { _thunkRev_commit = Ref.fromHexString rev
218+ , _thunkRev_nixSha256 = sha256
220+ , _thunkPtr_source = src
222+ parseGitHubSource v = do
223+ owner <- v Aeson..: "owner"
224+ repo <- v Aeson..: "repo"
225+ branch <- v Aeson..:! "branch"
226+ mPrivate <- v Aeson..:! "private"
227+ return $ ThunkSource_GitHub $ GitHubSource
228+ { _gitHubSource_owner = owner
229+ , _gitHubSource_repo = repo
230+ , _gitHubSource_branch = branch
231+ , _gitHubSource_private = fromMaybe False mPrivate
233+ parseGitSource v = do
234+ Just url <- parseURI <$> v Aeson..: "url"
235+ branch <- v Aeson..:! "branch"
236+ fetchSubmodules <- v Aeson..: "fetchSubmodules"
237+ return $ ThunkSource_Git $ GitSource
238+ { _gitSource_url = url
239+ , _gitSource_branch = branch
240+ , _gitSource_fetchSubmodules = fetchSubmodules
242+ case parseMaybe parseThunk =<< decode txt of
243+ Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
244+ Just ptr -> return ptr
352−overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
246+overwriteThunk :: FilePath -> ThunkPtr -> IO ()
353overwriteThunk target thunk = do
247overwriteThunk target thunk = do
354 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
248 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
355− readThunk target >>= \case
249+ Right _ <- readThunk target
356− Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
359 --TODO: Is there a safer way to do this overwriting?
251 --TODO: Is there a safer way to do this overwriting?
360− liftIO $ removePathForcibly target
252+ removeDirectoryRecursive target
361− createThunk target $ Right thunk
253+ createThunk target thunk
363−thunkPtrToSpec :: ThunkPtr -> ThunkSpec
255+thunkPtrLoader :: ThunkPtr -> Text
364−thunkPtrToSpec thunk = case _thunkPtr_source thunk of
256+thunkPtrLoader thunk = case _thunkPtr_source thunk of
365− ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
257+ ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
366− ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
258+ ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
368-- It's important that formatting be very consistent here, because
260-- It's important that formatting be very consistent here, because
369-- otherwise when people update thunks, their patches will be messy
261-- otherwise when people update thunks, their patches will be messy
@@ -372,18 +264,21 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
372 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
264 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
373 [ Just $ "owner" .= _gitHubSource_owner s
265 [ Just $ "owner" .= _gitHubSource_owner s
374 , Just $ "repo" .= _gitHubSource_repo s
266 , Just $ "repo" .= _gitHubSource_repo s
375− , ("branch" .=) <$> _gitHubSource_branch s
267+ , case _gitHubSource_branch s of
268+ Just b -> Just $ "branch" .= b
270+ , if _gitHubSource_private s
271+ then Just $ "private" .= True
376 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
273 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
377 , Just $ "sha256" .= _thunkRev_nixSha256 rev
274 , Just $ "sha256" .= _thunkRev_nixSha256 rev
378− , Just $ "private" .= _gitHubSource_private s
380 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
276 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
381− [ Just $ "url" .= gitUriToText (_gitSource_url s)
277+ --TODO: Is this safe? read/show is jank for `URI`
278+ [ Just $ "url" .= show (_gitSource_url s)
382 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
279 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
383− , ("branch" .=) <$> _gitSource_branch s
384 , Just $ "sha256" .= _thunkRev_nixSha256 rev
280 , Just $ "sha256" .= _thunkRev_nixSha256 rev
385 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
281 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
386− , Just $ "private" .= _gitSource_private s
389 githubCfg = defConfig
284 githubCfg = defConfig
@@ -404,84 +299,54 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
406 , "sha256"
301 , "sha256"
408 , "fetchSubmodules"
302 , "fetchSubmodules"
409 ] <> compare
303 ] <> compare
410 , confTrailingNewline = True
304 , confTrailingNewline = True
413−createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
307+createThunk :: FilePath -> ThunkPtr -> IO ()
414−createThunk target ptrInfo =
308+createThunk target thunk = do
415− ifor_ (_thunkSpec_files spec) $ \path -> \case
309+ createDirectoryIfMissing True (target </> ".attr-cache")
416− ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
310+ T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
417− ThunkFileSpec_Ptr _ -> case ptrInfo of
311+ LBS.writeFile (target </> "github.json") (encodeThunkPtrData thunk)
418− Left _ -> pure () -- We can't write the ptr without it
419− Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
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
429−createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
313+createThunkWithLatest :: FilePath -> ThunkSource -> IO ()
430createThunkWithLatest target s = do
314createThunkWithLatest target s = do
431 rev <- getLatestRev s
315 rev <- getLatestRev s
432− createThunk target $ Right $ ThunkPtr
316+ createThunk target $ ThunkPtr
433 { _thunkPtr_source = s
317 { _thunkPtr_source = s
434 , _thunkPtr_rev = rev
318 , _thunkPtr_rev = rev
437−updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
321+updateThunkToLatest :: FilePath -> IO ()
438−updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
322+updateThunkToLatest target = do
439− checkThunkDirectory target
323+ (overwrite, ptr) <- readThunk target >>= \case
440− -- check to see if thunk should be updated to a specific branch or just update it's current branch
324+ Left err -> fail $ "thunk update: " <> show err
441− case mBranch of
325+ Right c -> return $ case c of
442− Nothing -> do
326+ ThunkData_Packed t -> (target, t)
443− (overwrite, ptr) <- readThunk target >>= \case
327+ ThunkData_Checkout _ -> fail "cannot update an unpacked thunk"
444− Left err -> failWith [i|Thunk update: ${err}|]
328+ let src = _thunkPtr_source ptr
445− Right c -> case c of
329+ rev <- getLatestRev src
446− ThunkData_Packed _ t -> return (target, t)
330+ overwriteThunk overwrite $ ThunkPtr
447− ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
331+ { _thunkPtr_source = src
448− let src = _thunkPtr_source ptr
332+ , _thunkPtr_rev = rev
449− rev <- getLatestRev src
333+ }
450− overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
451− { _thunkPtr_source = src
452− , _thunkPtr_rev = rev
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.|]
460− spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
462−setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
463−setThunk 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.
335-- | 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.
336-- This tool will only ever produce the newest one when it writes a thunk.
470−gitHubThunkSpecs :: NonEmpty ThunkSpec
337+gitHubStandaloneLoaders :: NonEmpty Text
471−gitHubThunkSpecs =
338+gitHubStandaloneLoaders =
472− gitHubThunkSpecV5 :|
339+ gitHubStandaloneLoaderV2 :|
473− [ gitHubThunkSpecV4
340+ [ gitHubStandaloneLoaderV1
479−gitHubThunkSpecV1 :: ThunkSpec
343+gitHubStandaloneLoaderV1 :: Text
480−gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
344+gitHubStandaloneLoaderV1 = T.unlines
481− "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
345+ [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
483−gitHubThunkSpecV2 :: ThunkSpec
348+gitHubStandaloneLoaderV2 :: Text
484−gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
349+gitHubStandaloneLoaderV2 = T.unlines
485 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
350 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
351 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
352 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -491,701 +356,292 @@ gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
494−gitHubThunkSpecV3 :: ThunkSpec
359+plainGitStandaloneLoaders :: NonEmpty Text
495−gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
360+plainGitStandaloneLoaders =
496− [ "# DO NOT HAND-EDIT THIS FILE"
361+ plainGitStandaloneLoaderV1 :|
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\";"
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)))"
514−gitHubThunkSpecV4 :: ThunkSpec
365+plainGitStandaloneLoaderV1 :: Text
515−gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
366+plainGitStandaloneLoaderV1 = T.unlines
516− [ "# DO NOT HAND-EDIT THIS FILE"
367+ [ $notImplemented
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;"
523− , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
526−legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
370+-- | Look for authentication info from the 'hub' command
527−legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
371+getHubAuth
528− [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
372+ :: Text -- ^ Domain name
529− , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
373+ -> IO (Maybe Auth)
530− , (attrCacheFileName, ThunkFileSpec_AttrCache)
374+getHubAuth domain = do
531− , (".git", ThunkFileSpec_CheckoutIndicator)
375+ hubConfig <- getXdgDirectory XdgConfig "hub"
532− ]
376+ Yaml.decodeFile hubConfig >>= \case
533−
377+ Nothing -> return Nothing
534−gitHubThunkSpecV5 :: ThunkSpec
378+ Just v -> return $ flip parseMaybe v $ \v' -> do
535−gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|
379+ Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means
536−# DO NOT HAND-EDIT THIS FILE
380+ [Yaml.Object domainConfig] <- return $ toList domainConfigs
537−let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
381+ token <- domainConfig .: "oauth_token"
538− if !fetchSubmodules && !private then builtins.fetchTarball {
382+ return $ OAuth $ encodeUtf8 token
539− url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
383+
540− } else (import <nixpkgs> {}).fetchFromGitHub {
384+--TODO: when checking something out, make a shallow clone
541− inherit owner repo rev sha256 fetchSubmodules private;
543− json = builtins.fromJSON (builtins.readFile ./github.json);
547−parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
548−parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->
549− ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
551−gitThunkSpecs :: NonEmpty ThunkSpec
560−gitThunkSpecV1 :: ThunkSpec
561−gitThunkSpecV1 = 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)))"
568−gitThunkSpecV2 :: ThunkSpec
569−gitThunkSpecV2 = 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)))"
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.
580−gitThunkSpecV3 :: ThunkSpec
581−gitThunkSpecV3 = 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"
588− , " in if !fetchSubmodules && private then builtins.fetchGit {"
589− , " url = realUrl; inherit rev;"
590− , " } else (import <nixpkgs> {}).fetchgit {"
591− , " url = realUrl; inherit rev sha256;"
593− , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
596−gitThunkSpecV4 :: ThunkSpec
597−gitThunkSpecV4 = 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"
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;"
610− , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
613−legacyGitThunkSpec :: Text -> Text -> ThunkSpec
614−legacyGitThunkSpec 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)
621−gitThunkSpecV5 :: ThunkSpec
622−gitThunkSpecV5 = mkThunkSpec "git-v5" "git.json" parseGitJsonBytes [here|
623−# DO NOT HAND-EDIT THIS FILE
624−let 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
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;
635− json = builtins.fromJSON (builtins.readFile ./git.json);
639−parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
640−parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
642−mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
643−mkThunkSpec 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)
651− defaultNixViaSrc = [here|
652−# DO NOT HAND-EDIT THIS FILE
653−import (import ./thunk.nix)
657−parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
658−parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
660-- | Checks a cache directory to see if there is a fresh symlink
386-- | Checks a cache directory to see if there is a fresh symlink
661-- to the result of building an attribute of a thunk.
387-- 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
388-- If no cache hit is found, nix-build is called to build the attribute
663-- and the result is symlinked into the cache.
389-- and the result is symlinked into the cache.
664−nixBuildThunkAttrWithCache
390+nixBuildThunkAttrWithCache :: FilePath
665− :: MonadObelisk m
391+ -- ^ Path to directory containing Thunk
666− => ThunkSpec
392+ -> String
667− -> FilePath
393+ -- ^ Attribute to build
668− -- ^ Path to directory containing Thunk
394+ -> IO FilePath
669− -> String
395+ -- ^ Symlink to cached or built nix output
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>'
396-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
674-- the caching mechanism will fail as it merely measures the modification
397-- the caching mechanism will fail as it merely measures the modification
675-- time of the cache link and the expression to build.
398-- time of the cache link and the expression to build.
676−nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
399+nixBuildThunkAttrWithCache thunkDir attr = do
677− latestChange <- liftIO $ do
400+ --NB: Expects thunkDir to be normalised with no trailing path separator.
678− let
401+ --This should be guaranteed by the command argument parser.
679− getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
402+ let cacheErrHandler e
680− thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
403+ | isDoesNotExistError e = return Nothing -- expected from a cache miss
681− maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
404+ | otherwise = hPutStrLn stderr (displayException e) >> return Nothing
682−
405+ cacheDir = thunkDir </> ".attr-cache"
683− let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
406+ cachePath = cacheDir </> attr <.> "out"
684− _thunkSpec_files thunkSpec
407+ createDirectoryIfMissing False cacheDir
685− for cachePaths' $ \cachePaths ->
408+ latestChange <- maximum <$> mapM (getModificationTime . (thunkDir </>)) ["default.nix", "github.json"]
686− fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
409+ cacheHit <- handle cacheErrHandler $ do
687− let
410+ cacheTime <- posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
688− cachePath = thunkDir </> cacheDir </> attr <.> "out"
411+ return $ if latestChange <= cacheTime
689− cacheErrHandler e
412+ then Just cachePath
690− | isDoesNotExistError e = pure Nothing -- expected from a cache miss
413+ else Nothing
691− | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
414+ case cacheHit of
692− cacheHit <- handle cacheErrHandler $ do
415+ Just c -> return c
693− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
416+ Nothing -> do
694− pure $ if latestChange <= cacheTime
417+ hPutStrLn stderr (mconcat [thunkDir, ": ", attr, " not cached, building ..."])
695− then Just cachePath
418+ _ <- nixBuild $ def
696− else Nothing
419+ { _nixBuildConfig_target = Target
697− case cacheHit of
420+ { _target_path = thunkDir
698− Just c -> pure c
421+ , _target_attr = Just attr
700− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
423+ , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath
701− liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
424+ }
702− (cachePath <$) $ nixCmd $ NixCmd_Build $ def
425+ return cachePath
703− & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath
704− & nixCmdConfig_target .~ Target
705− { _target_path = Just thunkDir
706− , _target_attr = Just attr
707− , _target_expr = Nothing
710-- | Build a nix attribute, and cache the result if possible
427-- | Build a nix attribute, and cache the result if possible
711−nixBuildAttrWithCache
428+nixBuildAttrWithCache :: FilePath
712− :: MonadObelisk m
429+ -- ^ Path to directory containing Thunk
713− => FilePath
430+ -> String
714− -- ^ Path to directory containing Thunk
431+ -- ^ Attribute to build
715− -> String
432+ -> IO FilePath
716− -- ^ Attribute to build
433+ -- ^ Symlink to cached or built nix output
717− -> m FilePath
434+nixBuildAttrWithCache exprPath attr = do
718− -- ^ Symlink to cached or built nix output
435+ readThunk exprPath >>= \case
719−nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
436+ -- Only packed thunks are cached. in particular, checkouts are not
720− -- Only packed thunks are cached. In particular, checkouts are not.
437+ Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
721− Right (ThunkData_Packed spec _) ->
438+ _ -> nixBuild $ def
722− maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
439+ { _nixBuildConfig_target = Target
723− _ -> build
440+ { _target_path = exprPath
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
441 , _target_attr = Just attr
730− , _target_expr = Nothing
443+ , _nixBuildConfig_outLink = OutLink_None
733−-- | Safely update thunk using a custom action
446+unpackThunk :: FilePath
735−-- A temporary working space is used to do any update. When the custom
448+unpackThunk thunkDir = readThunk thunkDir >>= \case
736−-- action successfully completes, the resulting (packed) thunk is copied
449+ Left err -> fail $ "thunk unpack: " <> show err
737−-- back to the original location.
738−updateThunk :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
739−updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
740− p' <- copyThunkToTmp tmpDir p
741− unpackThunk' True p'
743− updateThunkFromTmp p'
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]
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]
759−finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
760−finalMsg noTrail s = if noTrail then Nothing else Just s
762−-- | Check that we are not somewhere inside the thunk directory
763−checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764−checkThunkDirectory 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|]
776−unpackThunk :: MonadObelisk m => FilePath -> m ()
777−unpackThunk = unpackThunk' False
779−unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
780−unpackThunk' 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
450 --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|]
451+ Right (ThunkData_Checkout _) -> fail "thunk unpack: thunk is already unpacked"
784− Right (ThunkData_Packed _ tptr) -> do
452+ Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
785− let (thunkParent, thunkName) = splitFileName thunkDir
453+ ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
786− withTempDirectory thunkParent thunkName $ \tmpThunk -> do
454+ mauth <- getHubAuth "github.com"
787− let
455+ repoResult <- executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
788− gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
456+ githubURI <- either throwIO (return . repoSshUrl) repoResult >>= \case
789− newSpec = case _thunkPtr_source tptr of
457+ Nothing -> fail "Cannot determine clone URI for thunk source"
790− ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
458+ Just c -> return $ T.unpack $ getUrl c
791− ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
459+ callProcess "hub" --TODO: Depend on hub explicitly
792− withSpinner' ("Fetching thunk " <> T.pack thunkName)
460+ [ "clone"
793− (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
461+ , "-n"
794− let unpackedPath = tmpThunk </> unpackedDirName
462+ , githubURI
795− gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
463+ , tmpRepo
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
802− removePathForcibly thunkDir
803− renameDirectory tmpThunk thunkDir
805−gitCloneForThunkUnpack
807− => GitSource -- ^ Git source to use
808− -> Ref hash -- ^ Commit hash to reset to
809− -> FilePath -- ^ Directory to clone into
811−gitCloneForThunkUnpack gitSrc commit dir = do
812− let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
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
823−packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
824−packThunk = packThunk' False
826−packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
827−packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
828− Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
830− ("Packing thunk " <> T.pack thunkDir)
831− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
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
839−modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
840−modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
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 }
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
855−getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
856−getThunkPtr 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"
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"]
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."
890− _ -> return (b, c)
465+ let obGitDir = tmpRepo </> ".git" </> "obelisk"
891−
466+ --If this directory already exists then something is weird and we should fail
892− -- Get information on all branches and their (optional) designated upstream
467+ createDirectory obGitDir
893− -- correspondents
468+ callProcess "cp"
894− headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
469+ [ "-r"
895− [ "for-each-ref"
470+ , "-T"
896− , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
471+ , thunkDir </> "."
897− , "refs/heads/"
472+ , obGitDir </> "orig-thunk"
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
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
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:"
927− , T.unwords untrackedBranches
929− , "To fix this, you probably want to do:"
932− ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++
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."
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
945− let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
474+ let checkoutOptions = concat
946− behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
475+ [ ["-C", tmpRepo]
947− pure (upstream, (ahead, behind))
476+ , pure "checkout"
948−
477+ , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)
949− -- Those branches which have commits ahead of, i.e. not on, the upstream
478+ , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr
950− -- branch. Purely being behind is fine.
479+ ]
951− let nonGood = Map.filter ((/= 0) . fst . snd) stats
480+ callProcess "hub" checkoutOptions
491+ ThunkSource_Git _s -> do
953− when (not $ Map.null nonGood) $ failWith $ T.unlines $
494+--TODO: add force mode to pack even if changes are present
954− [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
495+--TODO: add a rollback mode to pack to the original thunk
955− , ""
496+packThunk :: FilePath
957− flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
498+ -> IO ()
958− [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
499+packThunk thunkDir upstream = readThunk thunkDir >>= \case
959− [ ""
500+ Left err -> fail $ "thunk pack: " <> show err
960− , "Please push these upstream and try again. (Or just fetch, if they are somehow \
501+ Right (ThunkData_Packed _) -> fail "pack: thunk is already packed"
961− \pushed but this repo's remote tracking branches don't know it.)"
502+ Right (ThunkData_Checkout _) -> do
503+ thunkPtr <- getThunkPtr thunkDir upstream
963−
508+ createThunk thunkDir thunkPtr
964− when checkClean $ do
509+ return ()
965− -- We assume it's safe to pack the thunk at this point
510+
966− putLog Informational "All changes safe in git remotes. OK to pack thunk."
511+getThunkPtr :: FilePath -> String -> IO ThunkPtr
967−
512+getThunkPtr thunkDir upstream = do
968− let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
513+ --Check whether the working directory is clean
969−
514+ statusOutput <- readProcess "hub"
970− [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
515+ [ "-C", thunkDir
971− [ "config"
516+ , "status", "--porcelain", "--ignored" ] ""
972− , "--get"
517+ diffOutput <- readProcess "hub" [ "-C", thunkDir , "diff" ] ""
973− , "remote." <> T.unpack remote <> ".url"
518+ case null statusOutput && null diffOutput of
975−
520+ statusDebug <- readProcess "hub"
976− remoteUri <- case parseGitUri remoteUri' of
521+ [ "-C", thunkDir, "status", "--ignored" ] ""
977− Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
522+ fail $ unlines $
978− Just uri -> pure uri
523+ [ "thunk pack: thunk checkout contains unsaved modifications"
979− uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
524+ , "git status:"
980−
525+ ] ++ lines statusDebug
981−-- | Get the latest revision available from the given source
526+ True -> return ()
982−getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
527+
983−getLatestRev os = do
528+ -- Check whether there are any stashes
984− let gitS = thunkSourceToGitSource os
529+ stashOutput <- readProcess "hub" [ "-C", thunkDir, "stash", "list" ] ""
985− (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
530+ case null stashOutput of
986− case os of
531+ False -> do
987− ThunkSource_GitHub s -> githubThunkRev s commit
532+ fail $ unlines $
988− ThunkSource_Git s -> gitThunkRev s commit
533+ [ "thunk pack: thunk checkout has stashes"
989−
534+ , "git stash list:"
990−-- | Convert a URI to a thunk
535+ ] ++ lines stashOutput
991−--
536+ True -> return ()
992−-- If the URL is a github URL, we try to just download an archive for
537+
993−-- performance. If that doesn't work (e.g. authentication issue), we fall back
538+ --Check whether all local heads are pushed
994−-- on just doing things the normal way for git repos in general, and save it as
539+ repoHeads <- lines <$> readProcess "hub"
995−-- a regular git thunk.
540+ [ "-C", thunkDir
996−uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
541+ , "for-each-ref", "--format=%(refname:short)", "refs/heads/"
997−uriThunkPtr uri mPrivate mbranch mcommit = do
542+ ] ""
998− commit <- case mcommit of
543+ remotes <- lines <$> readProcess "hub" [ "-C", thunkDir, "remote" ] ""
999− Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
544+ --Check that the upstream specified actually exists
1000− (Just c) -> return c
545+ case L.find (== upstream) remotes of
1001− (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
546+ Nothing -> fail $ "thunk pack: upstream " <> upstream <> " does not exist"
1002− ThunkSource_GitHub s -> do
547+ Just _ -> return ()
1003− rev <- runExceptT $ githubThunkRev s commit
548+ -- iterate over cartesian product
1004− case rev of
549+ forM_ repoHeads $ \hd -> do
1005− Right r -> pure (ThunkSource_GitHub s, r)
550+ [localRev] <- lines <$> readProcess "hub" [ "-C", thunkDir, "rev-parse", hd ] ""
1006− Left e -> do
551+ forM_ remotes $ \rm -> do
1007− putLog Warning "\
552+ --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
1008−\Failed to fetch archive from GitHub. This is probably a private repo. \
553+ [remoteMergeRev] <- lines <$> readProcess "hub"
1009−\Falling back on normal fetchgit. Original failure:"
554+ [ "-C", thunkDir
1010− errorToWarning e
555+ , "merge-base"
1011− let s' = forgetGithub True s
556+ , localRev
1012− (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
557+ , "remotes/" <> rm <> "/" <> hd
1013− ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
558+ ] ""
1014− pure $ ThunkPtr
559+ case remoteMergeRev == localRev of
1015− { _thunkPtr_rev = rev
560+ False -> fail $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
1016− , _thunkPtr_source = src
561+ True -> return ()
1018−
563+ --We assume it's safe to pack the thunk at this point
1019−-- | N.B. Cannot infer all fields.
564+ [remoteUri'] <- lines <$> readProcess "hub"
1020−--
565+ [ "-C", thunkDir
1021−-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
566+ , "config", "--get", "remote." <> upstream <> ".url"
1022−-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
567+ ] ""
1023−-- should be employed, and so we respect that.
568+
1024−uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
569+ let uriParseFailure = "Could not identify git remote: " <> remoteUri'
1025−uriToThunkSource (GitUri u) mPrivate
570+ mRemoteUri = parseURIReference remoteUri'
1026− | Right uriAuth <- URI.uriAuthority u
571+ <|> parseSshShorthand remoteUri'
1027− , Just scheme <- URI.unRText <$> URI.uriScheme u
572+ thunkPtr <- case mRemoteUri of
1028− , case scheme of
573+ Nothing -> fail uriParseFailure
1029− "ssh" -> uriAuth == URI.Authority
574+ Just remoteUri -> do
1030− { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
575+ refs <- fmap (refsToTuples . words) . lines <$> readProcess "hub"
1031− , URI.authHost = fromRight' $ URI.mkHost "github.com"
576+ [ "-C"
1032− , URI.authPort = Nothing
577+ , thunkDir
1034− s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
579+ , "--head" ] ""
1035− && URI.unRText (URI.authHost uriAuth) == "github.com"
580+ -- safe because exactly one hash is associated with HEAD
1036− , Just (_, owner :| [repoish]) <- URI.uriPath u
581+ let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
1037− = \mbranch -> do
582+ remoteHeads = Map.fromList $ catMaybes $ fmap
1038− isPrivate <- getIsPrivate
583+ (\(x,y) -> (,) x <$> L.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
1039− pure $ ThunkSource_GitHub $ GitHubSource
584+ refs
1040− { _gitHubSource_owner = N $ URI.unRText owner
585+ localHeads = Map.fromList $ catMaybes $ fmap
1041− , _gitHubSource_repo = N $ let
586+ (\(x,y) -> (,) x <$> L.stripPrefix "refs/heads/" y)
1042− repoish' = URI.unRText repoish
587+ refs
1043− in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
588+ currentUpstreamBranch = Map.lookup currentHead remoteHeads
1044− , _gitHubSource_branch = N <$> mbranch
589+ <|> Map.lookup currentHead localHeads
1045− , _gitHubSource_private = isPrivate
590+ if
591+ | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch
592+ | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch
595+ refsToTuples [x, y] = (x, y)
596+ refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
598+ | Just uriAuth <- uriAuthority u
599+ = case uriScheme u of
600+ "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""
601+ s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"
602+ && uriRegName uriAuth == "github.com"
604+ githubThunkPtr u commit' branch' = do
605+ ["/", owner', repo'] <- return $ splitDirectories (uriPath u)
606+ let owner = N (T.pack owner')
607+ repo = N (T.pack (dropExtension repo'))
608+ commit = N (T.pack commit')
609+ branch = N . T.pack <$> branch'
610+ mauth <- getHubAuth "github.com"
611+ repoResult <- executeRequestMaybe mauth $ repositoryR owner repo
612+ repoIsPrivate <- either throwIO (return . repoPrivate) repoResult
613+ archiveResult <- executeRequestMaybe mauth $
614+ archiveForR owner repo ArchiveFormatTarball (Just (untagName commit))
615+ archiveUri <- either throwIO return archiveResult
616+ hash <- getNixSha256ForUriUnpacked archiveUri
618+ { _thunkPtr_rev = ThunkRev
619+ { _thunkRev_commit = commitNameToRef commit
620+ , _thunkRev_nixSha256 = hash
1047−
622+ , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
1048− | otherwise = \mbranch -> do
623+ { _gitHubSource_owner = owner
1049− isPrivate <- getIsPrivate
624+ , _gitHubSource_repo = repo
1050− pure $ ThunkSource_Git $ GitSource
625+ , _gitHubSource_branch = branch
1051− { _gitSource_url = GitUri u
626+ , _gitHubSource_private = repoIsPrivate
1052− , _gitSource_branch = N <$> mbranch
1053− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
1054− , _gitSource_private = isPrivate
1057− getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
1059−guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
1060−guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
1062− uriAttempt:xs -> do
1063− result <- readCreateProcessWithExitCode $
1070− , T.unpack $ gitUriToText uriAttempt
1073− (ExitSuccess, _, _) -> pure False -- Must be a public repo
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
1084−
629+ gitThunkPtr u _commit' _branch' = do
1085−-- Funny signature indicates no effects depend on the optional branch name.
630+ case uriScheme u of
1086−githubThunkRev
631+ "https:" -> return ()
1087− :: forall m
632+ "git:" -> return ()
1088− . MonadObelisk m
633+ _ -> fail $ "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"
1089− => GitHubSource
634+ $notImplemented
1090− -> Text
635+ parseSshShorthand uri' = do
1091− -> m ThunkRev
636+ -- This is what git does to check that the remote
1092−githubThunkRev s commit = do
637+ -- is not a local file path when parsing shorthand.
1093− owner <- forcePP $ _gitHubSource_owner s
638+ -- Last referenced from here:
1094− repo <- forcePP $ _gitHubSource_repo s
639+ -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
1095− revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
640+ let uri = T.pack uri'
1096− let archiveUri = GitUri $ URI.URI
641+ (authAndHostname, colonAndPath) = T.break (== ':') uri
1097− { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
642+ properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
1098− , URI.uriAuthority = Right $ URI.Authority
643+ -- Shorthand is valid iff a colon is present and it occurs before the first slash
1099− { URI.authUserInfo = Nothing
644+ -- This check is used to disambiguate a filepath containing a colon from shorthand
1100− , URI.authHost = fromRight' $ URI.mkHost "github.com"
645+ guard $ isNothing (T.findIndex (=='/') authAndHostname)
1101− , URI.authPort = Nothing
646+ && not (T.null colonAndPath)
1102− }
647+ parseURI $ T.unpack properUri
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
1112− { _thunkRev_commit = commitNameToRef $ N commit
1113− , _thunkRev_nixSha256 = hash
1116− forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
1117− forcePP = URI.mkPathPiece . untagName
1124−gitThunkRev 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
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.
1145− :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
1146−gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
1147− (_, bothMaps) <- gitLsRemote
1148− (T.unpack $ gitUriToText uri)
1149− (GitRef_Branch <$> mbranch)
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
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)
1163− rethrowE = either failWith pure
1164− uriMsg = gitUriToText uri
1166−parseGitUri :: Text -> Maybe GitUri
1167−parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
1169−parseFileURI :: Text -> Maybe URI.URI
1170−parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
1172−parseAbsoluteURI :: Text -> Maybe URI.URI
1173−parseAbsoluteURI uri = do
1174− parsedUri <- URI.mkURI uri
1175− guard $ URI.isPathAbsolute parsedUri
1178−parseSshShorthand :: Text -> Maybe URI.URI
1179−parseSshShorthand 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
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