@@ -5,70 +5,84 @@
55{-# LANGUAGE MultiWayIf #-}
66{-# LANGUAGE OverloadedStrings #-}
77{-# LANGUAGE PatternGuards #-}
8−{-# LANGUAGE QuasiQuotes #-}
98{-# LANGUAGE ScopedTypeVariables #-}
109{-# LANGUAGE TypeApplications #-}
11−module Obelisk.Command.Thunk where
10+module Obelisk.Command.Thunk
11+ ( ThunkPtr (..)
12+ , ThunkRev (..)
13+ , ThunkSource (..)
14+ , ThunkData (..)
15+ , ReadThunkError (..)
16+ , GitHubSource (..)
17+ , getThunkGitBranch
18+ , getLatestRev
19+ , updateThunkToLatest
20+ , createThunk
21+ , createThunkWithLatest
22+ , nixBuildAttrWithCache
23+ , nixBuildThunkAttrWithCache
24+ , unpackThunk
25+ , packThunk
26+ , readThunk
27+ , updateThunk
28+ , getThunkPtr
29+ , getThunkPtr'
30+ ) where
1231
1332import Control.Applicative
14−import Control.Exception (displayException, try)
15−import Control.Lens (ifor, ifor_, (.~))
33+import Control.Exception (displayException, throwIO, try)
1634import Control.Monad
17−import Control.Monad.Extra (findM)
18−import Control.Monad.Catch (MonadCatch, handle)
35+import Control.Monad.Catch (handle)
1936import Control.Monad.Except
2037import Data.Aeson ((.=))
2138import qualified Data.Aeson as Aeson
2239import Data.Aeson.Encode.Pretty
2340import qualified Data.Aeson.Types as Aeson
24−import Data.Bifunctor (first)
2541import qualified Data.ByteString.Lazy as LBS
26−import Data.Containers.ListUtils (nubOrd)
42+import qualified Data.ByteString.Lazy.Char8 as LBSC
2743import Data.Default
28−import Data.Either.Combinators (fromRight', rightToMaybe)
29−import Data.Foldable (toList)
30−import Data.Function ((&))
31−import Data.Functor ((<&>))
44+import Data.Either.Combinators (rightToMaybe)
45+import Data.Foldable
3246import Data.Git.Ref (Ref)
3347import qualified Data.Git.Ref as Ref
3448import qualified Data.List as L
35−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
49+import Data.List.NonEmpty (NonEmpty (..))
3650import qualified Data.List.NonEmpty as NonEmpty
37−import Data.Map (Map)
3851import qualified Data.Map as Map
3952import Data.Maybe
4053import Data.Set (Set)
4154import qualified Data.Set as Set
42−import Data.String.Here.Interpolated (i)
43−import Data.String.Here.Uninterpolated (here)
4455import Data.Text (Text)
4556import qualified Data.Text as T
4657import Data.Text.Encoding
4758import qualified Data.Text.IO as T
4859import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
49−import Data.Traversable (for)
50−import Data.Yaml (parseMaybe)
60+import Data.Yaml (parseMaybe, (.:))
61+import qualified Data.Yaml as Yaml
5162import GitHub
5263import GitHub.Data.Name
64+import GitHub.Endpoints.Repos.Contents (archiveForR)
65+import Network.URI
5366import Obelisk.Command.Nix
5467import System.Directory
55−import System.Exit
5668import System.FilePath
5769import System.IO.Error
5870import System.IO.Temp
59−import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
60−import qualified Text.URI as URI
71+import System.Posix (getSymbolicLinkStatus, modificationTime)
72+import System.Process (proc)
6173
6274import Obelisk.App (MonadObelisk)
6375import Obelisk.CliApp
76+import Obelisk.Command.Nix (withNixRemoteCheck)
6477import Obelisk.Command.Utils
6578
6679--TODO: Support symlinked thunk data
6780data ThunkData
68− = ThunkData_Packed ThunkSpec ThunkPtr
81+ = ThunkData_Packed ThunkPtr
6982 -- ^ Packed thunk
70− | ThunkData_Checkout
83+ | ThunkData_Checkout (Maybe ThunkPtr)
7184 -- ^ Checked out thunk that was unpacked from this pointer
85+ deriving (Show, Eq, Ord)
7286
7387-- | A reference to the exact data that a thunk should translate into
7488data ThunkPtr = ThunkPtr
@@ -81,7 +95,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
8195
8296-- | A specific revision of data; it may be available from multiple sources
8397data ThunkRev = ThunkRev
84− { _thunkRev_commit :: Ref Ref.SHA1
98+ { _thunkRev_commit :: Ref
8599 , _thunkRev_nixSha256 :: NixSha256
86100 }
87101 deriving (Show, Eq, Ord)
@@ -94,11 +108,6 @@ data ThunkSource
94108 | ThunkSource_Git GitSource
95109 deriving (Show, Eq, Ord)
96110
97−thunkSourceToGitSource :: ThunkSource -> GitSource
98−thunkSourceToGitSource = \case
99− ThunkSource_GitHub s -> forgetGithub False s
100− ThunkSource_Git s -> s
101−
102111data GitHubSource = GitHubSource
103112 { _gitHubSource_owner :: Name Owner
104113 , _gitHubSource_repo :: Name Repo
@@ -107,208 +116,182 @@ data GitHubSource = GitHubSource
107116 }
108117 deriving (Show, Eq, Ord)
109118
110−newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
111−
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
118−
119119data GitSource = GitSource
120− { _gitSource_url :: GitUri
121− , _gitSource_branch :: Maybe (Name Branch)
120+ { _gitSource_url :: URI
121+ , _gitSource_branch :: Name Branch
122122 , _gitSource_fetchSubmodules :: Bool
123− , _gitSource_private :: Bool
124123 }
125124 deriving (Show, Eq, Ord)
126125
127−newtype ThunkConfig = ThunkConfig
128− { _thunkConfig_private :: Maybe Bool
129− } deriving Show
130−
131−data ThunkUpdateConfig = ThunkUpdateConfig
132− { _thunkUpdateConfig_branch :: Maybe String
133− , _thunkUpdateConfig_config :: ThunkConfig
134− } deriving Show
135−
136−data ThunkPackConfig = ThunkPackConfig
137− { _thunkPackConfig_force :: Bool
138− , _thunkPackConfig_config :: ThunkConfig
139− } deriving Show
140−
141−-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
142−forgetGithub :: Bool -> GitHubSource -> GitSource
143−forgetGithub useSsh s = GitSource
144− { _gitSource_url = GitUri $ URI.URI
145− { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"
146− , URI.uriAuthority = Right $ URI.Authority
147− { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
148− <$ guard useSsh
149− , URI.authHost = fromRight' $ URI.mkHost "github.com"
150− , URI.authPort = Nothing
151− }
152− , URI.uriPath = Just ( False
153− , fromRight' . URI.mkPathPiece <$>
154− untagName (_gitHubSource_owner s)
155− :| [ untagName (_gitHubSource_repo s) <> ".git" ]
156− )
157− , URI.uriQuery = []
158− , URI.uriFragment = Nothing
159− }
160− , _gitSource_branch = _gitHubSource_branch s
161− , _gitSource_fetchSubmodules = False
162− , _gitSource_private = _gitHubSource_private s
163− }
164−
165126getThunkGitBranch :: ThunkPtr -> Maybe Text
166127getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
167128 ThunkSource_GitHub s -> _gitHubSource_branch s
168− ThunkSource_Git s -> _gitSource_branch s
129+ ThunkSource_Git s -> Just $ _gitSource_branch s
169130
170−commitNameToRef :: Name Commit -> Ref Ref.SHA1
131+commitNameToRef :: Name Commit -> Ref
171132commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
172133
173134-- TODO: Use spinner here.
174−getNixSha256ForUriUnpacked
175− :: MonadObelisk m
176− => GitUri
177− -> m NixSha256
135+getNixSha256ForUriUnpacked :: MonadObelisk m => URI -> m NixSha256
178136getNixSha256ForUriUnpacked uri =
179− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
180− [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
181− proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
182− pure hash
137+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> T.pack (show uri)) $ do
138+ fmap T.pack $ withNixRemoteCheck $ readProcessAndLogStderr Debug $
139+ proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
183140
184−nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
141+nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
185142nixPrefetchGit uri rev fetchSubmodules =
186− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
187− out <- readProcessAndLogStderr Debug $
188− proc nixPrefetchGitPath $ filter (/="")
189− [ "--url", T.unpack $ gitUriToText uri
143+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> T.pack (show uri) <> " at " <> rev) $ do
144+ out <- withNixRemoteCheck $ readProcessAndLogStderr Debug $
145+ proc "nix-prefetch-git" $ filter (/="")
146+ [ "--url", show uri
190147 , "--rev", T.unpack rev
191148 , if fetchSubmodules then "--fetch-submodules" else ""
192149 , "--quiet"
193150 ]
194151
195− case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of
196− Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
152+ case parseMaybe (Aeson..: "sha256") =<< Aeson.decode (LBSC.pack out) of
153+ Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> T.pack out
197154 Just x -> pure x
198155
156+getLatestGitRev :: MonadObelisk m => GitSource -> m ThunkRev
157+getLatestGitRev s = withSystemTempDirectory "git-clone" $ \tmpDir -> do
158+ withExitFailMessage ("Unable to determine latest git revision for branch " <> branch) $ do
159+ let git = fmap T.pack . readProcessAndLogStderr Debug . gitProc tmpDir
160+ out <- liftA2 (<>)
161+ (git ["clone", "--no-checkout", show $ _gitSource_url s]) -- Might be able to use --bare here instead to go faster.
162+ (git ["log", T.unpack branch, "--max-count=1", "--format=%H"])
163+
164+ case T.strip <$> safeLast (T.lines out) of
165+ Nothing -> failWith $ "Unable to parse git log: " <> out
166+ Just rev -> do
167+ putLog Debug $ "Latest commit in " <> branch <> " is " <> rev
168+ sha <- nixPrefetchGit (_gitSource_url s) rev (_gitSource_fetchSubmodules s)
169+ putLog Debug $ "Nix sha256 is " <> sha
170+ pure $ ThunkRev
171+ { _thunkRev_commit = Ref.fromHexString $ T.unpack rev
172+ , _thunkRev_nixSha256 = sha
173+ }
174+ where
175+ remote :: Text = "origin"
176+ branch :: Text = remote <> "/" <> untagName (_gitSource_branch s)
177+
178+ safeLast [] = Nothing
179+ safeLast xs = Just $ last xs
180+
181+-- | Get the latest revision available from the given source
182+getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
183+getLatestRev = \case
184+ ThunkSource_GitHub s -> do
185+ auth <- liftIO $ getHubAuth "github.com"
186+ commitsResult <- liftIO $ executeRequestMaybe auth $ commitsWithOptionsForR
187+ (_gitHubSource_owner s)
188+ (_gitHubSource_repo s)
189+ (FetchAtLeast 1)
190+ $ case _gitHubSource_branch s of
191+ Nothing -> []
192+ Just b -> [CommitQuerySha $ untagName b]
193+ commitInfos <- either (liftIO . throwIO) return commitsResult
194+ commitInfo : _ <- return $ toList commitInfos
195+ let commit = commitSha commitInfo
196+ putLog Debug $ "Latest commit is " <> untagName commit
197+ Right archiveUri <- liftIO $ executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit
198+ nixSha256 <- getNixSha256ForUriUnpacked archiveUri
199+ putLog Debug $ "Nix sha256 is " <> nixSha256
200+ return $ ThunkRev
201+ { _thunkRev_commit = commitNameToRef commit
202+ , _thunkRev_nixSha256 = nixSha256
203+ }
204+ ThunkSource_Git s -> getLatestGitRev s
205+
199206--TODO: Pretty print these
200207data ReadThunkError
201− = ReadThunkError_UnrecognizedThunk
202− | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
203− | ReadThunkError_MissingPaths (NonEmpty FilePath)
204− | ReadThunkError_UnparseablePtr FilePath String
205− | ReadThunkError_FileError IOError
206− | ReadThunkError_FileDoesNotMatch FilePath Text
207− | ReadThunkError_UnrecognizedState String
208− | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
209− deriving (Show)
210−
211−unpackedDirName :: FilePath
212−unpackedDirName = "."
213−
214−attrCacheFileName :: FilePath
215−attrCacheFileName = ".attr-cache"
216−
217−-- | Specification for how a file in a thunk version works.
218−data ThunkFileSpec
219− = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
220− | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
221− | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
222− | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
223−
224−-- | Specification for how a set of files in a thunk version work.
225−data ThunkSpec = ThunkSpec
226− { _thunkSpec_name :: !Text
227− , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
208+ = ReadThunkError_UnrecognizedFiles
209+ | ReadThunkError_AmbiguousFiles
210+ | ReadThunkError_UnrecognizedLoader Text
211+ | ReadThunkError_UnparseablePtr LBS.ByteString
212+ deriving (Show)
213+
214+-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
215+-- If the thunk is packed and additional data is present, fail.
216+readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
217+readThunk thunkDir = do
218+ files <- liftIO $ listDirectory thunkDir
219+ case ".git" `elem` files of
220+ True -> fmap ThunkData_Checkout <$> do
221+ let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
222+ liftIO $ doesDirectoryExist origThunkPath >>= \case
223+ True -> fmap Just <$> readPackedThunk origThunkPath
224+ False -> return $ return Nothing
225+ False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
226+
227+data ThunkType = ThunkType
228+ { _thunkType_loader :: FilePath
229+ , _thunkType_json :: FilePath
230+ , _thunkType_optional :: Set FilePath
231+ , _thunkType_loaderVersions :: NonEmpty Text
232+ , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr
228233 }
229234
230−thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
231−thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
232−
233−-- | Attempts to match a 'ThunkSpec' to a given directory.
234−matchThunkSpecToDir
235− :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
236− => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
237− -> FilePath -- ^ Path to directory
238− -> Set FilePath -- ^ Set of file paths relative to the given directory
239− -> m ThunkData
240−matchThunkSpecToDir thunkSpec dir dirFiles = do
241− case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
242− Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
243− Nothing -> pure ()
244− case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
245− Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
246− Nothing -> pure ()
247− datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
248− ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
249− ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
250− False -> Nothing
251− True -> Just ThunkData_Checkout
252− ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
253− actualContents <- liftIO (T.readFile $ dir </> expectedPath)
254− case T.strip expectedContents == T.strip actualContents of
255− True -> pure Nothing
256− False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
257− ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
258− let path = dir </> expectedPath
259− liftIO (doesFileExist path) >>= \case
260− False -> pure Nothing
261− True -> do
262− actualContents <- liftIO $ LBS.readFile path
263− case parser actualContents of
264− Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
265− Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
266−
267− case nonEmpty datas of
268− Nothing -> throwError ReadThunkError_UnrecognizedThunk
269− Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
270− where
271− rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272− takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
273−
274− expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
275−
276− requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
277− isRequiredFileSpec = \case
278− ThunkFileSpec_FileMatches _ -> True
279− _ -> False
280−
281− dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
282− True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
283− False -> pure ()
284−
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
291−
292− bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
293−
294− fold1WithM (x :| xs) f = foldM f x xs
295−
296−readThunkWith
297− :: (MonadObelisk m)
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}|]
235+gitHubThunkType :: ThunkType
236+gitHubThunkType = ThunkType
237+ { _thunkType_loader = "default.nix"
238+ , _thunkType_json = "github.json"
239+ , _thunkType_optional = Set.fromList [".attr-cache"]
240+ , _thunkType_loaderVersions = gitHubStandaloneLoaders
241+ , _thunkType_parser = parseThunkPtr $ \v ->
242+ ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
243+ }
244+
245+gitThunkType :: ThunkType
246+gitThunkType = ThunkType
247+ { _thunkType_loader = "default.nix"
248+ , _thunkType_json = "git.json"
249+ , _thunkType_optional = Set.fromList [".attr-cache"]
250+ , _thunkType_loaderVersions = plainGitStandaloneLoaders
251+ , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
252+ }
253+
254+thunkTypes :: [ThunkType]
255+thunkTypes = [gitThunkType, gitHubThunkType]
256+
257+findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)
258+findThunkType types thunkDir = do
259+ matches <- fmap catMaybes $ forM types $ \thunkType -> do
260+ let
261+ expectedContents = Set.fromList $ (thunkDir </>) <$>
262+ [ _thunkType_loader thunkType
263+ , _thunkType_json thunkType
264+ ]
265+ optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)
266+
267+ -- Ensure that there aren't any other files in the thunk
268+ -- NB: System.Directory.listDirectory returns the contents without the directory path
269+ files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
270+ let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
271+ missingContents = expectedContents `Set.difference` files
272+ pure $ if Set.null unexpectedContents && Set.null missingContents
273+ then Just thunkType
274+ else Nothing
275+
276+ pure $ case matches of
277+ [singleMatch] -> Right singleMatch
278+ [] -> Left ReadThunkError_UnrecognizedFiles
279+ _ -> Left ReadThunkError_AmbiguousFiles
307280
308281-- | Read a thunk and validate that it is exactly a packed thunk.
309282-- If additional data is present, fail.
310−readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
311−readThunk = readThunkWith thunkSpecTypes
283+readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
284+readPackedThunk thunkDir = runExceptT $ do
285+ thunkType <- ExceptT $ findThunkType thunkTypes thunkDir
286+ -- Ensure that we recognize the thunk loader
287+ loader <- liftIO $ T.readFile $ thunkDir </> _thunkType_loader thunkType
288+ unless (loader `elem` _thunkType_loaderVersions thunkType) $ do
289+ throwError $ ReadThunkError_UnrecognizedLoader loader
290+
291+ txt <- liftIO $ LBS.readFile $ thunkDir </> _thunkType_json thunkType
292+ case parseMaybe (_thunkType_parser thunkType) =<< Aeson.decode txt of
293+ Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
294+ Just ptr -> return ptr
312295
313296parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
314297parseThunkPtr parseSrc v = do
@@ -328,42 +311,38 @@ parseGitHubSource v = do
328311 owner <- v Aeson..: "owner"
329312 repo <- v Aeson..: "repo"
330313 branch <- v Aeson..:! "branch"
331− private <- v Aeson..:? "private"
314+ mPrivate <- v Aeson..:! "private"
332315 pure $ GitHubSource
333316 { _gitHubSource_owner = owner
334317 , _gitHubSource_repo = repo
335318 , _gitHubSource_branch = branch
336− , _gitHubSource_private = fromMaybe False private
319+ , _gitHubSource_private = fromMaybe False mPrivate
337320 }
338321
339322parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
340323parseGitSource v = do
341324 Just url <- parseGitUri <$> v Aeson..: "url"
342− branch <- v Aeson..:! "branch"
325+ branch <- v Aeson..: "branch"
343326 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
344− private <- v Aeson..:? "private"
345327 pure $ GitSource
346328 { _gitSource_url = url
347329 , _gitSource_branch = branch
348330 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
349− , _gitSource_private = fromMaybe False private
350331 }
351332
352333overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
353334overwriteThunk target thunk = do
354335 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
355− readThunk target >>= \case
356− Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
357− Right _ -> pure ()
336+ Right _ <- readThunk target
358337
359338 --TODO: Is there a safer way to do this overwriting?
360− liftIO $ removePathForcibly target
361− createThunk target $ Right thunk
339+ liftIO $ removeDirectoryRecursive target
340+ liftIO $ createThunk target thunk
362341
363−thunkPtrToSpec :: ThunkPtr -> ThunkSpec
364−thunkPtrToSpec thunk = case _thunkPtr_source thunk of
365− ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
366− ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
342+thunkPtrLoader :: ThunkPtr -> Text
343+thunkPtrLoader thunk = case _thunkPtr_source thunk of
344+ ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
345+ ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
367346
368347-- It's important that formatting be very consistent here, because
369348-- otherwise when people update thunks, their patches will be messy
@@ -372,18 +351,22 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
372351 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
373352 [ Just $ "owner" .= _gitHubSource_owner s
374353 , Just $ "repo" .= _gitHubSource_repo s
375− , ("branch" .=) <$> _gitHubSource_branch s
354+ , case _gitHubSource_branch s of
355+ Just b -> Just $ "branch" .= b
356+ Nothing -> Nothing
357+ , if _gitHubSource_private s
358+ then Just $ "private" .= True
359+ else Nothing
376360 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
377361 , Just $ "sha256" .= _thunkRev_nixSha256 rev
378− , Just $ "private" .= _gitHubSource_private s
379362 ]
380363 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
381− [ Just $ "url" .= gitUriToText (_gitSource_url s)
364+ --TODO: Is this safe? read/show is jank for `URI`
365+ [ Just $ "url" .= show (_gitSource_url s)
382366 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
383− , ("branch" .=) <$> _gitSource_branch s
367+ , Just $ "branch" .= _gitSource_branch s
384368 , Just $ "sha256" .= _thunkRev_nixSha256 rev
385369 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
386− , Just $ "private" .= _gitSource_private s
387370 ]
388371 where
389372 githubCfg = defConfig
@@ -404,84 +387,59 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
404387 [ "url"
405388 , "rev"
406389 , "sha256"
407− , "private"
408390 , "fetchSubmodules"
409391 ] <> compare
410392 , confTrailingNewline = True
411393 }
412394
413−createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
414−createThunk target ptrInfo =
415− ifor_ (_thunkSpec_files spec) $ \path -> \case
416− ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
417− ThunkFileSpec_Ptr _ -> case ptrInfo of
418− Left _ -> pure () -- We can't write the ptr without it
419− Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
420− _ -> pure ()
421− where
422− spec = either id thunkPtrToSpec ptrInfo
423− withReadyPath path f = do
424− let fullPath = target </> path
425− putLog Debug $ "Writing thunk file " <> T.pack fullPath
426− liftIO $ createDirectoryIfMissing True $ takeDirectory fullPath
427− f fullPath
395+createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
396+createThunk target thunk = liftIO $ do
397+ createDirectoryIfMissing True (target </> ".attr-cache")
398+ T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
399+ let
400+ jsonFileName = case _thunkPtr_source thunk of
401+ ThunkSource_GitHub _ -> "github"
402+ ThunkSource_Git _ -> "git"
403+ LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)
428404
429405createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
430406createThunkWithLatest target s = do
431407 rev <- getLatestRev s
432− createThunk target $ Right $ ThunkPtr
408+ createThunk target $ ThunkPtr
433409 { _thunkPtr_source = s
434410 , _thunkPtr_rev = rev
435411 }
436412
437−updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
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
441− case mBranch of
442− Nothing -> do
443− (overwrite, ptr) <- readThunk target >>= \case
444− Left err -> failWith [i|Thunk update: ${err}|]
445− Right c -> case c of
446− ThunkData_Packed _ t -> return (target, t)
447− ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
448− let src = _thunkPtr_source ptr
449− rev <- getLatestRev src
450− overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
451− { _thunkPtr_source = src
452− , _thunkPtr_rev = rev
453− }
454− Just branch -> readThunk target >>= \case
455− Left err -> failWith [i|Thunk update: ${err}|]
456− Right c -> case c of
457− ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
458− ThunkData_Checkout -> failWith [i|Thunk located at ${target} is unpacked. Use 'ob thunk pack' on the desired directory and then try 'ob thunk update' again.|]
459− where
460− spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
461−
462−setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
463−setThunk thunkConfig target gs branch = do
464− newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing
465− overwriteThunk target newThunkPtr
466− updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
413+updateThunkToLatest :: MonadObelisk m => FilePath -> m ()
414+updateThunkToLatest target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
415+ (overwrite, ptr) <- readThunk target >>= \case
416+ Left err -> failWith $ T.pack $ "thunk update: " <> show err
417+ Right c -> case c of
418+ ThunkData_Packed t -> return (target, t)
419+ ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
420+ let src = _thunkPtr_source ptr
421+ rev <- getLatestRev src
422+ overwriteThunk overwrite $ ThunkPtr
423+ { _thunkPtr_source = src
424+ , _thunkPtr_rev = rev
425+ }
467426
468427-- | All recognized github standalone loaders, ordered from newest to oldest.
469428-- This tool will only ever produce the newest one when it writes a thunk.
470−gitHubThunkSpecs :: NonEmpty ThunkSpec
471−gitHubThunkSpecs =
472− gitHubThunkSpecV5 :|
473− [ gitHubThunkSpecV4
474− , gitHubThunkSpecV3
475− , gitHubThunkSpecV2
476− , gitHubThunkSpecV1
429+gitHubStandaloneLoaders :: NonEmpty Text
430+gitHubStandaloneLoaders =
431+ gitHubStandaloneLoaderV2 :|
432+ [ gitHubStandaloneLoaderV3
433+ , gitHubStandaloneLoaderV1
477434 ]
478435
479−gitHubThunkSpecV1 :: ThunkSpec
480−gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
481− "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
436+gitHubStandaloneLoaderV1 :: Text
437+gitHubStandaloneLoaderV1 = T.unlines
438+ [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
439+ ]
482440
483−gitHubThunkSpecV2 :: ThunkSpec
484−gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
441+gitHubStandaloneLoaderV2 :: Text
442+gitHubStandaloneLoaderV2 = T.unlines
485443 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
486444 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
487445 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -491,8 +449,8 @@ gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
491449 , "))"
492450 ]
493451
494−gitHubThunkSpecV3 :: ThunkSpec
495−gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
452+gitHubStandaloneLoaderV3 :: Text
453+gitHubStandaloneLoaderV3 = T.unlines
496454 [ "# DO NOT HAND-EDIT THIS FILE"
497455 , "let"
498456 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
@@ -511,62 +469,22 @@ gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
511469 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
512470 ]
513471
514−gitHubThunkSpecV4 :: ThunkSpec
515−gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
516− [ "# DO NOT HAND-EDIT THIS FILE"
517− , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
518− , " if !fetchSubmodules && !private then builtins.fetchTarball {"
519− , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
520− , " } else (import <nixpkgs> {}).fetchFromGitHub {"
521− , " inherit owner repo rev sha256 fetchSubmodules private;"
522− , " };"
523− , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
472+plainGitStandaloneLoaders :: NonEmpty Text
473+plainGitStandaloneLoaders =
474+ plainGitStandaloneLoaderV1 :|
475+ [ plainGitStandaloneLoaderV2
524476 ]
525477
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)
532− ]
533−
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;
542− };
543− json = builtins.fromJSON (builtins.readFile ./github.json);
544−in fetch json
545−|]
546−
547−parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
548−parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->
549− ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
550−
551−gitThunkSpecs :: NonEmpty ThunkSpec
552−gitThunkSpecs =
553− gitThunkSpecV5 :|
554− [ gitThunkSpecV4
555− , gitThunkSpecV3
556− , gitThunkSpecV2
557− , gitThunkSpecV1
558− ]
559−
560−gitThunkSpecV1 :: ThunkSpec
561−gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
478+plainGitStandaloneLoaderV1 :: Text
479+plainGitStandaloneLoaderV1 = T.unlines
562480 [ "# DO NOT HAND-EDIT THIS FILE"
563481 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
564482 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
565483 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
566484 ]
567485
568−gitThunkSpecV2 :: ThunkSpec
569−gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
486+plainGitStandaloneLoaderV2 :: Text
487+plainGitStandaloneLoaderV2 = T.unlines
570488 [ "# DO NOT HAND-EDIT THIS FILE"
571489 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
572490 , " if builtins.hasAttr \"fetchGit\" builtins"
@@ -575,87 +493,24 @@ gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
575493 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
576494 ]
577495
578−-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
579−-- and will fail to find commits without this because it does shallow clones.
580−gitThunkSpecV3 :: ThunkSpec
581−gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
582− [ "# DO NOT HAND-EDIT THIS FILE"
583− , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
584− , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
585− , " if firstChar == \"/\" then /. + url"
586− , " else if firstChar == \".\" then ./. + url"
587− , " else url;"
588− , " in if !fetchSubmodules && private then builtins.fetchGit {"
589− , " url = realUrl; inherit rev;"
590− , " } else (import <nixpkgs> {}).fetchgit {"
591− , " url = realUrl; inherit rev sha256;"
592− , " };"
593− , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
594− ]
595−
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"
603− , " else url;"
604− , " in if !fetchSubmodules && private then builtins.fetchGit {"
605− , " url = realUrl; inherit rev;"
606− , " ${if branch == null then null else \"ref\"} = branch;"
607− , " } else (import <nixpkgs> {}).fetchgit {"
608− , " url = realUrl; inherit rev sha256;"
609− , " };"
610− , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
611− ]
612−
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)
619− ]
620−
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
628− else url;
629− in if !fetchSubmodules && private then builtins.fetchGit {
630− url = realUrl; inherit rev;
631− ${if branch == null then null else "ref"} = branch;
632− } else (import <nixpkgs> {}).fetchgit {
633− url = realUrl; inherit rev sha256;
634− };
635− json = builtins.fromJSON (builtins.readFile ./git.json);
636−in fetch json
637−|]
638−
639−parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
640−parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
641−
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)
649− ]
650− where
651− defaultNixViaSrc = [here|
652−# DO NOT HAND-EDIT THIS FILE
653−import (import ./thunk.nix)
654−|]
655−
656−
657−parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
658−parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
496+thunkFileNames :: [FilePath]
497+thunkFileNames = ["default.nix", "github.json", "git.json"]
498+
499+-- | Look for authentication info from the 'hub' command
500+getHubAuth
501+ :: Text -- ^ Domain name
502+ -> IO (Maybe Auth)
503+getHubAuth domain = do
504+ hubConfig <- getXdgDirectory XdgConfig "hub"
505+ Yaml.decodeFileEither hubConfig >>= \case
506+ Left _ -> return Nothing
507+ Right v -> return $ flip parseMaybe v $ \v' -> do
508+ Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means
509+ [Yaml.Object domainConfig] <- return $ toList domainConfigs
510+ token <- domainConfig .: "oauth_token"
511+ return $ OAuth $ encodeUtf8 token
512+
513+--TODO: when checking something out, make a shallow clone
659514
660515-- | Checks a cache directory to see if there is a fresh symlink
661516-- to the result of building an attribute of a thunk.
@@ -663,49 +518,44 @@ parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
663518-- and the result is symlinked into the cache.
664519nixBuildThunkAttrWithCache
665520 :: MonadObelisk m
666− => ThunkSpec
667− -> FilePath
521+ => FilePath
668522 -- ^ Path to directory containing Thunk
669523 -> String
670524 -- ^ Attribute to build
671− -> m (Maybe FilePath)
525+ -> m FilePath
672526 -- ^ Symlink to cached or built nix output
673527-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
674528-- the caching mechanism will fail as it merely measures the modification
675529-- time of the cache link and the expression to build.
676−nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
530+nixBuildThunkAttrWithCache thunkDir attr = do
531+ --NB: Expects thunkDir to be normalised with no trailing path separator.
532+ --This should be guaranteed by the command argument parser.
533+ let cacheErrHandler e
534+ | isDoesNotExistError e = return Nothing -- expected from a cache miss
535+ | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
536+ cacheDir = thunkDir </> ".attr-cache"
537+ cachePath = cacheDir </> attr <.> "out"
677538 latestChange <- liftIO $ do
678− let
679− getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
680− thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
681− maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
682−
683− let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
684− _thunkSpec_files thunkSpec
685− for cachePaths' $ \cachePaths ->
686− fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
687− let
688− cachePath = thunkDir </> cacheDir </> attr <.> "out"
689− cacheErrHandler e
690− | isDoesNotExistError e = pure Nothing -- expected from a cache miss
691− | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
692− cacheHit <- handle cacheErrHandler $ do
693− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
694− pure $ if latestChange <= cacheTime
695− then Just cachePath
696− else Nothing
697− case cacheHit of
698− Just c -> pure c
699− Nothing -> do
700− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
701− liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
702− (cachePath <$) $ nixCmd $ NixCmd_Build $ def
703− & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath
704− & nixCmdConfig_target .~ Target
705− { _target_path = Just thunkDir
706− , _target_attr = Just attr
707− , _target_expr = Nothing
708− }
539+ createDirectoryIfMissing False cacheDir
540+ let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
541+ maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
542+ cacheHit <- handle cacheErrHandler $ do
543+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
544+ return $ if latestChange <= cacheTime
545+ then Just cachePath
546+ else Nothing
547+ case cacheHit of
548+ Just c -> return c
549+ Nothing -> do
550+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
551+ _ <- nixBuild $ def
552+ { _nixBuildConfig_target = Target
553+ { _target_path = thunkDir
554+ , _target_attr = Just attr
555+ }
556+ , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath
557+ }
558+ return cachePath
709559
710560-- | Build a nix attribute, and cache the result if possible
711561nixBuildAttrWithCache
@@ -716,19 +566,17 @@ nixBuildAttrWithCache
716566 -- ^ Attribute to build
717567 -> m FilePath
718568 -- ^ Symlink to cached or built nix output
719−nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
720− -- Only packed thunks are cached. In particular, checkouts are not.
721− Right (ThunkData_Packed spec _) ->
722− maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
723− _ -> build
724− where
725− build = nixCmd $ NixCmd_Build $ def
726− & nixBuildConfig_outLink .~ OutLink_None
727− & nixCmdConfig_target .~ Target
728− { _target_path = Just exprPath
569+nixBuildAttrWithCache exprPath attr = do
570+ readThunk exprPath >>= \case
571+ -- Only packed thunks are cached. in particular, checkouts are not
572+ Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
573+ _ -> nixBuild $ def
574+ { _nixBuildConfig_target = Target
575+ { _target_path = exprPath
729576 , _target_attr = Just attr
730− , _target_expr = Nothing
731577 }
578+ , _nixBuildConfig_outLink = OutLink_None
579+ }
732580
733581-- | Safely update thunk using a custom action
734582--
@@ -740,442 +588,223 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
740588 p' <- copyThunkToTmp tmpDir p
741589 unpackThunk' True p'
742590 result <- f p'
743− updateThunkFromTmp p'
591+ updateThunkFromTmp p' "origin" -- TODO: stop hardcoding remote
744592 return result
745593 where
746594 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
747595 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
748− Right ThunkData_Packed{} -> do
596+ Right (ThunkData_Packed _) -> do
749597 let tmpThunk = tmpDir </> "thunk"
750598 callProcessAndLogOutput (Notice, Error) $
751− proc cp ["-r", "-T", thunkDir, tmpThunk]
599+ proc "cp" ["-r", "-T", thunkDir, tmpThunk]
752600 return tmpThunk
753− Right _ -> failWith "Thunk is not packed"
754− updateThunkFromTmp p' = do
755− _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
601+ Right _ -> failWith $ "Thunk is not packed"
602+ updateThunkFromTmp p' remote = do
603+ packThunk' True p' remote
756604 callProcessAndLogOutput (Notice, Error) $
757− proc cp ["-r", "-T", p', p]
605+ proc "cp" ["-r", "-T", p', p]
758606
759607finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
760608finalMsg noTrail s = if noTrail then Nothing else Just s
761609
762−-- | Check that we are not somewhere inside the thunk directory
763−checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764−checkThunkDirectory thunkDir = do
765− currentDir <- liftIO getCurrentDirectory
766− thunkDir' <- liftIO $ canonicalizePath thunkDir
767− when (thunkDir' `L.isInfixOf` currentDir) $
768− failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
769−
770− -- Don't let thunk commands work when directly given an unpacked repo
771− when (takeFileName thunkDir == unpackedDirName) $
772− readThunk (takeDirectory thunkDir) >>= \case
773− Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
774− Left _ -> pure ()
775−
776610unpackThunk :: MonadObelisk m => FilePath -> m ()
777611unpackThunk = unpackThunk' False
778612
779613unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
780−unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
781− Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
614+unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case
615+ Left err -> failWith $ "thunk unpack: " <> T.pack (show err)
782616 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
783− Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
784− Right (ThunkData_Packed _ tptr) -> do
617+ Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
618+ Right (ThunkData_Packed tptr) -> do
785619 let (thunkParent, thunkName) = splitFileName thunkDir
786− withTempDirectory thunkParent thunkName $ \tmpThunk -> do
787− let
788− gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
789− newSpec = case _thunkPtr_source tptr of
790− ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
791− ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
792− withSpinner' ("Fetching thunk " <> T.pack thunkName)
793− (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
794− let unpackedPath = tmpThunk </> unpackedDirName
795− gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
796−
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
800−
801− liftIO $ do
802− removePathForcibly thunkDir
803− renameDirectory tmpThunk thunkDir
804−
805−gitCloneForThunkUnpack
806− :: MonadObelisk m
807− => GitSource -- ^ Git source to use
808− -> Ref hash -- ^ Commit hash to reset to
809− -> FilePath -- ^ Directory to clone into
810− -> m ()
811−gitCloneForThunkUnpack gitSrc commit dir = do
812− let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
813− git $ [ "clone" ]
814− ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
815− ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
816− ++ do branch <- maybeToList $ _gitSource_branch gitSrc
817− [ "--branch", T.unpack $ untagName branch ]
818− git ["reset", "--hard", Ref.toHexString commit]
819− when (_gitSource_fetchSubmodules gitSrc) $
820− git ["submodule", "update", "--recursive", "--init"]
821−
620+ withTempDirectory thunkParent thunkName $ \tmpRepo -> do
621+ let obGitDir = tmpRepo </> ".git" </> "obelisk"
622+ case _thunkPtr_source tptr of
623+ ThunkSource_GitHub s -> do
624+ mauth <- liftIO $ getHubAuth "github.com"
625+ repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
626+ githubURI <- either (liftIO . throwIO) (return . repoSshUrl) repoResult >>= \case
627+ Nothing -> failWith "Cannot determine clone URI for thunk source"
628+ Just c -> return $ T.unpack $ getUrl c
629+
630+ withSpinner' ("Fetching thunk " <> T.pack thunkDir)
631+ ( finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkDir) $ do
632+ callProcessAndLogOutput (Debug, Debug) $
633+ proc "hub" ["clone", "-n", githubURI, tmpRepo]
634+ --If this directory already exists then something is weird and we should fail
635+ liftIO $ createDirectory obGitDir
636+ callProcessAndLogOutput (Debug, Error) $
637+ proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
638+
639+ -- Checkout
640+ putLog Debug $ "Checking out " <> T.pack (show $ maybe "" untagName $ _gitHubSource_branch s)
641+ callProcessAndLogOutput (Debug, Debug) $
642+ proc "hub" $ concat
643+ [ ["-C", tmpRepo]
644+ , pure "checkout"
645+ , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)
646+ , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr
647+ ]
648+ -- Set upstream branch
649+ forM_ (_gitHubSource_branch s) $ \branch ->
650+ callProcessAndLogOutput (Debug, Error) $
651+ proc "hub" ["-C", tmpRepo, "branch", "-u", "origin/" <> T.unpack (untagName branch)]
652+ callProcessAndLogOutput (Notice, Error) $ proc "rm" ["-r", thunkDir]
653+ callProcessAndLogOutput (Notice, Error) $ proc "mv" ["-T", tmpRepo, thunkDir]
654+
655+ ThunkSource_Git s -> do
656+ withSpinner' ("Fetching thunk " <> T.pack thunkName)
657+ (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
658+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
659+ git ["clone", if _gitSource_fetchSubmodules s then "--recursive" else "", show (_gitSource_url s)]
660+ git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
661+ when (_gitSource_fetchSubmodules s) $
662+ git ["submodule", "update", "--recursive", "--init"]
663+ git ["branch", "-u", "origin/" <> T.unpack (untagName $ _gitSource_branch s)]
664+
665+ liftIO $ createDirectory obGitDir
666+ callProcessAndLogOutput (Notice, Error) $
667+ proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
668+ callProcessAndLogOutput (Notice, Error) $
669+ proc "rm" ["-r", thunkDir]
670+ callProcessAndLogOutput (Notice, Error) $
671+ proc "mv" ["-T", tmpRepo, thunkDir]
672+
673+--TODO: add force mode to pack even if changes are present
822674--TODO: add a rollback mode to pack to the original thunk
823−packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
675+packThunk :: MonadObelisk m => FilePath -> Text -> m ()
824676packThunk = packThunk' False
825677
826−packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
827−packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
828− Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
829− _ -> withSpinner'
830− ("Packing thunk " <> T.pack thunkDir)
831− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
832− do
833− let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
834− thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
835− liftIO $ removePathForcibly thunkDir
836− createThunk thunkDir $ Right thunkPtr
837− pure thunkPtr
838−
839−modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
840−modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
841− Nothing -> ptr
842− Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of
843− ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }
844− ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
845− }
846−
847−data CheckClean
848− = CheckClean_FullCheck
849− -- ^ Check that the repo is clean, including .gitignored files
850− | CheckClean_NotIgnored
851− -- ^ Check that the repo is clean, not including .gitignored files
852− | CheckClean_NoCheck
853− -- ^ Don't check that the repo is clean
854−
855−getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
856−getThunkPtr gitCheckClean dir mPrivate = do
857− let repoLocations = nubOrd $ map (first normalise)
858− [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]
859− repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
860− thunkDir <- case repoLocation' of
861− Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
862− Just (_, path) -> pure $ normalise $ dir </> path
863−
864− let (checkClean, checkIgnored) = case gitCheckClean of
865− CheckClean_FullCheck -> (True, True)
866− CheckClean_NotIgnored -> (True, False)
867− CheckClean_NoCheck -> (False, False)
868− when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
869− "thunk pack: thunk checkout contains unsaved modifications"
870−
871− -- Check whether there are any stashes
872− when checkClean $ do
678+packThunk' :: MonadObelisk m => Bool -> FilePath -> Text -> m ()
679+packThunk' noTrail thunkDir upstream = readThunk thunkDir >>= \case
680+ Left err -> failWith $ T.pack $ "thunk pack: " <> show err
681+ Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
682+ Right (ThunkData_Checkout _) -> do
683+ withSpinner' ("Packing thunk " <> T.pack thunkDir)
684+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
685+ thunkPtr <- getThunkPtr thunkDir upstream
686+ callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
687+ liftIO $ createThunk thunkDir thunkPtr
688+
689+getThunkPtr :: MonadObelisk m => FilePath -> Text -> m ThunkPtr
690+getThunkPtr = getThunkPtr' True
691+
692+getThunkPtr' :: MonadObelisk m => Bool -> FilePath -> Text -> m ThunkPtr
693+getThunkPtr' checkClean thunkDir upstream = do
694+ when checkClean $ ensureCleanGitRepo thunkDir True $
695+ "thunk pack: thunk checkout contains unsaved modifications"
696+
697+ -- Check whether there are any stashes
873698 stashOutput <- readGitProcess thunkDir ["stash", "list"]
874− unless (T.null stashOutput) $
875− failWith $ T.unlines $
876− [ "thunk pack: thunk checkout has stashes"
877− , "git stash list:"
878− ] ++ T.lines stashOutput
879−
880− -- Get current branch
881− (mCurrentBranch, mCurrentCommit) <- do
882− b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
883− c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
884− case b of
885− (Just "HEAD") -> failWith $ T.unlines
886− [ "thunk pack: You are in 'detached HEAD' state."
887− , "If you want to pack at the current ref \
888− \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
889− ]
890− _ -> return (b, c)
891−
892− -- Get information on all branches and their (optional) designated upstream
893− -- correspondents
894− headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
895− [ "for-each-ref"
896− , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
897− , "refs/heads/"
898− ]
899−
900− (headInfo :: Map Text (Maybe (Text, Text)))
901− <- fmap Map.fromList $ forM headDump $ \line -> do
902− (branch : restOfLine) <- pure $ T.words line
903− mUpstream <- case restOfLine of
904− [] -> pure Nothing
905− [u, r] -> pure $ Just (u, r)
906− (_:_) -> failWith "git for-each-ref invalid output"
907− pure (branch, mUpstream)
908−
909− putLog Debug $ "branches: " <> T.pack (show headInfo)
910−
911− let errorMap :: Map Text ()
912− headUpstream :: Map Text (Text, Text)
913− (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
914− Nothing -> Left ()
915− Just b -> Right b
916−
917− putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)
918−
919− -- Check that every branch has a remote equivalent
920− when checkClean $ do
921− let untrackedBranches = Map.keys errorMap
922− when (not $ L.null untrackedBranches) $ failWith $ T.unlines $
923− [ "thunk pack: Certain branches in the thunk have no upstream branch \
924− \set. This means we don't know to check whether all your work is \
925− \saved. The offending branches are:"
926− , ""
927− , T.unwords untrackedBranches
928− , ""
929− , "To fix this, you probably want to do:"
930− , ""
931− ] ++
932− ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++
933− [ ""
934− , "These will push the branches to the default remote under the same \
935− \name, and (thanks to the `-u`) remember that choice so you don't \
936− \get this error again."
937− ]
938−
939− -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
940− stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
941− (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
942− [ "rev-list", "--left-right"
943− , T.unpack branch <> "..." <> T.unpack upstream
944− ]
945− let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
946− behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
947− pure (upstream, (ahead, behind))
948−
949− -- Those branches which have commits ahead of, i.e. not on, the upstream
950− -- branch. Purely being behind is fine.
951− let nonGood = Map.filter ((/= 0) . fst . snd) stats
952−
953− when (not $ Map.null nonGood) $ failWith $ T.unlines $
954− [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
955− , ""
956− ] ++
957− flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
958− [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
959− [ ""
960− , "Please push these upstream and try again. (Or just fetch, if they are somehow \
961− \pushed but this repo's remote tracking branches don't know it.)"
962− ]
963−
964− when checkClean $ do
965− -- We assume it's safe to pack the thunk at this point
966− putLog Informational "All changes safe in git remotes. OK to pack thunk."
967−
968− let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
969−
970− [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
971− [ "config"
972− , "--get"
973− , "remote." <> T.unpack remote <> ".url"
974− ]
975−
976− remoteUri <- case parseGitUri remoteUri' of
977− Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
978− Just uri -> pure uri
979− uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
980−
981−-- | Get the latest revision available from the given source
982−getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
983−getLatestRev os = do
984− let gitS = thunkSourceToGitSource os
985− (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
986− case os of
987− ThunkSource_GitHub s -> githubThunkRev s commit
988− ThunkSource_Git s -> gitThunkRev s commit
989−
990−-- | Convert a URI to a thunk
991−--
992−-- If the URL is a github URL, we try to just download an archive for
993−-- performance. If that doesn't work (e.g. authentication issue), we fall back
994−-- on just doing things the normal way for git repos in general, and save it as
995−-- a regular git thunk.
996−uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
997−uriThunkPtr uri mPrivate mbranch mcommit = do
998− commit <- case mcommit of
999− Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
1000− (Just c) -> return c
1001− (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
1002− ThunkSource_GitHub s -> do
1003− rev <- runExceptT $ githubThunkRev s commit
1004− case rev of
1005− Right r -> pure (ThunkSource_GitHub s, r)
1006− Left e -> do
1007− putLog Warning "\
1008−\Failed to fetch archive from GitHub. This is probably a private repo. \
1009−\Falling back on normal fetchgit. Original failure:"
1010− errorToWarning e
1011− let s' = forgetGithub True s
1012− (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
1013− ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
1014− pure $ ThunkPtr
1015− { _thunkPtr_rev = rev
1016− , _thunkPtr_source = src
1017− }
1018−
1019−-- | N.B. Cannot infer all fields.
1020−--
1021−-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
1022−-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
1023−-- should be employed, and so we respect that.
1024−uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
1025−uriToThunkSource (GitUri u) mPrivate
1026− | Right uriAuth <- URI.uriAuthority u
1027− , Just scheme <- URI.unRText <$> URI.uriScheme u
1028− , case scheme of
1029− "ssh" -> uriAuth == URI.Authority
1030− { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
1031− , URI.authHost = fromRight' $ URI.mkHost "github.com"
1032− , URI.authPort = Nothing
699+ when checkClean $ case T.null stashOutput of
700+ False -> do
701+ failWith $ T.unlines $
702+ [ "thunk pack: thunk checkout has stashes"
703+ , "git stash list:"
704+ ] ++ T.lines stashOutput
705+ True -> return ()
706+
707+ --Check whether all local heads are pushed
708+ repoHeads <- T.lines <$> readGitProcess thunkDir ["for-each-ref", "--format=%(refname:short)", "refs/heads/"]
709+ remotes <- T.lines <$> readGitProcess thunkDir ["remote"]
710+ --Check that the upstream specified actually exists
711+ case L.find (== upstream) remotes of
712+ Nothing -> failWith $ "thunk pack: upstream " <> upstream <> " does not exist. Available upstreams are " <> T.intercalate ", " remotes
713+ Just _ -> return ()
714+ -- iterate over cartesian product
715+ when checkClean $ forM_ repoHeads $ \hd -> do
716+ [localRev] <- T.lines <$> readGitProcess thunkDir ["rev-parse", T.unpack hd]
717+ forM_ remotes $ \rm -> do
718+ --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
719+ [remoteMergeRev] <- fmap T.lines $ readGitProcess thunkDir
720+ ["merge-base", T.unpack localRev, "remotes/" <> T.unpack rm <> "/" <> T.unpack hd]
721+ case remoteMergeRev == localRev of
722+ False -> failWith $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
723+ True -> return ()
724+
725+ --We assume it's safe to pack the thunk at this point
726+ [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir ["config", "--get", "remote." <> T.unpack upstream <> ".url"]
727+
728+ let uriParseFailure = "Could not identify git remote: " <> remoteUri'
729+ mRemoteUri = parseGitUri remoteUri'
730+ case mRemoteUri of
731+ Nothing -> failWith uriParseFailure
732+ Just remoteUri -> do
733+ refs <- fmap (map (refsToTuples . T.words) . T.lines) $ readGitProcess thunkDir ["show-ref", "--head"]
734+ -- safe because exactly one hash is associated with HEAD
735+ let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
736+ remoteHeads = Map.fromList $ catMaybes $ fmap
737+ (\(x,y) -> (,) x <$> T.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
738+ refs
739+ localHeads = Map.fromList $ catMaybes $ fmap
740+ (\(x,y) -> (,) x <$> T.stripPrefix "refs/heads/" y)
741+ refs
742+ currentUpstreamBranch = Map.lookup currentHead remoteHeads
743+ <|> Map.lookup currentHead localHeads
744+ if isGithubThunk remoteUri
745+ then githubThunkPtr remoteUri currentHead currentUpstreamBranch
746+ else gitThunkPtr remoteUri currentHead currentUpstreamBranch
747+ where
748+ refsToTuples [x, y] = (x, y)
749+ refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
750+ isGithubThunk u
751+ | Just uriAuth <- uriAuthority u
752+ = case uriScheme u of
753+ "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""
754+ s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"
755+ && uriRegName uriAuth == "github.com"
756+ | otherwise = False
757+ githubThunkPtr u commit' branch' = do
758+ ["/", owner', repo'] <- return $ splitDirectories (uriPath u)
759+ let owner = N (T.pack owner')
760+ dropGitExtension r = fromMaybe r $ T.stripSuffix ".git" r
761+ repo = N $ dropGitExtension $ T.pack repo'
762+ commit = N commit'
763+ branch = N <$> branch'
764+ mauth <- liftIO $ getHubAuth "github.com"
765+ repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR owner repo
766+ repoIsPrivate <- either (liftIO . throwIO) (return . repoPrivate) repoResult
767+ archiveResult <- liftIO $ executeRequestMaybe mauth $
768+ archiveForR owner repo ArchiveFormatTarball (Just (untagName commit))
769+ archiveUri <- either (liftIO . throwIO) return archiveResult
770+ hash <- getNixSha256ForUriUnpacked archiveUri
771+ return $ ThunkPtr
772+ { _thunkPtr_rev = ThunkRev
773+ { _thunkRev_commit = commitNameToRef commit
774+ , _thunkRev_nixSha256 = hash
1033775 }
1034− s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
1035− && URI.unRText (URI.authHost uriAuth) == "github.com"
1036− , Just (_, owner :| [repoish]) <- URI.uriPath u
1037− = \mbranch -> do
1038− isPrivate <- getIsPrivate
1039− pure $ ThunkSource_GitHub $ GitHubSource
1040− { _gitHubSource_owner = N $ URI.unRText owner
1041− , _gitHubSource_repo = N $ let
1042− repoish' = URI.unRText repoish
1043− in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
1044− , _gitHubSource_branch = N <$> mbranch
1045− , _gitHubSource_private = isPrivate
776+ , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
777+ { _gitHubSource_owner = owner
778+ , _gitHubSource_repo = repo
779+ , _gitHubSource_branch = branch
780+ , _gitHubSource_private = repoIsPrivate
1046781 }
1047−
1048− | otherwise = \mbranch -> do
1049− isPrivate <- getIsPrivate
1050− pure $ ThunkSource_Git $ GitSource
1051− { _gitSource_url = GitUri u
1052− , _gitSource_branch = N <$> mbranch
782+ }
783+ gitThunkPtr u commit branch' = do
784+ let protocols = ["https:", "ssh:", "git:"]
785+ unless (T.toLower (T.pack $ uriScheme u) `elem` protocols) $
786+ failWith $ "thunk pack: obelisk currently only supports "
787+ <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
788+ hash <- nixPrefetchGit u commit False
789+ branch <- case branch' of
790+ Nothing -> failWith "thunk pack: git thunks must track a branch"
791+ Just b -> pure $ N b
792+ pure $ ThunkPtr
793+ { _thunkPtr_rev = ThunkRev
794+ { _thunkRev_commit = commitNameToRef (N commit)
795+ , _thunkRev_nixSha256 = hash
796+ }
797+ , _thunkPtr_source = ThunkSource_Git $ GitSource
798+ { _gitSource_url = u
799+ , _gitSource_branch = branch
1053800 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
1054− , _gitSource_private = isPrivate
1055801 }
1056− where
1057− getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
1058−
1059−guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
1060−guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
1061− [] -> pure True
1062− uriAttempt:xs -> do
1063− result <- readCreateProcessWithExitCode $
1064− isolateGitProc $
1065− gitProcNoRepo
1066− [ "ls-remote"
1067− , "--quiet"
1068− , "--exit-code"
1069− , "--symref"
1070− , T.unpack $ gitUriToText uriAttempt
1071− ]
1072− case result of
1073− (ExitSuccess, _, _) -> pure False -- Must be a public repo
1074− _ -> loop xs
1075− where
1076− urisToTry = nubOrd $
1077− -- Include the original URI if it isn't using SSH because SSH will certainly fail.
1078− [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>
1079− [changeScheme "https" uri, changeScheme "http" uri]
1080− changeScheme scheme (GitUri u) = GitUri $ u
1081− { URI.uriScheme = URI.mkScheme scheme
1082− , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u
1083802 }
1084803
1085−-- Funny signature indicates no effects depend on the optional branch name.
1086−githubThunkRev
1087− :: forall m
1088− . MonadObelisk m
1089− => GitHubSource
1090− -> Text
1091− -> m ThunkRev
1092−githubThunkRev s commit = do
1093− owner <- forcePP $ _gitHubSource_owner s
1094− repo <- forcePP $ _gitHubSource_repo s
1095− revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
1096− let archiveUri = GitUri $ URI.URI
1097− { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
1098− , URI.uriAuthority = Right $ URI.Authority
1099− { URI.authUserInfo = Nothing
1100− , URI.authHost = fromRight' $ URI.mkHost "github.com"
1101− , URI.authPort = Nothing
1102− }
1103− , URI.uriPath = Just ( False
1104− , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
1105− )
1106− , URI.uriQuery = []
1107− , URI.uriFragment = Nothing
1108− }
1109− hash <- getNixSha256ForUriUnpacked archiveUri
1110− putLog Debug $ "Nix sha256 is " <> hash
1111− return $ ThunkRev
1112− { _thunkRev_commit = commitNameToRef $ N commit
1113− , _thunkRev_nixSha256 = hash
1114− }
1115− where
1116− forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
1117− forcePP = URI.mkPathPiece . untagName
1118−
1119−gitThunkRev
1120− :: MonadObelisk m
1121− => GitSource
1122− -> Text
1123− -> m ThunkRev
1124−gitThunkRev s commit = do
1125− let u = _gitSource_url s
1126− protocols = ["file", "https", "ssh", "git"]
1127− scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
1128− unless (T.toLower scheme `elem` protocols) $
1129− failWith $ "obelisk currently only supports "
1130− <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
1131− hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
1132− putLog Informational $ "Nix sha256 is " <> hash
1133− pure $ ThunkRev
1134− { _thunkRev_commit = commitNameToRef (N commit)
1135− , _thunkRev_nixSha256 = hash
1136− }
1137−
1138−-- | Given the URI to a git remote, and an optional branch name, return the name
1139−-- of the branch along with the hash of the commit at tip of that branch.
1140−--
1141−-- If the branch name is passed in, it is returned exactly as-is. If it is not
1142−-- passed it, the default branch of the repo is used instead.
1143−
1144−gitGetCommitBranch
1145− :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
1146−gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
1147− (_, bothMaps) <- gitLsRemote
1148− (T.unpack $ gitUriToText uri)
1149− (GitRef_Branch <$> mbranch)
1150− Nothing
1151− branch <- case mbranch of
1152− Nothing -> withExitFailMessage "Failed to find default branch" $ do
1153− b <- rethrowE $ gitLookupDefaultBranch bothMaps
1154− putLog Debug $ "Default branch for remote repo " <> uriMsg <> " is " <> b
1155− pure b
1156− Just b -> pure b
1157− commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)
1158− putLog Informational $ "Latest commit in branch " <> branch
1159− <> " from remote repo " <> uriMsg
1160− <> " is " <> commit
1161− pure (branch, commit)
1162− where
1163− rethrowE = either failWith pure
1164− uriMsg = gitUriToText uri
1165−
1166−parseGitUri :: Text -> Maybe GitUri
1167−parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
1168−
1169−parseFileURI :: Text -> Maybe URI.URI
1170−parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
1171−
1172−parseAbsoluteURI :: Text -> Maybe URI.URI
1173−parseAbsoluteURI uri = do
1174− parsedUri <- URI.mkURI uri
1175− guard $ URI.isPathAbsolute parsedUri
1176− pure parsedUri
804+parseGitUri :: Text -> Maybe URI
805+parseGitUri x = parseURIReference (T.unpack x) <|> parseSshShorthand x
1177806
1178−parseSshShorthand :: Text -> Maybe URI.URI
807+parseSshShorthand :: Text -> Maybe URI
1179808parseSshShorthand uri = do
1180809 -- This is what git does to check that the remote
1181810 -- is not a local file path when parsing shorthand.
@@ -1188,4 +817,4 @@ parseSshShorthand uri = do
1188817 -- This check is used to disambiguate a filepath containing a colon from shorthand
1189818 guard $ isNothing (T.findIndex (=='/') authAndHostname)
1190819 && not (T.null colonAndPath)
1191− URI.mkURI properUri
820+ parseURI $ T.unpack properUri