@@ -5,62 +5,48 @@
5{-# LANGUAGE MultiWayIf #-}
5{-# LANGUAGE MultiWayIf #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE PatternGuards #-}
8+{-# LANGUAGE QuasiQuotes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeApplications #-}
10−module Obelisk.Command.Thunk
11+module Obelisk.Command.Thunk where
15− , ReadThunkError (..)
19− , updateThunkToLatest
21− , createThunkWithLatest
22− , nixBuildAttrWithCache
23− , nixBuildThunkAttrWithCache
35import Control.Applicative
13import Control.Applicative
36import Control.Exception (displayException, try)
14import Control.Exception (displayException, try)
37−import qualified Control.Lens as Lens
15+import Control.Lens (ifor, ifor_, (.~))
38−import Control.Lens.Indexed hiding ((<.>))
39import Control.Monad
16import Control.Monad
40−import Control.Monad.Catch (handle)
17+import Control.Monad.Extra (findM)
18+import Control.Monad.Catch (MonadCatch, handle)
41import Control.Monad.Except
19import Control.Monad.Except
42import Data.Aeson ((.=))
20import Data.Aeson ((.=))
43import qualified Data.Aeson as Aeson
21import qualified Data.Aeson as Aeson
44import Data.Aeson.Encode.Pretty
22import Data.Aeson.Encode.Pretty
45import qualified Data.Aeson.Types as Aeson
23import qualified Data.Aeson.Types as Aeson
24+import Data.Bifunctor (first)
46import qualified Data.ByteString.Lazy as LBS
25import qualified Data.ByteString.Lazy as LBS
26+import Data.Containers.ListUtils (nubOrd)
47import Data.Default
27import Data.Default
48import Data.Either.Combinators (fromRight', rightToMaybe)
28import Data.Either.Combinators (fromRight', rightToMaybe)
29+import Data.Foldable (toList)
30+import Data.Function ((&))
31+import Data.Functor ((<&>))
49import Data.Git.Ref (Ref)
32import Data.Git.Ref (Ref)
50import qualified Data.Git.Ref as Ref
33import qualified Data.Git.Ref as Ref
51import qualified Data.List as L
34import qualified Data.List as L
52−import Data.List.NonEmpty (NonEmpty (..))
35+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
53import qualified Data.List.NonEmpty as NonEmpty
36import qualified Data.List.NonEmpty as NonEmpty
54import Data.Map (Map)
37import Data.Map (Map)
55import qualified Data.Map as Map
38import qualified Data.Map as Map
56import Data.Maybe
39import Data.Maybe
57import Data.Set (Set)
40import Data.Set (Set)
58import qualified Data.Set as Set
41import qualified Data.Set as Set
42+import Data.String.Here.Interpolated (i)
43+import Data.String.Here.Uninterpolated (here)
59import Data.Text (Text)
44import Data.Text (Text)
60import qualified Data.Text as T
45import qualified Data.Text as T
61import Data.Text.Encoding
46import Data.Text.Encoding
62import qualified Data.Text.IO as T
47import qualified Data.Text.IO as T
63import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
48import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
49+import Data.Traversable (for)
64import Data.Yaml (parseMaybe)
50import Data.Yaml (parseMaybe)
65import GitHub
51import GitHub
66import GitHub.Data.Name
52import GitHub.Data.Name
@@ -70,9 +56,8 @@ import System.Exit
70import System.FilePath
56import System.FilePath
71import System.IO.Error
57import System.IO.Error
72import System.IO.Temp
58import System.IO.Temp
73−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
74−import System.Process (proc)
60+import qualified Text.URI as URI
77import Obelisk.App (MonadObelisk)
62import Obelisk.App (MonadObelisk)
78import Obelisk.CliApp
63import Obelisk.CliApp
@@ -80,11 +65,10 @@ import Obelisk.Command.Utils
81--TODO: Support symlinked thunk data
66--TODO: Support symlinked thunk data
82data ThunkData
67data ThunkData
83− = ThunkData_Packed ThunkPtr
68+ = ThunkData_Packed ThunkSpec ThunkPtr
84 -- ^ Packed thunk
69 -- ^ Packed thunk
85− | ThunkData_Checkout (Maybe ThunkPtr)
70+ | ThunkData_Checkout
86 -- ^ Checked out thunk that was unpacked from this pointer
71 -- ^ Checked out thunk that was unpacked from this pointer
87− deriving (Show, Eq, Ord)
89-- | A reference to the exact data that a thunk should translate into
73-- | A reference to the exact data that a thunk should translate into
90data ThunkPtr = ThunkPtr
74data ThunkPtr = ThunkPtr
@@ -97,7 +81,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
98-- | A specific revision of data; it may be available from multiple sources
82-- | A specific revision of data; it may be available from multiple sources
99data ThunkRev = ThunkRev
83data ThunkRev = ThunkRev
100− { _thunkRev_commit :: Ref
84+ { _thunkRev_commit :: Ref Ref.SHA1
101 , _thunkRev_nixSha256 :: NixSha256
85 , _thunkRev_nixSha256 :: NixSha256
103 deriving (Show, Eq, Ord)
87 deriving (Show, Eq, Ord)
@@ -110,41 +94,72 @@ data ThunkSource
110 | ThunkSource_Git GitSource
94 | ThunkSource_Git GitSource
111 deriving (Show, Eq, Ord)
95 deriving (Show, Eq, Ord)
97+thunkSourceToGitSource :: ThunkSource -> GitSource
98+thunkSourceToGitSource = \case
99+ ThunkSource_GitHub s -> forgetGithub False s
100+ ThunkSource_Git s -> s
113data GitHubSource = GitHubSource
102data GitHubSource = GitHubSource
114 { _gitHubSource_owner :: Name Owner
103 { _gitHubSource_owner :: Name Owner
115 , _gitHubSource_repo :: Name Repo
104 , _gitHubSource_repo :: Name Repo
116 , _gitHubSource_branch :: Maybe (Name Branch)
105 , _gitHubSource_branch :: Maybe (Name Branch)
106+ , _gitHubSource_private :: Bool
118 deriving (Show, Eq, Ord)
108 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
120data GitSource = GitSource
119data GitSource = GitSource
121− { _gitSource_url :: URI
120+ { _gitSource_url :: GitUri
122 , _gitSource_branch :: Maybe (Name Branch)
121 , _gitSource_branch :: Maybe (Name Branch)
123 , _gitSource_fetchSubmodules :: Bool
122 , _gitSource_fetchSubmodules :: Bool
123+ , _gitSource_private :: Bool
125 deriving (Show, Eq, Ord)
125 deriving (Show, Eq, Ord)
127+newtype ThunkConfig = ThunkConfig
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
127-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
141-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
128forgetGithub :: Bool -> GitHubSource -> GitSource
142forgetGithub :: Bool -> GitHubSource -> GitSource
129forgetGithub useSsh s = GitSource
143forgetGithub useSsh s = GitSource
130− { _gitSource_url = URI
144+ { _gitSource_url = GitUri $ URI.URI
131− { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"
145+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"
132− , uriAuthority = Right $ Authority
146+ , URI.uriAuthority = Right $ URI.Authority
133− { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing
147+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
134 <$ guard useSsh
148 <$ guard useSsh
135− , authHost = fromRight' $ mkHost "github.com"
149+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
136− , authPort = Nothing
150+ , URI.authPort = Nothing
138− , uriPath = Just ( False
152+ , URI.uriPath = Just ( False
139− , fromRight' . mkPathPiece <$>
153+ , fromRight' . URI.mkPathPiece <$>
140 untagName (_gitHubSource_owner s)
154 untagName (_gitHubSource_owner s)
141 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
155 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
143− , uriQuery = []
157+ , URI.uriQuery = []
144− , uriFragment = Nothing
158+ , URI.uriFragment = Nothing
146 , _gitSource_branch = _gitHubSource_branch s
160 , _gitSource_branch = _gitHubSource_branch s
147 , _gitSource_fetchSubmodules = False
161 , _gitSource_fetchSubmodules = False
162+ , _gitSource_private = _gitHubSource_private s
150getThunkGitBranch :: ThunkPtr -> Maybe Text
165getThunkGitBranch :: ThunkPtr -> Maybe Text
@@ -152,26 +167,26 @@ getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
152 ThunkSource_GitHub s -> _gitHubSource_branch s
167 ThunkSource_GitHub s -> _gitHubSource_branch s
153 ThunkSource_Git s -> _gitSource_branch s
168 ThunkSource_Git s -> _gitSource_branch s
155−commitNameToRef :: Name Commit -> Ref
170+commitNameToRef :: Name Commit -> Ref Ref.SHA1
156commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
171commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
158-- TODO: Use spinner here.
173-- TODO: Use spinner here.
159getNixSha256ForUriUnpacked
174getNixSha256ForUriUnpacked
160 :: MonadObelisk m
175 :: MonadObelisk m
161− => URI
176+ => GitUri
162 -> m NixSha256
177 -> m NixSha256
163getNixSha256ForUriUnpacked uri =
178getNixSha256ForUriUnpacked uri =
164− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do
179+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
165 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
180 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
166− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]
181+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
167 pure hash
182 pure hash
169−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
184+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
170nixPrefetchGit uri rev fetchSubmodules =
185nixPrefetchGit uri rev fetchSubmodules =
171− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do
186+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
172 out <- readProcessAndLogStderr Debug $
187 out <- readProcessAndLogStderr Debug $
173− proc "nix-prefetch-git" $ filter (/="")
188+ proc nixPrefetchGitPath $ filter (/="")
174− [ "--url", T.unpack $ render uri
189+ [ "--url", T.unpack $ gitUriToText uri
175 , "--rev", T.unpack rev
190 , "--rev", T.unpack rev
176 , if fetchSubmodules then "--fetch-submodules" else ""
191 , if fetchSubmodules then "--fetch-submodules" else ""
177 , "--quiet"
192 , "--quiet"
@@ -183,93 +198,117 @@ nixPrefetchGit uri rev fetchSubmodules =
184--TODO: Pretty print these
199--TODO: Pretty print these
185data ReadThunkError
200data ReadThunkError
186− = ReadThunkError_UnrecognizedFiles
201+ = ReadThunkError_UnrecognizedThunk
187− | ReadThunkError_AmbiguousFiles
202+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
188− | ReadThunkError_UnrecognizedLoader Text
203+ | ReadThunkError_MissingPaths (NonEmpty FilePath)
189− | ReadThunkError_UnparseablePtr LBS.ByteString
204+ | ReadThunkError_UnparseablePtr FilePath String
190− deriving (Show)
205+ | ReadThunkError_FileError IOError
191−
206+ | ReadThunkError_FileDoesNotMatch FilePath Text
192−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
207+ | ReadThunkError_UnrecognizedState String
193−-- If the thunk is packed and additional data is present, fail.
208+ | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
194−readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
209+ deriving (Show)
195−readThunk thunkDir = do
210+
196− files <- liftIO $ listDirectory thunkDir
211+unpackedDirName :: FilePath
197− case ".git" `elem` files of
212+unpackedDirName = "."
198− True -> fmap ThunkData_Checkout <$> do
213+
199− let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
214+attrCacheFileName :: FilePath
200− liftIO $ doesDirectoryExist origThunkPath >>= \case
215+attrCacheFileName = ".attr-cache"
201− True -> fmap Just <$> readPackedThunk origThunkPath
216+
202− False -> return $ return Nothing
217+-- | Specification for how a file in a thunk version works.
203− False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
218+data ThunkFileSpec
204−
219+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
205−data ThunkType = ThunkType
220+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
206− { _thunkType_loader :: FilePath
221+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
207− , _thunkType_json :: FilePath
222+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
208− , _thunkType_optional :: Set FilePath
223+
209− , _thunkType_loaderVersions :: NonEmpty Text
224+-- | Specification for how a set of files in a thunk version work.
210− , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr
225+data ThunkSpec = ThunkSpec
226+ { _thunkSpec_name :: !Text
227+ , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
213−gitHubThunkType :: ThunkType
230+thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
214−gitHubThunkType = ThunkType
231+thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
215− { _thunkType_loader = "default.nix"
232+
216− , _thunkType_json = "github.json"
233+-- | Attempts to match a 'ThunkSpec' to a given directory.
217− , _thunkType_optional = Set.fromList [".attr-cache"]
234+matchThunkSpecToDir
218− , _thunkType_loaderVersions = gitHubStandaloneLoaders
235+ :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
219− , _thunkType_parser = parseThunkPtr $ \v ->
236+ => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
220− ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
237+ -> FilePath -- ^ Path to directory
221− }
238+ -> Set FilePath -- ^ Set of file paths relative to the given directory
223−gitThunkType :: ThunkType
240+matchThunkSpecToDir thunkSpec dir dirFiles = do
224−gitThunkType = ThunkType
241+ case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
225− { _thunkType_loader = "default.nix"
242+ Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
226− , _thunkType_json = "git.json"
243+ Nothing -> pure ()
227− , _thunkType_optional = Set.fromList [".attr-cache"]
244+ case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
228− , _thunkType_loaderVersions = plainGitStandaloneLoaders
245+ Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
229− , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
246+ Nothing -> pure ()
230− }
247+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
231−
248+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
232−thunkTypes :: [ThunkType]
249+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
233−thunkTypes = [gitThunkType, gitHubThunkType]
250+ False -> Nothing
234−
251+ True -> Just ThunkData_Checkout
235−findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)
252+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
236−findThunkType types thunkDir = do
253+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)
237− matches <- fmap catMaybes $ forM types $ \thunkType -> do
254+ case T.strip expectedContents == T.strip actualContents of
238− let
255+ True -> pure Nothing
239− expectedContents = Set.fromList $ (thunkDir </>) <$>
256+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
240− [ _thunkType_loader thunkType
257+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
241− , _thunkType_json thunkType
258+ let path = dir </> expectedPath
242− ]
259+ liftIO (doesFileExist path) >>= \case
243− optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)
260+ False -> pure Nothing
245− -- Ensure that there aren't any other files in the thunk
262+ actualContents <- liftIO $ LBS.readFile path
246− -- NB: System.Directory.listDirectory returns the contents without the directory path
263+ case parser actualContents of
247− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
264+ Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
248− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
265+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
249− missingContents = expectedContents `Set.difference` files
266+
250− pure $ if Set.null unexpectedContents && Set.null missingContents
267+ case nonEmpty datas of
251− then Just thunkType
268+ Nothing -> throwError ReadThunkError_UnrecognizedThunk
252− else Nothing
269+ Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
254− pure $ case matches of
271+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
255− [singleMatch] -> Right singleMatch
272+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
256− [] -> Left ReadThunkError_UnrecognizedFiles
273+
257− _ -> Left ReadThunkError_AmbiguousFiles
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}|]
259-- | Read a thunk and validate that it is exactly a packed thunk.
308-- | Read a thunk and validate that it is exactly a packed thunk.
260-- If additional data is present, fail.
309-- If additional data is present, fail.
261−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
262−readPackedThunk thunkDir = runExceptT $ do
311+readThunk = readThunkWith thunkSpecTypes
263− thunkType <- ExceptT $ findThunkType thunkTypes thunkDir
264− -- Ensure that we recognize the thunk loader
265− loader <- liftIO $ T.readFile $ thunkDir </> _thunkType_loader thunkType
266− unless (loader `elem` _thunkType_loaderVersions thunkType) $ do
267− throwError $ ReadThunkError_UnrecognizedLoader loader
269− txt <- liftIO $ LBS.readFile $ thunkDir </> _thunkType_json thunkType
270− case parseMaybe (_thunkType_parser thunkType) =<< Aeson.decode txt of
271− Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
272− Just ptr -> return ptr
274parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
313parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
275parseThunkPtr parseSrc v = do
314parseThunkPtr parseSrc v = do
@@ -289,10 +328,12 @@ parseGitHubSource v = do
289 owner <- v Aeson..: "owner"
328 owner <- v Aeson..: "owner"
290 repo <- v Aeson..: "repo"
329 repo <- v Aeson..: "repo"
291 branch <- v Aeson..:! "branch"
330 branch <- v Aeson..:! "branch"
331+ private <- v Aeson..:? "private"
292 pure $ GitHubSource
332 pure $ GitHubSource
293 { _gitHubSource_owner = owner
333 { _gitHubSource_owner = owner
294 , _gitHubSource_repo = repo
334 , _gitHubSource_repo = repo
295 , _gitHubSource_branch = branch
335 , _gitHubSource_branch = branch
336+ , _gitHubSource_private = fromMaybe False private
298parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
339parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
@@ -300,25 +341,29 @@ parseGitSource v = do
300 Just url <- parseGitUri <$> v Aeson..: "url"
341 Just url <- parseGitUri <$> v Aeson..: "url"
301 branch <- v Aeson..:! "branch"
342 branch <- v Aeson..:! "branch"
302 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
343 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
344+ private <- v Aeson..:? "private"
303 pure $ GitSource
345 pure $ GitSource
304 { _gitSource_url = url
346 { _gitSource_url = url
305 , _gitSource_branch = branch
347 , _gitSource_branch = branch
306 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
348 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
349+ , _gitSource_private = fromMaybe False private
309overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
352overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
310overwriteThunk target thunk = do
353overwriteThunk target thunk = do
311 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
354 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
312− Right _ <- readThunk target
355+ readThunk target >>= \case
356+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
314 --TODO: Is there a safer way to do this overwriting?
359 --TODO: Is there a safer way to do this overwriting?
315− liftIO $ removeDirectoryRecursive target
360+ liftIO $ removePathForcibly target
316− liftIO $ createThunk target thunk
361+ createThunk target $ Right thunk
318−thunkPtrLoader :: ThunkPtr -> Text
363+thunkPtrToSpec :: ThunkPtr -> ThunkSpec
319−thunkPtrLoader thunk = case _thunkPtr_source thunk of
364+thunkPtrToSpec thunk = case _thunkPtr_source thunk of
320− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
365+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
321− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
366+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
323-- It's important that formatting be very consistent here, because
368-- It's important that formatting be very consistent here, because
324-- otherwise when people update thunks, their patches will be messy
369-- otherwise when people update thunks, their patches will be messy
@@ -330,13 +375,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
330 , ("branch" .=) <$> _gitHubSource_branch s
375 , ("branch" .=) <$> _gitHubSource_branch s
331 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
376 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
332 , Just $ "sha256" .= _thunkRev_nixSha256 rev
377 , Just $ "sha256" .= _thunkRev_nixSha256 rev
378+ , Just $ "private" .= _gitHubSource_private s
334 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
380 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
335− [ Just $ "url" .= render (_gitSource_url s)
381+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
336 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
382 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
337 , ("branch" .=) <$> _gitSource_branch s
383 , ("branch" .=) <$> _gitSource_branch s
338 , Just $ "sha256" .= _thunkRev_nixSha256 rev
384 , Just $ "sha256" .= _thunkRev_nixSha256 rev
339 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
385 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
386+ , Just $ "private" .= _gitSource_private s
342 githubCfg = defConfig
389 githubCfg = defConfig
@@ -357,62 +404,84 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
359 , "sha256"
406 , "sha256"
360 , "fetchSubmodules"
408 , "fetchSubmodules"
361 ] <> compare
409 ] <> compare
362 , confTrailingNewline = True
410 , confTrailingNewline = True
365−createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
413+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
366−createThunk target thunk = liftIO $ do
414+createThunk target ptrInfo =
367− createDirectoryIfMissing True (target </> ".attr-cache")
415+ ifor_ (_thunkSpec_files spec) $ \path -> \case
368− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
416+ ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
369− let
417+ ThunkFileSpec_Ptr _ -> case ptrInfo of
370− jsonFileName = case _thunkPtr_source thunk of
418+ Left _ -> pure () -- We can't write the ptr without it
371− ThunkSource_GitHub _ -> "github"
372− ThunkSource_Git _ -> "git"
373− LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)
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
375createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
429createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
376createThunkWithLatest target s = do
430createThunkWithLatest target s = do
377 rev <- getLatestRev s
431 rev <- getLatestRev s
378− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
379 { _thunkPtr_source = s
433 { _thunkPtr_source = s
380 , _thunkPtr_rev = rev
434 , _thunkPtr_rev = rev
383−updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()
437+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
384−updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $
438+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
439+ checkThunkDirectory target
440+ -- check to see if thunk should be updated to a specific branch or just update it's current branch
385 case mBranch of
441 case mBranch of
386 Nothing -> do
442 Nothing -> do
387 (overwrite, ptr) <- readThunk target >>= \case
443 (overwrite, ptr) <- readThunk target >>= \case
388− Left err -> failWith $ T.pack $ "thunk update: " <> show err
444+ Left err -> failWith [i|Thunk update: ${err}|]
389 Right c -> case c of
445 Right c -> case c of
390− ThunkData_Packed t -> return (target, t)
446+ ThunkData_Packed _ t -> return (target, t)
391− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
392 let src = _thunkPtr_source ptr
448 let src = _thunkPtr_source ptr
393 rev <- getLatestRev src
449 rev <- getLatestRev src
394− overwriteThunk overwrite $ ThunkPtr
450+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
395 { _thunkPtr_source = src
451 { _thunkPtr_source = src
396 , _thunkPtr_rev = rev
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 ()
398− Just branch -> setThunk branch target
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
400-- | All recognized github standalone loaders, ordered from newest to oldest.
468-- | All recognized github standalone loaders, ordered from newest to oldest.
401-- This tool will only ever produce the newest one when it writes a thunk.
469-- This tool will only ever produce the newest one when it writes a thunk.
402−gitHubStandaloneLoaders :: NonEmpty Text
470+gitHubThunkSpecs :: NonEmpty ThunkSpec
403−gitHubStandaloneLoaders =
471+gitHubThunkSpecs =
404− gitHubStandaloneLoaderV2 :|
472+ gitHubThunkSpecV5 :|
405− [ gitHubStandaloneLoaderV3
473+ [ gitHubThunkSpecV4
406− , gitHubStandaloneLoaderV1
474+ , gitHubThunkSpecV3
409−gitHubStandaloneLoaderV1 :: Text
479+gitHubThunkSpecV1 :: ThunkSpec
410−gitHubStandaloneLoaderV1 = T.unlines
480+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
411− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
481+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
414−gitHubStandaloneLoaderV2 :: Text
483+gitHubThunkSpecV2 :: ThunkSpec
415−gitHubStandaloneLoaderV2 = T.unlines
484+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
416 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
485 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
417 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
418 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -422,8 +491,8 @@ gitHubStandaloneLoaderV2 = T.unlines
425−gitHubStandaloneLoaderV3 :: Text
494+gitHubThunkSpecV3 :: ThunkSpec
426−gitHubStandaloneLoaderV3 = T.unlines
495+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
427 [ "# DO NOT HAND-EDIT THIS FILE"
496 [ "# DO NOT HAND-EDIT THIS FILE"
429 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
498 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
@@ -442,22 +511,62 @@ gitHubStandaloneLoaderV3 = T.unlines
442 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
445−plainGitStandaloneLoaders :: NonEmpty Text
514+gitHubThunkSpecV4 :: ThunkSpec
446−plainGitStandaloneLoaders =
515+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
447− plainGitStandaloneLoaderV1 :|
516+ [ "# DO NOT HAND-EDIT THIS FILE"
448− [ plainGitStandaloneLoaderV2
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
527+legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
528+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
529+ , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
530+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
531+ , (".git", ThunkFileSpec_CheckoutIndicator)
534+gitHubThunkSpecV5 :: ThunkSpec
535+gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|
536+# DO NOT HAND-EDIT THIS FILE
537+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
538+ if !fetchSubmodules && !private then builtins.fetchTarball {
539+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
540+ } else (import <nixpkgs> {}).fetchFromGitHub {
541+ inherit owner repo rev sha256 fetchSubmodules private;
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
451−plainGitStandaloneLoaderV1 :: Text
560+gitThunkSpecV1 :: ThunkSpec
452−plainGitStandaloneLoaderV1 = T.unlines
561+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
453 [ "# DO NOT HAND-EDIT THIS FILE"
562 [ "# DO NOT HAND-EDIT THIS FILE"
454 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
563 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
455 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
564 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
456 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
565 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
459−plainGitStandaloneLoaderV2 :: Text
568+gitThunkSpecV2 :: ThunkSpec
460−plainGitStandaloneLoaderV2 = T.unlines
569+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
461 [ "# DO NOT HAND-EDIT THIS FILE"
570 [ "# DO NOT HAND-EDIT THIS FILE"
462 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
571 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
463 , " if builtins.hasAttr \"fetchGit\" builtins"
572 , " if builtins.hasAttr \"fetchGit\" builtins"
@@ -466,10 +575,87 @@ plainGitStandaloneLoaderV2 = T.unlines
466 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
575 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
469−thunkFileNames :: [FilePath]
578+-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
470−thunkFileNames = ["default.nix", "github.json", "git.json"]
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)
472−--TODO: when checking something out, make a shallow clone
657+parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
658+parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
474-- | Checks a cache directory to see if there is a fresh symlink
660-- | Checks a cache directory to see if there is a fresh symlink
475-- to the result of building an attribute of a thunk.
661-- to the result of building an attribute of a thunk.
@@ -477,44 +663,49 @@ thunkFileNames = ["default.nix", "github.json", "git.json"]
477-- and the result is symlinked into the cache.
663-- and the result is symlinked into the cache.
478nixBuildThunkAttrWithCache
664nixBuildThunkAttrWithCache
479 :: MonadObelisk m
665 :: MonadObelisk m
480− => FilePath
667+ -> FilePath
481 -- ^ Path to directory containing Thunk
668 -- ^ Path to directory containing Thunk
482 -> String
669 -> String
483 -- ^ Attribute to build
670 -- ^ Attribute to build
484− -> m FilePath
671+ -> m (Maybe FilePath)
485 -- ^ Symlink to cached or built nix output
672 -- ^ Symlink to cached or built nix output
486-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
673-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
487-- the caching mechanism will fail as it merely measures the modification
674-- the caching mechanism will fail as it merely measures the modification
488-- time of the cache link and the expression to build.
675-- time of the cache link and the expression to build.
489−nixBuildThunkAttrWithCache thunkDir attr = do
676+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
490− --NB: Expects thunkDir to be normalised with no trailing path separator.
491− --This should be guaranteed by the command argument parser.
492− let cacheErrHandler e
493− | isDoesNotExistError e = return Nothing -- expected from a cache miss
494− | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
495− cacheDir = thunkDir </> ".attr-cache"
496− cachePath = cacheDir </> attr <.> "out"
497 latestChange <- liftIO $ do
677 latestChange <- liftIO $ do
498− createDirectoryIfMissing False cacheDir
678+ let
499− let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
679+ getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
680+ thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
500− maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
681+ maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
683+ let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
684+ _thunkSpec_files thunkSpec
685+ for cachePaths' $ \cachePaths ->
686+ fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
688+ cachePath = thunkDir </> cacheDir </> attr <.> "out"
690+ | isDoesNotExistError e = pure Nothing -- expected from a cache miss
691+ | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
501− cacheHit <- handle cacheErrHandler $ do
692+ cacheHit <- handle cacheErrHandler $ do
502− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
693+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
503− return $ if latestChange <= cacheTime
694+ pure $ if latestChange <= cacheTime
504− then Just cachePath
695+ then Just cachePath
505− else Nothing
696+ else Nothing
506− case cacheHit of
697+ case cacheHit of
507− Just c -> return c
698+ Just c -> pure c
508− Nothing -> do
699+ Nothing -> do
509− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
700+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
701+ liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
510− _ <- nixCmd $ NixCmd_Build$ def
702+ (cachePath <$) $ nixCmd $ NixCmd_Build $ def
511− Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
703+ & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath
512− Lens.& nixCmdConfig_target Lens..~ Target
704+ & nixCmdConfig_target .~ Target
513− { _target_path = Just thunkDir
705+ { _target_path = Just thunkDir
514− , _target_attr = Just attr
706+ , _target_attr = Just attr
515− , _target_expr = Nothing
707+ , _target_expr = Nothing
519-- | Build a nix attribute, and cache the result if possible
710-- | Build a nix attribute, and cache the result if possible
520nixBuildAttrWithCache
711nixBuildAttrWithCache
@@ -525,13 +716,15 @@ nixBuildAttrWithCache
525 -- ^ Attribute to build
716 -- ^ Attribute to build
526 -> m FilePath
717 -> m FilePath
527 -- ^ Symlink to cached or built nix output
718 -- ^ Symlink to cached or built nix output
528−nixBuildAttrWithCache exprPath attr = do
719+nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
529− readThunk exprPath >>= \case
530− -- Only packed thunks are cached. in particular, checkouts are not
720+ -- Only packed thunks are cached. In particular, checkouts are not.
721+ Right (ThunkData_Packed spec _) ->
531− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
722+ maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
532− _ -> nixCmd $ NixCmd_Build $ def
725+ build = nixCmd $ NixCmd_Build $ def
533− Lens.& nixBuildConfig_outLink Lens..~ OutLink_None
726+ & nixBuildConfig_outLink .~ OutLink_None
534− Lens.& nixCmdConfig_target Lens..~ Target
727+ & nixCmdConfig_target .~ Target
535 { _target_path = Just exprPath
728 { _target_path = Just exprPath
536 , _target_attr = Just attr
729 , _target_attr = Just attr
537 , _target_expr = Nothing
730 , _target_expr = Nothing
@@ -552,142 +745,153 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
553 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
746 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
554 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
747 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
555− Right (ThunkData_Packed _) -> do
748+ Right ThunkData_Packed{} -> do
556 let tmpThunk = tmpDir </> "thunk"
749 let tmpThunk = tmpDir </> "thunk"
557 callProcessAndLogOutput (Notice, Error) $
750 callProcessAndLogOutput (Notice, Error) $
558− proc "cp" ["-r", "-T", thunkDir, tmpThunk]
751+ proc cp ["-r", "-T", thunkDir, tmpThunk]
559 return tmpThunk
752 return tmpThunk
560− Right _ -> failWith $ "Thunk is not packed"
753+ Right _ -> failWith "Thunk is not packed"
561 updateThunkFromTmp p' = do
754 updateThunkFromTmp p' = do
562− _ <- packThunk' True p'
755+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
563 callProcessAndLogOutput (Notice, Error) $
756 callProcessAndLogOutput (Notice, Error) $
564− proc "cp" ["-r", "-T", p', p]
757+ proc cp ["-r", "-T", p', p]
566finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
759finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
567finalMsg noTrail s = if noTrail then Nothing else Just s
760finalMsg noTrail s = if noTrail then Nothing else Just s
569−unpackThunk :: MonadObelisk m => FilePath -> m ()
570−unpackThunk = unpackThunk' False
572-- | Check that we are not somewhere inside the thunk directory
762-- | Check that we are not somewhere inside the thunk directory
573checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
763checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
574checkThunkDirectory thunkDir = do
764checkThunkDirectory thunkDir = do
575 currentDir <- liftIO getCurrentDirectory
765 currentDir <- liftIO getCurrentDirectory
576 thunkDir' <- liftIO $ canonicalizePath thunkDir
766 thunkDir' <- liftIO $ canonicalizePath thunkDir
577 when (thunkDir' `L.isInfixOf` currentDir) $
767 when (thunkDir' `L.isInfixOf` currentDir) $
578− failWith "Can't pack/unpack from within the thunk directory"
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
580unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
779unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
581−unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir >> readThunk thunkDir >>= \case
780+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
582− Left err -> failWith $ "thunk unpack: " <> T.pack (show err)
781+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
583 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
782 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
584− Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
585− Right (ThunkData_Packed tptr) -> do
784+ Right (ThunkData_Packed _ tptr) -> do
586 let (thunkParent, thunkName) = splitFileName thunkDir
785 let (thunkParent, thunkName) = splitFileName thunkDir
587− withTempDirectory thunkParent thunkName $ \tmpRepo -> do
786+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
588− let obGitDir = tmpRepo </> ".git" </> "obelisk"
787+ let
788+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
589− s = case _thunkPtr_source tptr of
789+ newSpec = case _thunkPtr_source tptr of
590− ThunkSource_GitHub s' -> forgetGithub False s'
790+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
591− ThunkSource_Git s' -> s'
791+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
592 withSpinner' ("Fetching thunk " <> T.pack thunkName)
792 withSpinner' ("Fetching thunk " <> T.pack thunkName)
593 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
793 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
794+ let unpackedPath = tmpThunk </> unpackedDirName
795+ gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
797+ let normalizeMore = dropTrailingPathSeparator . normalise
798+ when (normalizeMore unpackedPath /= normalizeMore tmpThunk) $ -- Only write meta data if the checkout is not inplace
799+ createThunk tmpThunk $ Left newSpec
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
594− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
812+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
595− git $ [ "clone" ]
813+ git $ [ "clone" ]
596− ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
814+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
597− ++ [ T.unpack $ render $ _gitSource_url s ]
815+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
598− ++ do branch <- maybeToList $ _gitSource_branch s
816+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc
599− [ "--branch", T.unpack $ untagName branch ]
817+ [ "--branch", T.unpack $ untagName branch ]
600− git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
818+ git ["reset", "--hard", Ref.toHexString commit]
601− when (_gitSource_fetchSubmodules s) $
819+ when (_gitSource_fetchSubmodules gitSrc) $
602− git ["submodule", "update", "--recursive", "--init"]
820+ git ["submodule", "update", "--recursive", "--init"]
604− liftIO $ createDirectory obGitDir
605− callProcessAndLogOutput (Notice, Error) $
606− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
607− callProcessAndLogOutput (Notice, Error) $
608− proc "rm" ["-r", thunkDir]
609− callProcessAndLogOutput (Notice, Error) $
610− proc "mv" ["-T", tmpRepo, thunkDir]
612−--TODO: add force mode to pack even if changes are present
613--TODO: add a rollback mode to pack to the original thunk
822--TODO: add a rollback mode to pack to the original thunk
614−packThunk :: MonadObelisk m => FilePath -> m ThunkPtr
823+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
615packThunk = packThunk' False
824packThunk = packThunk' False
617−packThunk' :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr
826+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
618−packThunk' noTrail thunkDir = checkThunkDirectory thunkDir >> readThunk thunkDir >>= \case
827+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
619− Left err -> failWith $ T.pack $ "thunk pack: " <> show err
620− Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
828+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
621− Right (ThunkData_Checkout _) -> do
829+ _ -> withSpinner'
622− withSpinner' ("Packing thunk " <> T.pack thunkDir)
830+ ("Packing thunk " <> T.pack thunkDir)
623− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
831+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
833+ let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
624− thunkPtr <- getThunkPtr thunkDir
834+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
625− callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
835+ liftIO $ removePathForcibly thunkDir
626− liftIO $ createThunk thunkDir thunkPtr
836+ createThunk thunkDir $ Right thunkPtr
627 pure thunkPtr
837 pure thunkPtr
629−-- set thunk to a desired branch
839+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
630−setThunk :: MonadObelisk m => String -> FilePath -> m ()
840+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
631−setThunk branch thunkDir = checkThunkDirectory thunkDir >> readThunk thunkDir >>= \case
841+ Nothing -> ptr
632− Left err -> failWith $ T.pack $ "thunk set : " <> show err
633− Right (ThunkData_Packed thunkptr) -> do
634− let thunkSrc = _thunkPtr_source thunkptr
635− repository = case thunkSrc of
636− ThunkSource_Git gitSource -> T.unpack $ render $ _gitSource_url gitSource
637− ThunkSource_GitHub gitHubSource -> T.unpack $ render $ _gitSource_url $ forgetGithub True gitHubSource
638− -- check to see if branch exists before modifying directory
639− (exitCode, _) <- gitLsRemoteExitCode repository branch
642− remoteResults <- readGitProcessNoRepo ["ls-remote", repository, branch]
643− uri <- mkURI $ T.pack repository
644− let rev = head $ T.words remoteResults -- TODO: Don't use head
645− sha256 <- nixPrefetchGit uri rev False
646− let newThunkPtr = ThunkPtr
647− { _thunkPtr_source = case _thunkPtr_source thunkptr of
842+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of
648− ThunkSource_Git gitSource -> ThunkSource_Git GitSource
843+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }
649− { _gitSource_url = _gitSource_url gitSource
650− , _gitSource_branch = Just $ N $ T.pack branch
651− , _gitSource_fetchSubmodules = _gitSource_fetchSubmodules gitSource
653− ThunkSource_GitHub gitHubSource -> ThunkSource_GitHub GitHubSource
844+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
654− { _gitHubSource_owner = _gitHubSource_owner gitHubSource
655− , _gitHubSource_repo = _gitHubSource_repo gitHubSource
656− , _gitHubSource_branch = Just $ N $ T.pack branch
658− , _thunkPtr_rev = ThunkRev
846+
659− { _thunkRev_commit = Ref.hash $ encodeUtf8 rev
847+data CheckClean
660− , _thunkRev_nixSha256 = sha256
848+ = CheckClean_FullCheck
661− }
849+ -- ^ Check that the repo is clean, including .gitignored files
662− }
850+ | CheckClean_NotIgnored
663− overwriteThunk thunkDir newThunkPtr
851+ -- ^ Check that the repo is clean, not including .gitignored files
664− updateThunkToLatest thunkDir Nothing
852+ | CheckClean_NoCheck
665− ExitFailure errNum -> failWith $ T.pack $ if errNum == 2
853+ -- ^ Don't check that the repo is clean
666− then "Error: branch not found"
854+
667− else ("Error Code: " <> show errNum <> "issue checking out the desired branch")
668− Right (ThunkData_Checkout _) -> failWith $ T.pack $ "thunk located at " <> (show thunkDir) <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk set again."
670−getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr
671−getThunkPtr = getThunkPtr' True
673−getThunkPtr' :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
855+getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
674−getThunkPtr' checkClean thunkDir = do
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)
675− when checkClean $ ensureCleanGitRepo thunkDir True $
868+ when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
676 "thunk pack: thunk checkout contains unsaved modifications"
869 "thunk pack: thunk checkout contains unsaved modifications"
678 -- Check whether there are any stashes
871 -- Check whether there are any stashes
872+ when checkClean $ do
679− stashOutput <- readGitProcess thunkDir ["stash", "list"]
873+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
680− when checkClean $ case T.null stashOutput of
874+ unless (T.null stashOutput) $
682 failWith $ T.unlines $
875 failWith $ T.unlines $
683 [ "thunk pack: thunk checkout has stashes"
876 [ "thunk pack: thunk checkout has stashes"
684 , "git stash list:"
877 , "git stash list:"
685 ] ++ T.lines stashOutput
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."
686− True -> return ()
890+ _ -> return (b, c)
688 -- Get information on all branches and their (optional) designated upstream
892 -- Get information on all branches and their (optional) designated upstream
689 -- correspondents
893 -- correspondents
690− (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
894+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
691 [ "for-each-ref"
895 [ "for-each-ref"
692 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
896 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
693 , "refs/heads/"
897 , "refs/heads/"
@@ -733,7 +937,7 @@ getThunkPtr' checkClean thunkDir = do
735 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
939 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
736− stats <- iforM headUpstream $ \branch (upstream, _remote) -> do
940+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
737 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
941 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
738 [ "rev-list", "--left-right"
942 [ "rev-list", "--left-right"
739 , T.unpack branch <> "..." <> T.unpack upstream
943 , T.unpack branch <> "..." <> T.unpack upstream
@@ -750,20 +954,16 @@ getThunkPtr' checkClean thunkDir = do
750 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
954 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
753− (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat
957+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
754 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
958 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
756 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
960 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
757 \pushed but this repo's remote tracking branches don't know it.)"
961 \pushed but this repo's remote tracking branches don't know it.)"
964+ when checkClean $ do
760− -- We assume it's safe to pack the thunk at this point
965+ -- We assume it's safe to pack the thunk at this point
761− putLog Informational $ "All changes safe in git remotes. OK to pack thunk."
966+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
763− -- Get current branch ``
764− mCurrentBranch <- listToMaybe
766− <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
768 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
968 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
@@ -776,14 +976,12 @@ getThunkPtr' checkClean thunkDir = do
776 remoteUri <- case parseGitUri remoteUri' of
976 remoteUri <- case parseGitUri remoteUri' of
777 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
977 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
778 Just uri -> pure uri
978 Just uri -> pure uri
779− uriThunkPtr remoteUri mCurrentBranch
979+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
781-- | Get the latest revision available from the given source
981-- | Get the latest revision available from the given source
782getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
982getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
783getLatestRev os = do
983getLatestRev os = do
784− let gitS = case os of
984+ let gitS = thunkSourceToGitSource os
785− ThunkSource_GitHub s -> forgetGithub False s
786− ThunkSource_Git s -> s
787 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
985 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
788 case os of
986 case os of
789 ThunkSource_GitHub s -> githubThunkRev s commit
987 ThunkSource_GitHub s -> githubThunkRev s commit
@@ -795,16 +993,18 @@ getLatestRev os = do
795-- performance. If that doesn't work (e.g. authentication issue), we fall back
993-- performance. If that doesn't work (e.g. authentication issue), we fall back
796-- on just doing things the normal way for git repos in general, and save it as
994-- on just doing things the normal way for git repos in general, and save it as
797-- a regular git thunk.
995-- a regular git thunk.
798−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> m ThunkPtr
996+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
799−uriThunkPtr uri mbranch = do
997+uriThunkPtr uri mPrivate mbranch mcommit = do
998+ commit <- case mcommit of
800− (_, commit) <- gitGetCommitBranch uri mbranch
999+ Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
1000+ (Just c) -> return c
801− (src, rev) <- case uriToThunkSource uri mbranch of
1001+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
802 ThunkSource_GitHub s -> do
1002 ThunkSource_GitHub s -> do
803 rev <- runExceptT $ githubThunkRev s commit
1003 rev <- runExceptT $ githubThunkRev s commit
804 case rev of
1004 case rev of
805 Right r -> pure (ThunkSource_GitHub s, r)
1005 Right r -> pure (ThunkSource_GitHub s, r)
806 Left e -> do
1006 Left e -> do
807− putLog Warning $ "\
1007+ putLog Warning "\
808\Failed to fetch archive from GitHub. This is probably a private repo. \
1008\Failed to fetch archive from GitHub. This is probably a private repo. \
809\Falling back on normal fetchgit. Original failure:"
1009\Falling back on normal fetchgit. Original failure:"
810 errorToWarning e
1010 errorToWarning e
@@ -821,34 +1021,66 @@ uriThunkPtr uri mbranch = do
821-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
1021-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
822-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
1022-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
823-- should be employed, and so we respect that.
1023-- should be employed, and so we respect that.
824−uriToThunkSource :: URI -> Maybe Text -> ThunkSource
1024+uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
825−uriToThunkSource u
1025+uriToThunkSource (GitUri u) mPrivate
826− | Right uriAuth <- uriAuthority u
1026+ | Right uriAuth <- URI.uriAuthority u
827− , Just scheme <- unRText <$> uriScheme u
1027+ , Just scheme <- URI.unRText <$> URI.uriScheme u
828 , case scheme of
1028 , case scheme of
829− "ssh" -> uriAuth == Authority
1029+ "ssh" -> uriAuth == URI.Authority
830− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing
1030+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
831− , authHost = fromRight' $ mkHost "github.com"
1031+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
832− , authPort = Nothing
1032+ , URI.authPort = Nothing
834 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
1034 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
835− && unRText (authHost uriAuth) == "github.com"
1035+ && URI.unRText (URI.authHost uriAuth) == "github.com"
836− , Just (_, owner :| [repoish]) <- uriPath u
1036+ , Just (_, owner :| [repoish]) <- URI.uriPath u
1038+ isPrivate <- getIsPrivate
837− = \mbranch -> ThunkSource_GitHub $ GitHubSource
1039+ pure $ ThunkSource_GitHub $ GitHubSource
838− { _gitHubSource_owner = N $ unRText owner
1040+ { _gitHubSource_owner = N $ URI.unRText owner
839− , _gitHubSource_repo = N $ let
1041+ , _gitHubSource_repo = N $ let
840− repoish' = unRText repoish
1042+ repoish' = URI.unRText repoish
841− in case T.stripSuffix ".git" repoish' of
1043+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
844− , _gitHubSource_branch = N <$> mbranch
1044+ , _gitHubSource_branch = N <$> mbranch
1045+ , _gitHubSource_private = isPrivate
1048+ | otherwise = \mbranch -> do
1049+ isPrivate <- getIsPrivate
847− | otherwise = \mbranch -> ThunkSource_Git $ GitSource
1050+ pure $ ThunkSource_Git $ GitSource
848− { _gitSource_url = u
1051+ { _gitSource_url = GitUri u
849− , _gitSource_branch = N <$> mbranch
1052+ , _gitSource_branch = N <$> mbranch
850− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
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
853-- Funny signature indicates no effects depend on the optional branch name.
1085-- Funny signature indicates no effects depend on the optional branch name.
854githubThunkRev
1086githubThunkRev
@@ -860,19 +1092,19 @@ githubThunkRev
860githubThunkRev s commit = do
1092githubThunkRev s commit = do
861 owner <- forcePP $ _gitHubSource_owner s
1093 owner <- forcePP $ _gitHubSource_owner s
862 repo <- forcePP $ _gitHubSource_repo s
1094 repo <- forcePP $ _gitHubSource_repo s
863− revTarball <- mkPathPiece $ commit <> ".tar.gz"
1095+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
864− let archiveUri = URI
1096+ let archiveUri = GitUri $ URI.URI
865− { uriScheme = Just $ fromRight' $ mkScheme "https"
1097+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
866− , uriAuthority = Right $ Authority
1098+ , URI.uriAuthority = Right $ URI.Authority
867− { authUserInfo = Nothing
1099+ { URI.authUserInfo = Nothing
868− , authHost = fromRight' $ mkHost "github.com"
1100+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
869− , authPort = Nothing
1101+ , URI.authPort = Nothing
871− , uriPath = Just ( False
1103+ , URI.uriPath = Just ( False
872− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]
1104+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
874− , uriQuery = []
1106+ , URI.uriQuery = []
875− , uriFragment = Nothing
1107+ , URI.uriFragment = Nothing
877 hash <- getNixSha256ForUriUnpacked archiveUri
1109 hash <- getNixSha256ForUriUnpacked archiveUri
878 putLog Debug $ "Nix sha256 is " <> hash
1110 putLog Debug $ "Nix sha256 is " <> hash
@@ -881,8 +1113,8 @@ githubThunkRev s commit = do
881 , _thunkRev_nixSha256 = hash
1113 , _thunkRev_nixSha256 = hash
884− forcePP :: Name entity -> m (RText 'PathPiece)
1116+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
885− forcePP = mkPathPiece . untagName
1117+ forcePP = URI.mkPathPiece . untagName
887gitThunkRev
1119gitThunkRev
888 :: MonadObelisk m
1120 :: MonadObelisk m
@@ -891,11 +1123,11 @@ gitThunkRev
891 -> m ThunkRev
1123 -> m ThunkRev
892gitThunkRev s commit = do
1124gitThunkRev s commit = do
893 let u = _gitSource_url s
1125 let u = _gitSource_url s
894− protocols = ["https", "ssh", "git"]
1126+ protocols = ["file", "https", "ssh", "git"]
895− Just scheme <- pure $ unRText <$> uriScheme u
1127+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
896 unless (T.toLower scheme `elem` protocols) $
1128 unless (T.toLower scheme `elem` protocols) $
897 failWith $ "obelisk currently only supports "
1129 failWith $ "obelisk currently only supports "
898− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
1130+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
899 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
1131 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
900 putLog Informational $ "Nix sha256 is " <> hash
1132 putLog Informational $ "Nix sha256 is " <> hash
901 pure $ ThunkRev
1133 pure $ ThunkRev
@@ -908,12 +1140,14 @@ gitThunkRev s commit = do
909-- If the branch name is passed in, it is returned exactly as-is. If it is not
1141-- If the branch name is passed in, it is returned exactly as-is. If it is not
910-- passed it, the default branch of the repo is used instead.
1142-- passed it, the default branch of the repo is used instead.
911gitGetCommitBranch
1144gitGetCommitBranch
912− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
1145+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
913gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
1146gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
914− bothMaps <- gitLsRemote
1147+ (_, bothMaps) <- gitLsRemote
915− (T.unpack $ render uri)
1148+ (T.unpack $ gitUriToText uri)
916 (GitRef_Branch <$> mbranch)
1149 (GitRef_Branch <$> mbranch)
917 branch <- case mbranch of
1151 branch <- case mbranch of
918 Nothing -> withExitFailMessage "Failed to find default branch" $ do
1152 Nothing -> withExitFailMessage "Failed to find default branch" $ do
919 b <- rethrowE $ gitLookupDefaultBranch bothMaps
1153 b <- rethrowE $ gitLookupDefaultBranch bothMaps
@@ -927,18 +1161,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "
927 pure (branch, commit)
1161 pure (branch, commit)
929 rethrowE = either failWith pure
1163 rethrowE = either failWith pure
930− uriMsg = render uri
1164+ uriMsg = gitUriToText uri
1166+parseGitUri :: Text -> Maybe GitUri
1167+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
932−parseGitUri :: Text -> Maybe URI
1169+parseFileURI :: Text -> Maybe URI.URI
933−parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x
1170+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
935−parseAbsoluteURI :: Text -> Maybe URI
1172+parseAbsoluteURI :: Text -> Maybe URI.URI
936parseAbsoluteURI uri = do
1173parseAbsoluteURI uri = do
937− parsedUri <- mkURI uri
1174+ parsedUri <- URI.mkURI uri
938− guard $ isPathAbsolute parsedUri
1175+ guard $ URI.isPathAbsolute parsedUri
939− pure $ parsedUri
1176+ pure parsedUri
941−parseSshShorthand :: Text -> Maybe URI
1178+parseSshShorthand :: Text -> Maybe URI.URI
942parseSshShorthand uri = do
1179parseSshShorthand uri = do
943 -- This is what git does to check that the remote
1180 -- This is what git does to check that the remote
944 -- is not a local file path when parsing shorthand.
1181 -- is not a local file path when parsing shorthand.
@@ -951,4 +1188,4 @@ parseSshShorthand uri = do
951 -- This check is used to disambiguate a filepath containing a colon from shorthand
1188 -- This check is used to disambiguate a filepath containing a colon from shorthand
952 guard $ isNothing (T.findIndex (=='/') authAndHostname)
1189 guard $ isNothing (T.findIndex (=='/') authAndHostname)
953 && not (T.null colonAndPath)
1190 && not (T.null colonAndPath)
954− mkURI properUri
1191+ URI.mkURI properUri