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