@@ -1,81 +1,74 @@
11{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
23{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
35{-# LANGUAGE MultiWayIf #-}
46{-# LANGUAGE OverloadedStrings #-}
57{-# LANGUAGE PatternGuards #-}
6−{-# LANGUAGE TemplateHaskell #-}
7−
8−module Obelisk.Command.Thunk
9− ( ThunkPtr (..)
10− , ThunkRev (..)
11− , ThunkSource (..)
12− , ThunkData (..)
13− , GitHubSource (..)
14− , getLatestRev
15− , updateThunkToLatest
16− , createThunk
17− , createThunkWithLatest
18− , nixBuildAttrWithCache
19− , nixBuildThunkAttrWithCache
20− , unpackThunk
21− , packThunk
22− , readThunk
23− , getThunkPtr
24− ) where
8+{-# LANGUAGE QuasiQuotes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+module Obelisk.Command.Thunk where
2512
2613import Control.Applicative
27−import Control.Exception
14+import Control.Exception (displayException, try)
15+import Control.Lens (ifor, ifor_, (.~))
2816import Control.Monad
17+import Control.Monad.Extra (findM)
18+import Control.Monad.Catch (MonadCatch, handle)
2919import Control.Monad.Except
30−import Data.Aeson as Aeson
20+import Data.Aeson ((.=))
21+import qualified Data.Aeson as Aeson
3122import Data.Aeson.Encode.Pretty
23+import qualified Data.Aeson.Types as Aeson
24+import Data.Bifunctor (first)
3225import qualified Data.ByteString.Lazy as LBS
26+import Data.Containers.ListUtils (nubOrd)
3327import Data.Default
34−import Data.Foldable
28+import Data.Either.Combinators (fromRight', rightToMaybe)
29+import Data.Foldable (toList)
30+import Data.Function ((&))
31+import Data.Functor ((<&>))
3532import Data.Git.Ref (Ref)
3633import qualified Data.Git.Ref as Ref
3734import qualified Data.List as L
38−import Data.List.NonEmpty (NonEmpty (..))
35+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
3936import qualified Data.List.NonEmpty as NonEmpty
37+import Data.Map (Map)
4038import qualified Data.Map as Map
4139import Data.Maybe
42−import Data.Monoid
4340import Data.Set (Set)
4441import qualified Data.Set as Set
42+import Data.String.Here.Interpolated (i)
43+import Data.String.Here.Uninterpolated (here)
4544import Data.Text (Text)
4645import qualified Data.Text as T
4746import Data.Text.Encoding
4847import qualified Data.Text.IO as T
4948import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
50−import Data.Yaml (parseMaybe, (.:))
51−import qualified Data.Yaml as Yaml
49+import Data.Traversable (for)
50+import Data.Yaml (parseMaybe)
5251import GitHub
5352import GitHub.Data.Name
54−import GitHub.Endpoints.Repos.Contents (archiveForR)
55−import Network.URI
5653import Obelisk.Command.Nix
5754import System.Directory
5855import System.Exit
5956import System.FilePath
60−import System.IO
6157import System.IO.Error
6258import System.IO.Temp
63−import System.Posix (getSymbolicLinkStatus, modificationTime)
64−import System.Process (StdStream (CreatePipe), callProcess, createProcess, proc, readProcess, std_err,
65− std_out, waitForProcess)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
60+import qualified Text.URI as URI
6661
67−import Development.Placeholders
62+import Obelisk.App (MonadObelisk)
63+import Obelisk.CliApp
6864import Obelisk.Command.Utils
6965
70−import Obelisk.Command.CLI (putError, putErrorAndExit, putWarning, withSpinner)
71−
7266--TODO: Support symlinked thunk data
7367data ThunkData
74− = ThunkData_Packed ThunkPtr
68+ = ThunkData_Packed ThunkSpec ThunkPtr
7569 -- ^ Packed thunk
76− | ThunkData_Checkout (Maybe ThunkPtr)
70+ | ThunkData_Checkout
7771 -- ^ Checked out thunk that was unpacked from this pointer
78− deriving (Show, Eq, Ord)
7972
8073-- | A reference to the exact data that a thunk should translate into
8174data ThunkPtr = ThunkPtr
@@ -88,7 +81,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
8881
8982-- | A specific revision of data; it may be available from multiple sources
9083data ThunkRev = ThunkRev
91− { _thunkRev_commit :: Ref
84+ { _thunkRev_commit :: Ref Ref.SHA1
9285 , _thunkRev_nixSha256 :: NixSha256
9386 }
9487 deriving (Show, Eq, Ord)
@@ -101,6 +94,11 @@ data ThunkSource
10194 | ThunkSource_Git GitSource
10295 deriving (Show, Eq, Ord)
10396
97+thunkSourceToGitSource :: ThunkSource -> GitSource
98+thunkSourceToGitSource = \case
99+ ThunkSource_GitHub s -> forgetGithub False s
100+ ThunkSource_Git s -> s
101+
104102data GitHubSource = GitHubSource
105103 { _gitHubSource_owner :: Name Owner
106104 , _gitHubSource_repo :: Name Repo
@@ -109,157 +107,263 @@ data GitHubSource = GitHubSource
109107 }
110108 deriving (Show, Eq, Ord)
111109
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+
112119data GitSource = GitSource
113− { _gitSource_url :: URI
114− --TODO: Is it ok to use the types from the GitHub api bindings?
120+ { _gitSource_url :: GitUri
115121 , _gitSource_branch :: Maybe (Name Branch)
116122 , _gitSource_fetchSubmodules :: Bool
123+ , _gitSource_private :: Bool
117124 }
118125 deriving (Show, Eq, Ord)
119126
120−commitNameToRef :: Name Commit -> Ref
121−commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
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
122135
123−getNixSha256ForUriUnpacked :: URI -> IO NixSha256
124−getNixSha256ForUriUnpacked uri = do
125− --TODO: Make this package depend on nix-prefetch-url properly
126− let cmd = proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
127− (_, Just out, Just err, p) <- createProcess cmd
128− { std_out = CreatePipe
129− , std_err = CreatePipe
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
130159 }
131− --TODO: Deal with errors here; usually they're HTTP errors
132− waitForProcess p >>= \case
133− ExitSuccess -> return ()
134− _ -> do
135− hPutStrLn stdout =<< hGetContents out
136− hPutStrLn stderr =<< hGetContents err
137− --TODO: actual error
138− putErrorAndExit $ "nix-prefetch-url"
139− T.strip <$> T.hGetContents out
160+ , _gitSource_branch = _gitHubSource_branch s
161+ , _gitSource_fetchSubmodules = False
162+ , _gitSource_private = _gitHubSource_private s
163+ }
140164
141−-- | Get the latest revision available from the given source
142−getLatestRev :: ThunkSource -> IO ThunkRev
143−getLatestRev = \case
144− ThunkSource_GitHub s -> do
145− auth <- getHubAuth "github.com"
146− commitsResult <- executeRequestMaybe auth $ commitsWithOptionsForR
147− (_gitHubSource_owner s)
148− (_gitHubSource_repo s)
149− (FetchAtLeast 1)
150− $ case _gitHubSource_branch s of
151− Nothing -> []
152− Just b -> [CommitQuerySha $ untagName b]
153− commitInfos <- either throwIO return commitsResult
154− commitInfo : _ <- return $ toList commitInfos
155− let commit = commitSha commitInfo
156− Right archiveUri <- executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit
157− nixSha256 <- getNixSha256ForUriUnpacked archiveUri
158− return $ ThunkRev
159− { _thunkRev_commit = commitNameToRef commit
160− , _thunkRev_nixSha256 = nixSha256
161− }
162− ThunkSource_Git _s -> do
163− $notImplemented
165+getThunkGitBranch :: ThunkPtr -> Maybe Text
166+getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
167+ ThunkSource_GitHub s -> _gitHubSource_branch s
168+ ThunkSource_Git s -> _gitSource_branch s
169+
170+commitNameToRef :: Name Commit -> Ref Ref.SHA1
171+commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
172+
173+-- TODO: Use spinner here.
174+getNixSha256ForUriUnpacked
175+ :: MonadObelisk m
176+ => GitUri
177+ -> m NixSha256
178+getNixSha256ForUriUnpacked 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
183+
184+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
185+nixPrefetchGit 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
190+ , "--rev", T.unpack rev
191+ , if fetchSubmodules then "--fetch-submodules" else ""
192+ , "--quiet"
193+ ]
194+
195+ case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of
196+ Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
197+ Just x -> pure x
164198
165199--TODO: Pretty print these
166200data ReadThunkError
167− = ReadThunkError_WrongContents (Set String) (Set String)
168− | ReadThunkError_UnrecognizedLoader Text
169− | ReadThunkError_UnparseablePtr LBS.ByteString
170− deriving (Show)
171−
172−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
173−-- If the thunk is packed and additional data is present, fail.
174−readThunk :: FilePath -> IO (Either ReadThunkError ThunkData)
175−readThunk thunkDir = do
176− files <- listDirectory thunkDir
177− case ".git" `elem` files of
178− True -> fmap ThunkData_Checkout <$> do
179− let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
180− doesDirectoryExist origThunkPath >>= \case
181− True -> fmap Just <$> readPackedThunk origThunkPath
182− False -> return $ return Nothing
183− False -> fmap ThunkData_Packed <$> readPackedThunk thunkDir
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)
228+ }
229+
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}|]
184307
185308-- | Read a thunk and validate that it is exactly a packed thunk.
186309-- If additional data is present, fail.
187−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
188−readPackedThunk thunkDir = runExceptT $ do
189− let thunkLoader = thunkDir </> "default.nix"
190− githubJson = thunkDir </> "github.json"
191− attrCache = thunkDir </> ".attr-cache"
192− expectedContents = Set.fromList $
193− [ githubJson
194− , thunkLoader
195− ]
196− optionalContents = Set.fromList $
197− [ attrCache
198− ]
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
311+readThunk = readThunkWith thunkSpecTypes
199312
200− -- Ensure that there aren't any other files in the thunk
201− -- NB: System.Directory.listDirectory returns the contents without the directory path
202− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
203− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
204− missingContents = expectedContents `Set.difference` files
205− unless (Set.null unexpectedContents && Set.null missingContents) $ do
206− throwError $ ReadThunkError_WrongContents unexpectedContents missingContents
207−
208− -- Ensure that we recognize the thunk loader
209− loader <- liftIO $ T.readFile thunkLoader
210− unless (loader `elem` gitHubStandaloneLoaders) $ do
211− throwError $ ReadThunkError_UnrecognizedLoader loader
212−
213− txt <- liftIO $ LBS.readFile githubJson
214− let parseThunk v = do
215− rev <- v Aeson..: "rev"
216− sha256 <- v Aeson..: "sha256"
217− src <- parseGitHubSource v
218− <|> parseGitSource v
219− return $ ThunkPtr
220− { _thunkPtr_rev = ThunkRev
221− { _thunkRev_commit = Ref.fromHexString rev
222− , _thunkRev_nixSha256 = sha256
223− }
224− , _thunkPtr_source = src
225− }
226− parseGitHubSource v = do
227− owner <- v Aeson..: "owner"
228− repo <- v Aeson..: "repo"
229− branch <- v Aeson..:! "branch"
230− mPrivate <- v Aeson..:! "private"
231− return $ ThunkSource_GitHub $ GitHubSource
232− { _gitHubSource_owner = owner
233− , _gitHubSource_repo = repo
234− , _gitHubSource_branch = branch
235− , _gitHubSource_private = fromMaybe False mPrivate
236− }
237− parseGitSource v = do
238− Just url <- parseURI <$> v Aeson..: "url"
239− branch <- v Aeson..:! "branch"
240− fetchSubmodules <- v Aeson..: "fetchSubmodules"
241− return $ ThunkSource_Git $ GitSource
242− { _gitSource_url = url
243− , _gitSource_branch = branch
244− , _gitSource_fetchSubmodules = fetchSubmodules
245− }
246− case parseMaybe parseThunk =<< decode txt of
247− Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
248− Just ptr -> return ptr
313+parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
314+parseThunkPtr parseSrc v = do
315+ rev <- v Aeson..: "rev"
316+ sha256 <- v Aeson..: "sha256"
317+ src <- parseSrc v
318+ pure $ ThunkPtr
319+ { _thunkPtr_rev = ThunkRev
320+ { _thunkRev_commit = Ref.fromHexString rev
321+ , _thunkRev_nixSha256 = sha256
322+ }
323+ , _thunkPtr_source = src
324+ }
325+
326+parseGitHubSource :: Aeson.Object -> Aeson.Parser GitHubSource
327+parseGitHubSource v = do
328+ owner <- v Aeson..: "owner"
329+ repo <- v Aeson..: "repo"
330+ branch <- v Aeson..:! "branch"
331+ private <- v Aeson..:? "private"
332+ pure $ GitHubSource
333+ { _gitHubSource_owner = owner
334+ , _gitHubSource_repo = repo
335+ , _gitHubSource_branch = branch
336+ , _gitHubSource_private = fromMaybe False private
337+ }
249338
250−overwriteThunk :: FilePath -> ThunkPtr -> IO ()
339+parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
340+parseGitSource v = do
341+ Just url <- parseGitUri <$> v Aeson..: "url"
342+ branch <- v Aeson..:! "branch"
343+ fetchSubmodules <- v Aeson..:! "fetchSubmodules"
344+ private <- v Aeson..:? "private"
345+ pure $ GitSource
346+ { _gitSource_url = url
347+ , _gitSource_branch = branch
348+ , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
349+ , _gitSource_private = fromMaybe False private
350+ }
351+
352+overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
251353overwriteThunk target thunk = do
252354 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
253− Right _ <- readThunk target
355+ readThunk target >>= \case
356+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
357+ Right _ -> pure ()
254358
255359 --TODO: Is there a safer way to do this overwriting?
256− removeDirectoryRecursive target
257− createThunk target thunk
360+ liftIO $ removePathForcibly target
361+ createThunk target $ Right thunk
258362
259−thunkPtrLoader :: ThunkPtr -> Text
260−thunkPtrLoader thunk = case _thunkPtr_source thunk of
261− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
262− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
363+thunkPtrToSpec :: ThunkPtr -> ThunkSpec
364+thunkPtrToSpec thunk = case _thunkPtr_source thunk of
365+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
366+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
263367
264368-- It's important that formatting be very consistent here, because
265369-- otherwise when people update thunks, their patches will be messy
@@ -268,21 +372,18 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
268372 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
269373 [ Just $ "owner" .= _gitHubSource_owner s
270374 , Just $ "repo" .= _gitHubSource_repo s
271− , case _gitHubSource_branch s of
272− Just b -> Just $ "branch" .= b
273− Nothing -> Nothing
274− , if _gitHubSource_private s
275− then Just $ "private" .= True
276− else Nothing
375+ , ("branch" .=) <$> _gitHubSource_branch s
277376 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
278377 , Just $ "sha256" .= _thunkRev_nixSha256 rev
378+ , Just $ "private" .= _gitHubSource_private s
279379 ]
280380 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
281− --TODO: Is this safe? read/show is jank for `URI`
282− [ Just $ "url" .= show (_gitSource_url s)
381+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
283382 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
383+ , ("branch" .=) <$> _gitSource_branch s
284384 , Just $ "sha256" .= _thunkRev_nixSha256 rev
285385 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
386+ , Just $ "private" .= _gitSource_private s
286387 ]
287388 where
288389 githubCfg = defConfig
@@ -303,54 +404,84 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
303404 [ "url"
304405 , "rev"
305406 , "sha256"
407+ , "private"
306408 , "fetchSubmodules"
307409 ] <> compare
308410 , confTrailingNewline = True
309411 }
310412
311−createThunk :: FilePath -> ThunkPtr -> IO ()
312−createThunk target thunk = do
313− createDirectoryIfMissing True (target </> ".attr-cache")
314− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
315− LBS.writeFile (target </> "github.json") (encodeThunkPtrData thunk)
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
316428
317−createThunkWithLatest :: FilePath -> ThunkSource -> IO ()
429+createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
318430createThunkWithLatest target s = do
319431 rev <- getLatestRev s
320− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
321433 { _thunkPtr_source = s
322434 , _thunkPtr_rev = rev
323435 }
324436
325−updateThunkToLatest :: FilePath -> IO ()
326−updateThunkToLatest target = do
327− (overwrite, ptr) <- readThunk target >>= \case
328− Left err -> fail $ "thunk update: " <> show err
329− Right c -> return $ case c of
330− ThunkData_Packed t -> (target, t)
331− ThunkData_Checkout _ -> fail "cannot update an unpacked thunk"
332− let src = _thunkPtr_source ptr
333− rev <- getLatestRev src
334− overwriteThunk overwrite $ ThunkPtr
335− { _thunkPtr_source = src
336− , _thunkPtr_rev = rev
337− }
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
338467
339468-- | All recognized github standalone loaders, ordered from newest to oldest.
340469-- This tool will only ever produce the newest one when it writes a thunk.
341−gitHubStandaloneLoaders :: NonEmpty Text
342−gitHubStandaloneLoaders =
343− gitHubStandaloneLoaderV2 :|
344− [ gitHubStandaloneLoaderV1
470+gitHubThunkSpecs :: NonEmpty ThunkSpec
471+gitHubThunkSpecs =
472+ gitHubThunkSpecV5 :|
473+ [ gitHubThunkSpecV4
474+ , gitHubThunkSpecV3
475+ , gitHubThunkSpecV2
476+ , gitHubThunkSpecV1
345477 ]
346478
347−gitHubStandaloneLoaderV1 :: Text
348−gitHubStandaloneLoaderV1 = T.unlines
349− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
350− ]
479+gitHubThunkSpecV1 :: ThunkSpec
480+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
481+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
351482
352−gitHubStandaloneLoaderV2 :: Text
353−gitHubStandaloneLoaderV2 = T.unlines
483+gitHubThunkSpecV2 :: ThunkSpec
484+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
354485 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
355486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
356487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -360,289 +491,701 @@ gitHubStandaloneLoaderV2 = T.unlines
360491 , "))"
361492 ]
362493
363−plainGitStandaloneLoaders :: NonEmpty Text
364−plainGitStandaloneLoaders =
365− plainGitStandaloneLoaderV1 :|
366− [
494+gitHubThunkSpecV3 :: ThunkSpec
495+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
496+ [ "# DO NOT HAND-EDIT THIS FILE"
497+ , "let"
498+ , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
499+ , " then fetchFromGitHubPrivate args"
500+ , " else (import <nixpkgs> {}).fetchFromGitHub (builtins.removeAttrs args [\"branch\"]);"
501+ , " fetchFromGitHubPrivate ="
502+ , " { owner, repo, rev, branch ? null, name ? null, sha256 ? null, private ? false"
503+ , " , fetchSubmodules ? false, githubBase ? \"github.com\", ..."
504+ , " }: assert !fetchSubmodules;"
505+ , " builtins.fetchGit ({"
506+ , " url = \"ssh://git@${githubBase}/${owner}/${repo}.git\";"
507+ , " inherit rev;"
508+ , " }"
509+ , " // (if branch == null then {} else { ref = branch; })"
510+ , " // (if name == null then {} else { inherit name; }));"
511+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
367512 ]
368513
369−plainGitStandaloneLoaderV1 :: Text
370−plainGitStandaloneLoaderV1 = T.unlines
371− [ $notImplemented
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)))"
372524 ]
373525
374−-- | Look for authentication info from the 'hub' command
375−getHubAuth
376− :: Text -- ^ Domain name
377− -> IO (Maybe Auth)
378−getHubAuth domain = do
379− hubConfig <- getXdgDirectory XdgConfig "hub"
380− Yaml.decodeFile hubConfig >>= \case
381− Nothing -> return Nothing
382− Just v -> return $ flip parseMaybe v $ \v' -> do
383− Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means
384− [Yaml.Object domainConfig] <- return $ toList domainConfigs
385− token <- domainConfig .: "oauth_token"
386− return $ OAuth $ encodeUtf8 token
387−
388−--TODO: when checking something out, make a shallow clone
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
562+ [ "# DO NOT HAND-EDIT THIS FILE"
563+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
564+ , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
565+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
566+ ]
567+
568+gitThunkSpecV2 :: ThunkSpec
569+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
570+ [ "# DO NOT HAND-EDIT THIS FILE"
571+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
572+ , " if builtins.hasAttr \"fetchGit\" builtins"
573+ , " then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"
574+ , " else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"
575+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
576+ ]
577+
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
389659
390660-- | Checks a cache directory to see if there is a fresh symlink
391661-- to the result of building an attribute of a thunk.
392662-- If no cache hit is found, nix-build is called to build the attribute
393663-- and the result is symlinked into the cache.
394−nixBuildThunkAttrWithCache :: FilePath
395− -- ^ Path to directory containing Thunk
396− -> String
397− -- ^ Attribute to build
398− -> IO FilePath
399− -- ^ Symlink to cached or built nix output
664+nixBuildThunkAttrWithCache
665+ :: MonadObelisk m
666+ => ThunkSpec
667+ -> FilePath
668+ -- ^ Path to directory containing Thunk
669+ -> String
670+ -- ^ Attribute to build
671+ -> m (Maybe FilePath)
672+ -- ^ Symlink to cached or built nix output
400673-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
401674-- the caching mechanism will fail as it merely measures the modification
402675-- time of the cache link and the expression to build.
403−nixBuildThunkAttrWithCache thunkDir attr = do
404− --NB: Expects thunkDir to be normalised with no trailing path separator.
405− --This should be guaranteed by the command argument parser.
406− let cacheErrHandler e
407− | isDoesNotExistError e = return Nothing -- expected from a cache miss
408− | otherwise = putError (T.pack $ displayException e) >> return Nothing
409− cacheDir = thunkDir </> ".attr-cache"
410− cachePath = cacheDir </> attr <.> "out"
411− createDirectoryIfMissing False cacheDir
412− latestChange <- maximum <$> mapM (getModificationTime . (thunkDir </>)) ["default.nix", "github.json"]
413− cacheHit <- handle cacheErrHandler $ do
414− cacheTime <- posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
415− return $ if latestChange <= cacheTime
416− then Just cachePath
417− else Nothing
418− case cacheHit of
419− Just c -> return c
420− Nothing -> do
421− putWarning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
422− _ <- nixBuild $ def
423− { _nixBuildConfig_target = Target
424− { _target_path = thunkDir
425− , _target_attr = Just attr
426− }
427− , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath
428− }
429− return cachePath
676+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
677+ 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+ }
430709
431710-- | Build a nix attribute, and cache the result if possible
432−nixBuildAttrWithCache :: FilePath
433− -- ^ Path to directory containing Thunk
434− -> String
435− -- ^ Attribute to build
436− -> IO FilePath
437− -- ^ Symlink to cached or built nix output
438−nixBuildAttrWithCache exprPath attr = do
439− readThunk exprPath >>= \case
440− -- Only packed thunks are cached. in particular, checkouts are not
441− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
442− _ -> nixBuild $ def
443− { _nixBuildConfig_target = Target
444− { _target_path = exprPath
711+nixBuildAttrWithCache
712+ :: MonadObelisk m
713+ => FilePath
714+ -- ^ Path to directory containing Thunk
715+ -> String
716+ -- ^ Attribute to build
717+ -> m FilePath
718+ -- ^ 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
445729 , _target_attr = Just attr
730+ , _target_expr = Nothing
446731 }
447− , _nixBuildConfig_outLink = OutLink_None
448− }
449732
450−unpackThunk :: FilePath
451− -> IO ()
452−unpackThunk thunkDir = readThunk thunkDir >>= \case
453− Left err -> putErrorAndExit $ "thunk unpack: " <> (T.pack $ show err)
733+-- | Safely update thunk using a custom action
734+--
735+-- A temporary working space is used to do any update. When the custom
736+-- action successfully completes, the resulting (packed) thunk is copied
737+-- back to the original location.
738+updateThunk :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
739+updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
740+ p' <- copyThunkToTmp tmpDir p
741+ unpackThunk' True p'
742+ result <- f p'
743+ updateThunkFromTmp p'
744+ return result
745+ where
746+ copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
747+ Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
748+ Right ThunkData_Packed{} -> do
749+ let tmpThunk = tmpDir </> "thunk"
750+ callProcessAndLogOutput (Notice, Error) $
751+ proc cp ["-r", "-T", thunkDir, tmpThunk]
752+ return tmpThunk
753+ Right _ -> failWith "Thunk is not packed"
754+ updateThunkFromTmp p' = do
755+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
756+ callProcessAndLogOutput (Notice, Error) $
757+ proc cp ["-r", "-T", p', p]
758+
759+finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
760+finalMsg noTrail s = if noTrail then Nothing else Just s
761+
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+
776+unpackThunk :: MonadObelisk m => FilePath -> m ()
777+unpackThunk = unpackThunk' False
778+
779+unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
780+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
781+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
454782 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
455− Right (ThunkData_Checkout _) -> putErrorAndExit "thunk unpack: thunk is already unpacked"
456− Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
457− ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
458− mauth <- getHubAuth "github.com"
459− repoResult <- executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
460− githubURI <- either throwIO (return . repoSshUrl) repoResult >>= \case
461− Nothing -> fail "Cannot determine clone URI for thunk source"
462− Just c -> return $ T.unpack $ getUrl c
463− withSpinner "Cloning from GitHub ..." (Just $ "Cloned " <> githubURI) $ do
464− callProcess "hub" --TODO: Depend on hub explicitly
465− [ "clone"
466− , "-n"
467− , githubURI
468− , tmpRepo
469− ]
470− let obGitDir = tmpRepo </> ".git" </> "obelisk"
471− --If this directory already exists then something is weird and we should fail
472− createDirectory obGitDir
473− withSpinner "Copying thunk ..." Nothing $ do
474− callProcess "cp"
475− [ "-r"
476− , "-T"
477− , thunkDir </> "."
478− , obGitDir </> "orig-thunk"
479− ]
480− let checkoutOptions = concat
481− [ ["-C", tmpRepo]
482− , pure "checkout"
483− , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)
484− , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr
485− ]
486− callProcess "hub" checkoutOptions
487− callProcess "rm"
488− [ "-r"
489− , thunkDir
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
784+ Right (ThunkData_Packed _ tptr) -> do
785+ 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+
822+--TODO: add a rollback mode to pack to the original thunk
823+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
824+packThunk = packThunk' False
825+
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
873+ 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."
490889 ]
491− callProcess "mv"
492− [ "-T"
493− , tmpRepo
494− , thunkDir
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
495944 ]
496− return ()
497− ThunkSource_Git _s -> do
498− $notImplemented
945+ let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
946+ behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
947+ pure (upstream, (ahead, behind))
499948
500−--TODO: add force mode to pack even if changes are present
501−--TODO: add a rollback mode to pack to the original thunk
502−packThunk :: FilePath
503− -> String
504− -> IO ()
505−packThunk thunkDir upstream = readThunk thunkDir >>= \case
506− Left err -> fail $ "thunk pack: " <> show err
507− Right (ThunkData_Packed _) -> putErrorAndExit "pack: thunk is already packed"
508− Right (ThunkData_Checkout _) -> do
509− thunkPtr <- getThunkPtr thunkDir upstream
510− callProcess "rm"
511− [ "-rf"
512− , thunkDir
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.)"
513962 ]
514− createThunk thunkDir thunkPtr
515− return ()
516−
517−getThunkPtr :: FilePath -> String -> IO ThunkPtr
518−getThunkPtr thunkDir upstream = do
519− checkGitCleanStatus thunkDir >>= \case
520− False -> do
521− statusDebug <- readProcess "hub"
522− [ "-C", thunkDir, "status", "--ignored" ] ""
523− fail $ unlines $
524− [ "thunk pack: thunk checkout contains unsaved modifications"
525− , "git status:"
526− ] ++ lines statusDebug
527− True -> return ()
528−
529− -- Check whether there are any stashes
530− stashOutput <- readProcess "hub" [ "-C", thunkDir, "stash", "list" ] ""
531− case null stashOutput of
532− False -> do
533− fail $ unlines $
534− [ "thunk pack: thunk checkout has stashes"
535− , "git stash list:"
536− ] ++ lines stashOutput
537− True -> return ()
538−
539− --Check whether all local heads are pushed
540− repoHeads <- lines <$> readProcess "hub"
541− [ "-C", thunkDir
542− , "for-each-ref", "--format=%(refname:short)", "refs/heads/"
543− ] ""
544− remotes <- lines <$> readProcess "hub" [ "-C", thunkDir, "remote" ] ""
545− --Check that the upstream specified actually exists
546− case L.find (== upstream) remotes of
547− Nothing -> fail $ "thunk pack: upstream " <> upstream <> " does not exist"
548− Just _ -> return ()
549− -- iterate over cartesian product
550− forM_ repoHeads $ \hd -> do
551− [localRev] <- lines <$> readProcess "hub" [ "-C", thunkDir, "rev-parse", hd ] ""
552− forM_ remotes $ \rm -> do
553− --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
554− [remoteMergeRev] <- lines <$> readProcess "hub"
555− [ "-C", thunkDir
556− , "merge-base"
557− , localRev
558− , "remotes/" <> rm <> "/" <> hd
559− ] ""
560− case remoteMergeRev == localRev of
561− False -> fail $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
562− True -> return ()
563−
564− --We assume it's safe to pack the thunk at this point
565− [remoteUri'] <- lines <$> readProcess "hub"
566− [ "-C", thunkDir
567− , "config", "--get", "remote." <> upstream <> ".url"
568− ] ""
569−
570− let uriParseFailure = "Could not identify git remote: " <> remoteUri'
571− mRemoteUri = parseURIReference remoteUri'
572− <|> parseSshShorthand remoteUri'
573− thunkPtr <- case mRemoteUri of
574− Nothing -> fail uriParseFailure
575− Just remoteUri -> do
576− refs <- fmap (refsToTuples . words) . lines <$> readProcess "hub"
577− [ "-C"
578− , thunkDir
579− , "show-ref"
580− , "--head" ] ""
581− -- safe because exactly one hash is associated with HEAD
582− let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
583− remoteHeads = Map.fromList $ catMaybes $ fmap
584− (\(x,y) -> (,) x <$> L.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
585− refs
586− localHeads = Map.fromList $ catMaybes $ fmap
587− (\(x,y) -> (,) x <$> L.stripPrefix "refs/heads/" y)
588− refs
589− currentUpstreamBranch = Map.lookup currentHead remoteHeads
590− <|> Map.lookup currentHead localHeads
591− if
592− | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch
593− | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch
594− return thunkPtr
595− where
596− refsToTuples [x, y] = (x, y)
597− refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
598− isGithubThunk u
599− | Just uriAuth <- uriAuthority u
600− = case uriScheme u of
601− "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""
602− s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"
603− && uriRegName uriAuth == "github.com"
604− | otherwise = False
605− githubThunkPtr u commit' branch' = do
606− ["/", owner', repo'] <- return $ splitDirectories (uriPath u)
607− let owner = N (T.pack owner')
608− repo = N (T.pack (dropExtension repo'))
609− commit = N (T.pack commit')
610− branch = N . T.pack <$> branch'
611− mauth <- getHubAuth "github.com"
612− repoResult <- executeRequestMaybe mauth $ repositoryR owner repo
613− repoIsPrivate <- either throwIO (return . repoPrivate) repoResult
614− archiveResult <- executeRequestMaybe mauth $
615− archiveForR owner repo ArchiveFormatTarball (Just (untagName commit))
616− archiveUri <- either throwIO return archiveResult
617− hash <- getNixSha256ForUriUnpacked archiveUri
618− return $ ThunkPtr
619− { _thunkPtr_rev = ThunkRev
620− { _thunkRev_commit = commitNameToRef commit
621− , _thunkRev_nixSha256 = hash
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
6221033 }
623− , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
624− { _gitHubSource_owner = owner
625− , _gitHubSource_repo = repo
626− , _gitHubSource_branch = branch
627− , _gitHubSource_private = repoIsPrivate
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
6281046 }
1047+
1048+ | otherwise = \mbranch -> do
1049+ isPrivate <- getIsPrivate
1050+ pure $ ThunkSource_Git $ GitSource
1051+ { _gitSource_url = GitUri u
1052+ , _gitSource_branch = N <$> mbranch
1053+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
1054+ , _gitSource_private = isPrivate
1055+ }
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
6291083 }
630− gitThunkPtr u _commit' _branch' = do
631− case uriScheme u of
632− "https:" -> return ()
633− "git:" -> return ()
634− _ -> fail $ "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"
635− $notImplemented
636− parseSshShorthand uri' = do
637− -- This is what git does to check that the remote
638− -- is not a local file path when parsing shorthand.
639− -- Last referenced from here:
640− -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
641− let uri = T.pack uri'
642− (authAndHostname, colonAndPath) = T.break (== ':') uri
643− properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
644− -- Shorthand is valid iff a colon is present and it occurs before the first slash
645− -- This check is used to disambiguate a filepath containing a colon from shorthand
646− guard $ isNothing (T.findIndex (=='/') authAndHostname)
647− && not (T.null colonAndPath)
648− parseURI $ T.unpack properUri
1084+
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
1177+
1178+parseSshShorthand :: Text -> Maybe URI.URI
1179+parseSshShorthand uri = do
1180+ -- This is what git does to check that the remote
1181+ -- is not a local file path when parsing shorthand.
1182+ -- Last referenced from here:
1183+ -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
1184+ let
1185+ (authAndHostname, colonAndPath) = T.break (== ':') uri
1186+ properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
1187+ -- Shorthand is valid iff a colon is present and it occurs before the first slash
1188+ -- This check is used to disambiguate a filepath containing a colon from shorthand
1189+ guard $ isNothing (T.findIndex (=='/') authAndHostname)
1190+ && not (T.null colonAndPath)
1191+ URI.mkURI properUri