@@ -1,77 +1,74 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiWayIf #-}
5{-# LANGUAGE MultiWayIf #-}
4{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE PatternGuards #-}
6−{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE QuasiQuotes #-}
7−
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
8−module Obelisk.Command.Thunk
11+module Obelisk.Command.Thunk where
15− , updateThunkToLatest
17− , createThunkWithLatest
18− , nixBuildAttrWithCache
19− , nixBuildThunkAttrWithCache
26import Control.Applicative
13import Control.Applicative
27−import Control.Exception
14+import Control.Exception (displayException, try)
15+import Control.Lens (ifor, ifor_, (.~))
28import Control.Monad
16import Control.Monad
17+import Control.Monad.Extra (findM)
18+import Control.Monad.Catch (MonadCatch, handle)
29import Control.Monad.Except
19import Control.Monad.Except
30−import Data.Aeson as Aeson
20+import Data.Aeson ((.=))
21+import qualified Data.Aeson as Aeson
31import Data.Aeson.Encode.Pretty
22import Data.Aeson.Encode.Pretty
23+import qualified Data.Aeson.Types as Aeson
24+import Data.Bifunctor (first)
32import qualified Data.ByteString.Lazy as LBS
25import qualified Data.ByteString.Lazy as LBS
26+import Data.Containers.ListUtils (nubOrd)
33import Data.Default
27import 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 ((<&>))
35import Data.Git.Ref (Ref)
32import Data.Git.Ref (Ref)
36import qualified Data.Git.Ref as Ref
33import qualified Data.Git.Ref as Ref
37import qualified Data.List as L
34import qualified Data.List as L
38−import Data.List.NonEmpty (NonEmpty (..))
35+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
39import qualified Data.List.NonEmpty as NonEmpty
36import qualified Data.List.NonEmpty as NonEmpty
40import qualified Data.Map as Map
38import qualified Data.Map as Map
41import Data.Maybe
39import Data.Maybe
43import Data.Set (Set)
40import Data.Set (Set)
44import qualified Data.Set as Set
41import qualified Data.Set as Set
42+import Data.String.Here.Interpolated (i)
43+import Data.String.Here.Uninterpolated (here)
45import Data.Text (Text)
44import Data.Text (Text)
46import qualified Data.Text as T
45import qualified Data.Text as T
47import Data.Text.Encoding
46import Data.Text.Encoding
48import qualified Data.Text.IO as T
47import qualified Data.Text.IO as T
49import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
48import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
50−import Data.Yaml (parseMaybe, (.:))
49+import Data.Traversable (for)
51−import qualified Data.Yaml as Yaml
50+import Data.Yaml (parseMaybe)
52import GitHub
51import GitHub
53import GitHub.Data.Name
52import GitHub.Data.Name
54−import GitHub.Endpoints.Repos.Contents (archiveForR)
56import Obelisk.Command.Nix
53import Obelisk.Command.Nix
57import System.Directory
54import System.Directory
58import System.Exit
55import System.Exit
59import System.FilePath
56import System.FilePath
61import System.IO.Error
57import System.IO.Error
62import System.IO.Temp
58import System.IO.Temp
63−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
64−import System.Process
60+import qualified Text.URI as URI
66−import Development.Placeholders
62+import Obelisk.App (MonadObelisk)
64+import Obelisk.Command.Utils
68--TODO: Support symlinked thunk data
66--TODO: Support symlinked thunk data
69data ThunkData
67data ThunkData
70− = ThunkData_Packed ThunkPtr
68+ = ThunkData_Packed ThunkSpec ThunkPtr
71 -- ^ Packed thunk
69 -- ^ Packed thunk
72− | ThunkData_Checkout (Maybe ThunkPtr)
70+ | ThunkData_Checkout
73 -- ^ Checked out thunk that was unpacked from this pointer
71 -- ^ Checked out thunk that was unpacked from this pointer
74− deriving (Show, Eq, Ord)
76-- | A reference to the exact data that a thunk should translate into
73-- | A reference to the exact data that a thunk should translate into
77data ThunkPtr = ThunkPtr
74data ThunkPtr = ThunkPtr
@@ -84,7 +81,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
85-- | A specific revision of data; it may be available from multiple sources
82-- | A specific revision of data; it may be available from multiple sources
86data ThunkRev = ThunkRev
83data ThunkRev = ThunkRev
87− { _thunkRev_commit :: Ref
84+ { _thunkRev_commit :: Ref Ref.SHA1
88 , _thunkRev_nixSha256 :: NixSha256
85 , _thunkRev_nixSha256 :: NixSha256
90 deriving (Show, Eq, Ord)
87 deriving (Show, Eq, Ord)
@@ -97,6 +94,11 @@ data ThunkSource
97 | ThunkSource_Git GitSource
94 | ThunkSource_Git GitSource
98 deriving (Show, Eq, Ord)
95 deriving (Show, Eq, Ord)
97+thunkSourceToGitSource :: ThunkSource -> GitSource
98+thunkSourceToGitSource = \case
99+ ThunkSource_GitHub s -> forgetGithub False s
100+ ThunkSource_Git s -> s
100data GitHubSource = GitHubSource
102data GitHubSource = GitHubSource
101 { _gitHubSource_owner :: Name Owner
103 { _gitHubSource_owner :: Name Owner
102 , _gitHubSource_repo :: Name Repo
104 , _gitHubSource_repo :: Name Repo
@@ -105,157 +107,263 @@ data GitHubSource = GitHubSource
106 deriving (Show, Eq, Ord)
108 deriving (Show, Eq, Ord)
110+newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
112+gitUriToText :: GitUri -> Text
113+gitUriToText (GitUri uri)
114+ | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"
115+ , Just (_, path) <- URI.uriPath uri
116+ = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)
117+ | otherwise = URI.render uri
108data GitSource = GitSource
119data GitSource = GitSource
109− { _gitSource_url :: URI
120+ { _gitSource_url :: GitUri
110− --TODO: Is it ok to use the types from the GitHub api bindings?
111 , _gitSource_branch :: Maybe (Name Branch)
121 , _gitSource_branch :: Maybe (Name Branch)
112 , _gitSource_fetchSubmodules :: Bool
122 , _gitSource_fetchSubmodules :: Bool
123+ , _gitSource_private :: Bool
114 deriving (Show, Eq, Ord)
125 deriving (Show, Eq, Ord)
116−commitNameToRef :: Name Commit -> Ref
127+newtype ThunkConfig = ThunkConfig
117−commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
128+ { _thunkConfig_private :: Maybe Bool
119−getNixSha256ForUriUnpacked :: URI -> IO NixSha256
131+data ThunkUpdateConfig = ThunkUpdateConfig
120−getNixSha256ForUriUnpacked uri = do
132+ { _thunkUpdateConfig_branch :: Maybe String
121− --TODO: Make this package depend on nix-prefetch-url properly
133+ , _thunkUpdateConfig_config :: ThunkConfig
122− let cmd = proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
134+ } deriving Show
123− (_, Just out, Just err, p) <- createProcess cmd
135+
124− { std_out = CreatePipe
136+data ThunkPackConfig = ThunkPackConfig
125− , std_err = CreatePipe
137+ { _thunkPackConfig_force :: Bool
138+ , _thunkPackConfig_config :: ThunkConfig
141+-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
142+forgetGithub :: Bool -> GitHubSource -> GitSource
143+forgetGithub useSsh s = GitSource
144+ { _gitSource_url = GitUri $ URI.URI
145+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"
146+ , URI.uriAuthority = Right $ URI.Authority
147+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
149+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
150+ , URI.authPort = Nothing
152+ , URI.uriPath = Just ( False
153+ , fromRight' . URI.mkPathPiece <$>
154+ untagName (_gitHubSource_owner s)
155+ :| [ untagName (_gitHubSource_repo s) <> ".git" ]
158+ , URI.uriFragment = Nothing
127− --TODO: Deal with errors here; usually they're HTTP errors
160+ , _gitSource_branch = _gitHubSource_branch s
128− waitForProcess p >>= \case
161+ , _gitSource_fetchSubmodules = False
129− ExitSuccess -> return ()
162+ , _gitSource_private = _gitHubSource_private s
131− hPutStrLn stdout =<< hGetContents out
132− hPutStrLn stderr =<< hGetContents err
133− --TODO: actual error
134− fail $ "nix-prefetch-url"
135− T.strip <$> T.hGetContents out
137−-- | Get the latest revision available from the given source
165+getThunkGitBranch :: ThunkPtr -> Maybe Text
138−getLatestRev :: ThunkSource -> IO ThunkRev
166+getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
140− ThunkSource_GitHub s -> do
167+ ThunkSource_GitHub s -> _gitHubSource_branch s
141− auth <- getHubAuth "github.com"
168+ ThunkSource_Git s -> _gitSource_branch s
142− commitsResult <- executeRequestMaybe auth $ commitsWithOptionsForR
169+
143− (_gitHubSource_owner s)
170+commitNameToRef :: Name Commit -> Ref Ref.SHA1
144− (_gitHubSource_repo s)
171+commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
145− (FetchAtLeast 1)
172+
146− $ case _gitHubSource_branch s of
173+-- TODO: Use spinner here.
147− Nothing -> []
174+getNixSha256ForUriUnpacked
148− Just b -> [CommitQuerySha $ untagName b]
175+ :: MonadObelisk m
149− commitInfos <- either throwIO return commitsResult
176+ => GitUri
150− commitInfo : _ <- return $ toList commitInfos
177+ -> m NixSha256
151− let commit = commitSha commitInfo
178+getNixSha256ForUriUnpacked uri =
152− Right archiveUri <- executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit
179+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
153− nixSha256 <- getNixSha256ForUriUnpacked archiveUri
180+ [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
154− return $ ThunkRev
181+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
155− { _thunkRev_commit = commitNameToRef commit
182+ pure hash
156− , _thunkRev_nixSha256 = nixSha256
183+
157− }
184+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
158− ThunkSource_Git _s -> do
185+nixPrefetchGit uri rev fetchSubmodules =
159− $notImplemented
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 ""
195+ case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of
196+ Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
161--TODO: Pretty print these
199--TODO: Pretty print these
162data ReadThunkError
200data ReadThunkError
163− = ReadThunkError_WrongContents (Set String) (Set String)
201+ = ReadThunkError_UnrecognizedThunk
164− | ReadThunkError_UnrecognizedLoader Text
202+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
165− | ReadThunkError_UnparseablePtr LBS.ByteString
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
166− deriving (Show)
209+ deriving (Show)
168−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
211+unpackedDirName :: FilePath
169−-- If the thunk is packed and additional data is present, fail.
212+unpackedDirName = "."
214+attrCacheFileName :: FilePath
215+attrCacheFileName = ".attr-cache"
217+-- | Specification for how a file in a thunk version works.
219+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
220+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
221+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
222+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
224+-- | Specification for how a set of files in a thunk version work.
225+data ThunkSpec = ThunkSpec
226+ { _thunkSpec_name :: !Text
227+ , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
230+thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
231+thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
233+-- | Attempts to match a 'ThunkSpec' to a given directory.
235+ :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
236+ => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
237+ -> FilePath -- ^ Path to directory
238+ -> Set FilePath -- ^ Set of file paths relative to the given directory
240+matchThunkSpecToDir thunkSpec dir dirFiles = do
241+ case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
242+ Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
244+ case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
245+ Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
247+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
248+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
249+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
251+ True -> Just ThunkData_Checkout
252+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
253+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)
254+ case T.strip expectedContents == T.strip actualContents of
255+ True -> pure Nothing
256+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
257+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
258+ let path = dir </> expectedPath
259+ liftIO (doesFileExist path) >>= \case
260+ False -> pure Nothing
262+ actualContents <- liftIO $ LBS.readFile path
263+ case parser actualContents of
264+ Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
265+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
267+ case nonEmpty datas of
268+ Nothing -> throwError ReadThunkError_UnrecognizedThunk
269+ Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
271+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
274+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
276+ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
277+ isRequiredFileSpec = \case
278+ ThunkFileSpec_FileMatches _ -> True
281+ dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
282+ True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
285+ -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
286+ mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout
287+ mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked
288+ mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked
289+ mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) =
290+ if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB
292+ bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
294+ fold1WithM (x :| xs) f = foldM f x xs
170−readThunk :: FilePath -> IO (Either ReadThunkError ThunkData)
298+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
171−readThunk thunkDir = do
299+readThunkWith specTypes dir = do
172− files <- listDirectory thunkDir
300+ dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
173− case ".git" `elem` files of
301+ let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
174− True -> fmap ThunkData_Checkout <$> do
302+ flip fix specs $ \loop -> \case
175− let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
303+ [] -> pure $ Left ReadThunkError_UnrecognizedThunk
176− doesDirectoryExist origThunkPath >>= \case
304+ spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
177− True -> fmap Just <$> readPackedThunk origThunkPath
305+ Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
178− False -> return $ return Nothing
306+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
179− False -> fmap ThunkData_Packed <$> readPackedThunk thunkDir
181-- | Read a thunk and validate that it is exactly a packed thunk.
308-- | Read a thunk and validate that it is exactly a packed thunk.
182-- If additional data is present, fail.
309-- If additional data is present, fail.
183−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
184−readPackedThunk thunkDir = runExceptT $ do
311+readThunk = readThunkWith thunkSpecTypes
185− let thunkLoader = thunkDir </> "default.nix"
186− githubJson = thunkDir </> "github.json"
187− attrCache = thunkDir </> ".attr-cache"
188− expectedContents = Set.fromList $
192− optionalContents = Set.fromList $
196− -- Ensure that there aren't any other files in the thunk
313+parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
197− -- NB: System.Directory.listDirectory returns the contents without the directory path
314+parseThunkPtr parseSrc v = do
198− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
199− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
200− missingContents = expectedContents `Set.difference` files
201− unless (Set.null unexpectedContents && Set.null missingContents) $ do
202− throwError $ ReadThunkError_WrongContents unexpectedContents missingContents
204− -- Ensure that we recognize the thunk loader
205− loader <- liftIO $ T.readFile thunkLoader
206− unless (loader `elem` gitHubStandaloneLoaders) $ do
207− throwError $ ReadThunkError_UnrecognizedLoader loader
209− txt <- liftIO $ LBS.readFile githubJson
210− let parseThunk v = do
211− rev <- v Aeson..: "rev"
315+ rev <- v Aeson..: "rev"
212− sha256 <- v Aeson..: "sha256"
316+ sha256 <- v Aeson..: "sha256"
213− src <- parseGitHubSource v
317+ src <- parseSrc v
214− <|> parseGitSource v
215− return $ ThunkPtr
318+ pure $ ThunkPtr
216− { _thunkPtr_rev = ThunkRev
319+ { _thunkPtr_rev = ThunkRev
217− { _thunkRev_commit = Ref.fromHexString rev
320+ { _thunkRev_commit = Ref.fromHexString rev
218− , _thunkRev_nixSha256 = sha256
321+ , _thunkRev_nixSha256 = sha256
220− , _thunkPtr_source = src
323+ , _thunkPtr_source = src
222− parseGitHubSource v = do
326+parseGitHubSource :: Aeson.Object -> Aeson.Parser GitHubSource
327+parseGitHubSource v = do
223− owner <- v Aeson..: "owner"
328+ owner <- v Aeson..: "owner"
224− repo <- v Aeson..: "repo"
329+ repo <- v Aeson..: "repo"
225− branch <- v Aeson..:! "branch"
330+ branch <- v Aeson..:! "branch"
226− mPrivate <- v Aeson..:! "private"
331+ private <- v Aeson..:? "private"
227− return $ ThunkSource_GitHub $ GitHubSource
332+ pure $ GitHubSource
228− { _gitHubSource_owner = owner
333+ { _gitHubSource_owner = owner
229− , _gitHubSource_repo = repo
334+ , _gitHubSource_repo = repo
230− , _gitHubSource_branch = branch
335+ , _gitHubSource_branch = branch
231− , _gitHubSource_private = fromMaybe False mPrivate
336+ , _gitHubSource_private = fromMaybe False private
233− parseGitSource v = do
339+parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
340+parseGitSource v = do
234− Just url <- parseURI <$> v Aeson..: "url"
341+ Just url <- parseGitUri <$> v Aeson..: "url"
235− branch <- v Aeson..:! "branch"
342+ branch <- v Aeson..:! "branch"
236− fetchSubmodules <- v Aeson..: "fetchSubmodules"
343+ fetchSubmodules <- v Aeson..:! "fetchSubmodules"
344+ private <- v Aeson..:? "private"
237− return $ ThunkSource_Git $ GitSource
345+ pure $ GitSource
238− { _gitSource_url = url
346+ { _gitSource_url = url
239− , _gitSource_branch = branch
347+ , _gitSource_branch = branch
240− , _gitSource_fetchSubmodules = fetchSubmodules
348+ , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
241− }
349+ , _gitSource_private = fromMaybe False private
242− case parseMaybe parseThunk =<< decode txt of
350+ }
243− Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
244− Just ptr -> return ptr
246−overwriteThunk :: FilePath -> ThunkPtr -> IO ()
352+overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
247overwriteThunk target thunk = do
353overwriteThunk target thunk = do
248 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
354 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
249− Right _ <- readThunk target
355+ readThunk target >>= \case
356+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
251 --TODO: Is there a safer way to do this overwriting?
359 --TODO: Is there a safer way to do this overwriting?
252− removeDirectoryRecursive target
360+ liftIO $ removePathForcibly target
253− createThunk target thunk
361+ createThunk target $ Right thunk
255−thunkPtrLoader :: ThunkPtr -> Text
363+thunkPtrToSpec :: ThunkPtr -> ThunkSpec
256−thunkPtrLoader thunk = case _thunkPtr_source thunk of
364+thunkPtrToSpec thunk = case _thunkPtr_source thunk of
257− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
365+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
258− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
366+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
260-- It's important that formatting be very consistent here, because
368-- It's important that formatting be very consistent here, because
261-- otherwise when people update thunks, their patches will be messy
369-- otherwise when people update thunks, their patches will be messy
@@ -264,21 +372,18 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
264 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
372 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
265 [ Just $ "owner" .= _gitHubSource_owner s
373 [ Just $ "owner" .= _gitHubSource_owner s
266 , Just $ "repo" .= _gitHubSource_repo s
374 , Just $ "repo" .= _gitHubSource_repo s
267− , case _gitHubSource_branch s of
375+ , ("branch" .=) <$> _gitHubSource_branch s
268− Just b -> Just $ "branch" .= b
270− , if _gitHubSource_private s
271− then Just $ "private" .= True
273 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
376 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
274 , Just $ "sha256" .= _thunkRev_nixSha256 rev
377 , Just $ "sha256" .= _thunkRev_nixSha256 rev
378+ , Just $ "private" .= _gitHubSource_private s
276 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
380 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
277− --TODO: Is this safe? read/show is jank for `URI`
278− [ Just $ "url" .= show (_gitSource_url s)
381+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
279 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
382 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
383+ , ("branch" .=) <$> _gitSource_branch s
280 , Just $ "sha256" .= _thunkRev_nixSha256 rev
384 , Just $ "sha256" .= _thunkRev_nixSha256 rev
281 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
385 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
386+ , Just $ "private" .= _gitSource_private s
284 githubCfg = defConfig
389 githubCfg = defConfig
@@ -299,54 +404,84 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
301 , "sha256"
406 , "sha256"
302 , "fetchSubmodules"
408 , "fetchSubmodules"
303 ] <> compare
409 ] <> compare
304 , confTrailingNewline = True
410 , confTrailingNewline = True
307−createThunk :: FilePath -> ThunkPtr -> IO ()
413+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
308−createThunk target thunk = do
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)
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
309− createDirectoryIfMissing True (target </> ".attr-cache")
426+ liftIO $ createDirectoryIfMissing True $ takeDirectory fullPath
310− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
427+ f fullPath
311− LBS.writeFile (target </> "github.json") (encodeThunkPtrData thunk)
313−createThunkWithLatest :: FilePath -> ThunkSource -> IO ()
429+createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
314createThunkWithLatest target s = do
430createThunkWithLatest target s = do
315 rev <- getLatestRev s
431 rev <- getLatestRev s
316− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
317 { _thunkPtr_source = s
433 { _thunkPtr_source = s
318 , _thunkPtr_rev = rev
434 , _thunkPtr_rev = rev
321−updateThunkToLatest :: FilePath -> IO ()
437+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
322−updateThunkToLatest target = do
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
323− (overwrite, ptr) <- readThunk target >>= \case
443+ (overwrite, ptr) <- readThunk target >>= \case
324− Left err -> fail $ "thunk update: " <> show err
444+ Left err -> failWith [i|Thunk update: ${err}|]
325− Right c -> return $ case c of
445+ Right c -> case c of
326− ThunkData_Packed t -> (target, t)
446+ ThunkData_Packed _ t -> return (target, t)
327− ThunkData_Checkout _ -> fail "cannot update an unpacked thunk"
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
328− let src = _thunkPtr_source ptr
448+ let src = _thunkPtr_source ptr
329− rev <- getLatestRev src
449+ rev <- getLatestRev src
330− overwriteThunk overwrite $ ThunkPtr
450+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
331− { _thunkPtr_source = src
451+ { _thunkPtr_source = src
332− , _thunkPtr_rev = rev
452+ , _thunkPtr_rev = rev
454+ Just branch -> readThunk target >>= \case
455+ Left err -> failWith [i|Thunk update: ${err}|]
456+ Right c -> case c of
457+ ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
458+ ThunkData_Checkout -> failWith [i|Thunk located at ${target} is unpacked. Use 'ob thunk pack' on the desired directory and then try 'ob thunk update' again.|]
460+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
462+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
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
335-- | All recognized github standalone loaders, ordered from newest to oldest.
468-- | All recognized github standalone loaders, ordered from newest to oldest.
336-- This tool will only ever produce the newest one when it writes a thunk.
469-- This tool will only ever produce the newest one when it writes a thunk.
337−gitHubStandaloneLoaders :: NonEmpty Text
470+gitHubThunkSpecs :: NonEmpty ThunkSpec
338−gitHubStandaloneLoaders =
471+gitHubThunkSpecs =
339− gitHubStandaloneLoaderV2 :|
472+ gitHubThunkSpecV5 :|
340− [ gitHubStandaloneLoaderV1
473+ [ gitHubThunkSpecV4
343−gitHubStandaloneLoaderV1 :: Text
479+gitHubThunkSpecV1 :: ThunkSpec
344−gitHubStandaloneLoaderV1 = T.unlines
480+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
345− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
481+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
348−gitHubStandaloneLoaderV2 :: Text
483+gitHubThunkSpecV2 :: ThunkSpec
349−gitHubStandaloneLoaderV2 = T.unlines
484+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
350 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
485 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
351 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
352 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -356,292 +491,701 @@ gitHubStandaloneLoaderV2 = T.unlines
359−plainGitStandaloneLoaders :: NonEmpty Text
494+gitHubThunkSpecV3 :: ThunkSpec
360−plainGitStandaloneLoaders =
495+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
361− plainGitStandaloneLoaderV1 :|
496+ [ "# DO NOT HAND-EDIT THIS FILE"
498+ , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
499+ , " then fetchFromGitHubPrivate args"
500+ , " else (import <nixpkgs> {}).fetchFromGitHub (builtins.removeAttrs args [\"branch\"]);"
501+ , " fetchFromGitHubPrivate ="
502+ , " { owner, repo, rev, branch ? null, name ? null, sha256 ? null, private ? false"
503+ , " , fetchSubmodules ? false, githubBase ? \"github.com\", ..."
504+ , " }: assert !fetchSubmodules;"
505+ , " builtins.fetchGit ({"
506+ , " url = \"ssh://git@${githubBase}/${owner}/${repo}.git\";"
509+ , " // (if branch == null then {} else { ref = branch; })"
510+ , " // (if name == null then {} else { inherit name; }));"
511+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
365−plainGitStandaloneLoaderV1 :: Text
514+gitHubThunkSpecV4 :: ThunkSpec
366−plainGitStandaloneLoaderV1 = T.unlines
515+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
367− [ $notImplemented
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;"
523+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
370−-- | Look for authentication info from the 'hub' command
526+legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
371−getHubAuth
527+legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
372− :: Text -- ^ Domain name
528+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
373− -> IO (Maybe Auth)
529+ , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
374−getHubAuth domain = do
530+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
375− hubConfig <- getXdgDirectory XdgConfig "hub"
531+ , (".git", ThunkFileSpec_CheckoutIndicator)
376− Yaml.decodeFile hubConfig >>= \case
532+ ]
377− Nothing -> return Nothing
533+
378− Just v -> return $ flip parseMaybe v $ \v' -> do
534+gitHubThunkSpecV5 :: ThunkSpec
379− Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means
535+gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|
380− [Yaml.Object domainConfig] <- return $ toList domainConfigs
536+# DO NOT HAND-EDIT THIS FILE
381− token <- domainConfig .: "oauth_token"
537+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
382− return $ OAuth $ encodeUtf8 token
538+ if !fetchSubmodules && !private then builtins.fetchTarball {
383−
539+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
384−--TODO: when checking something out, make a shallow clone
540+ } else (import <nixpkgs> {}).fetchFromGitHub {
541+ inherit owner repo rev sha256 fetchSubmodules private;
543+ json = builtins.fromJSON (builtins.readFile ./github.json);
547+parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
548+parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->
549+ ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
551+gitThunkSpecs :: NonEmpty ThunkSpec
560+gitThunkSpecV1 :: ThunkSpec
561+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
562+ [ "# DO NOT HAND-EDIT THIS FILE"
563+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
564+ , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
565+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
568+gitThunkSpecV2 :: ThunkSpec
569+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
570+ [ "# DO NOT HAND-EDIT THIS FILE"
571+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
572+ , " if builtins.hasAttr \"fetchGit\" builtins"
573+ , " then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"
574+ , " else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"
575+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
578+-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
579+-- and will fail to find commits without this because it does shallow clones.
580+gitThunkSpecV3 :: ThunkSpec
581+gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
582+ [ "# DO NOT HAND-EDIT THIS FILE"
583+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
584+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
585+ , " if firstChar == \"/\" then /. + url"
586+ , " else if firstChar == \".\" then ./. + url"
588+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
589+ , " url = realUrl; inherit rev;"
590+ , " } else (import <nixpkgs> {}).fetchgit {"
591+ , " url = realUrl; inherit rev sha256;"
593+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
596+gitThunkSpecV4 :: ThunkSpec
597+gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines
598+ [ "# DO NOT HAND-EDIT THIS FILE"
599+ , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
600+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
601+ , " if firstChar == \"/\" then /. + url"
602+ , " else if firstChar == \".\" then ./. + url"
604+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
605+ , " url = realUrl; inherit rev;"
606+ , " ${if branch == null then null else \"ref\"} = branch;"
607+ , " } else (import <nixpkgs> {}).fetchgit {"
608+ , " url = realUrl; inherit rev sha256;"
610+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
613+legacyGitThunkSpec :: Text -> Text -> ThunkSpec
614+legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList
615+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
616+ , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
617+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
618+ , (".git", ThunkFileSpec_CheckoutIndicator)
621+gitThunkSpecV5 :: ThunkSpec
622+gitThunkSpecV5 = mkThunkSpec "git-v5" "git.json" parseGitJsonBytes [here|
623+# DO NOT HAND-EDIT THIS FILE
624+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
625+ let realUrl = let firstChar = builtins.substring 0 1 url; in
626+ if firstChar == "/" then /. + url
627+ else if firstChar == "." then ./. + url
629+ in if !fetchSubmodules && private then builtins.fetchGit {
630+ url = realUrl; inherit rev;
631+ ${if branch == null then null else "ref"} = branch;
632+ } else (import <nixpkgs> {}).fetchgit {
633+ url = realUrl; inherit rev sha256;
635+ json = builtins.fromJSON (builtins.readFile ./git.json);
639+parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
640+parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
642+mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
643+mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
644+ [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
645+ , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)
646+ , (jsonFileName, ThunkFileSpec_Ptr parser)
647+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
648+ , (normalise $ unpackedDirName </> ".git", ThunkFileSpec_CheckoutIndicator)
651+ defaultNixViaSrc = [here|
652+# DO NOT HAND-EDIT THIS FILE
653+import (import ./thunk.nix)
657+parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
658+parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
386-- | Checks a cache directory to see if there is a fresh symlink
660-- | Checks a cache directory to see if there is a fresh symlink
387-- to the result of building an attribute of a thunk.
661-- to the result of building an attribute of a thunk.
388-- If no cache hit is found, nix-build is called to build the attribute
662-- If no cache hit is found, nix-build is called to build the attribute
389-- and the result is symlinked into the cache.
663-- and the result is symlinked into the cache.
390−nixBuildThunkAttrWithCache :: FilePath
664+nixBuildThunkAttrWithCache
391− -- ^ Path to directory containing Thunk
668+ -- ^ Path to directory containing Thunk
392− -> String
669+ -> String
393− -- ^ Attribute to build
670+ -- ^ Attribute to build
394− -> IO FilePath
671+ -> m (Maybe FilePath)
395− -- ^ Symlink to cached or built nix output
672+ -- ^ Symlink to cached or built nix output
396-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
673-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
397-- the caching mechanism will fail as it merely measures the modification
674-- the caching mechanism will fail as it merely measures the modification
398-- time of the cache link and the expression to build.
675-- time of the cache link and the expression to build.
399−nixBuildThunkAttrWithCache thunkDir attr = do
676+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
400− --NB: Expects thunkDir to be normalised with no trailing path separator.
677+ latestChange <- liftIO $ do
401− --This should be guaranteed by the command argument parser.
678+ let
679+ getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
680+ thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
681+ maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
683+ let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
684+ _thunkSpec_files thunkSpec
685+ for cachePaths' $ \cachePaths ->
686+ fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
688+ cachePath = thunkDir </> cacheDir </> attr <.> "out"
402− let cacheErrHandler e
689+ cacheErrHandler e
403− | isDoesNotExistError e = return Nothing -- expected from a cache miss
690+ | isDoesNotExistError e = pure Nothing -- expected from a cache miss
404− | otherwise = hPutStrLn stderr (displayException e) >> return Nothing
691+ | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
405− cacheDir = thunkDir </> ".attr-cache"
406− cachePath = cacheDir </> attr <.> "out"
407− createDirectoryIfMissing False cacheDir
408− latestChange <- maximum <$> mapM (getModificationTime . (thunkDir </>)) ["default.nix", "github.json"]
409− cacheHit <- handle cacheErrHandler $ do
692+ cacheHit <- handle cacheErrHandler $ do
410− cacheTime <- posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
693+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
411− return $ if latestChange <= cacheTime
694+ pure $ if latestChange <= cacheTime
412− then Just cachePath
695+ then Just cachePath
413− else Nothing
696+ else Nothing
414− case cacheHit of
697+ case cacheHit of
415− Just c -> return c
698+ Just c -> pure c
416− Nothing -> do
699+ Nothing -> do
417− hPutStrLn stderr (mconcat [thunkDir, ": ", attr, " not cached, building ..."])
700+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
418− _ <- nixBuild $ def
701+ liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
419− { _nixBuildConfig_target = Target
702+ (cachePath <$) $ nixCmd $ NixCmd_Build $ def
703+ & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath
704+ & nixCmdConfig_target .~ Target
420− { _target_path = thunkDir
705+ { _target_path = Just thunkDir
421− , _target_attr = Just attr
706+ , _target_attr = Just attr
422− }
707+ , _target_expr = Nothing
423− , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath
427-- | Build a nix attribute, and cache the result if possible
710-- | Build a nix attribute, and cache the result if possible
428−nixBuildAttrWithCache :: FilePath
711+nixBuildAttrWithCache
429− -- ^ Path to directory containing Thunk
714+ -- ^ Path to directory containing Thunk
430− -> String
715+ -> String
431− -- ^ Attribute to build
716+ -- ^ Attribute to build
432− -> IO FilePath
717+ -> m FilePath
433− -- ^ Symlink to cached or built nix output
718+ -- ^ Symlink to cached or built nix output
434−nixBuildAttrWithCache exprPath attr = do
719+nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
435− readThunk exprPath >>= \case
436− -- Only packed thunks are cached. in particular, checkouts are not
720+ -- Only packed thunks are cached. In particular, checkouts are not.
721+ Right (ThunkData_Packed spec _) ->
437− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
722+ maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
438− _ -> nixBuild $ def
723+ _ -> build
439− { _nixBuildConfig_target = Target
724+ where
725+ build = nixCmd $ NixCmd_Build $ def
726+ & nixBuildConfig_outLink .~ OutLink_None
727+ & nixCmdConfig_target .~ Target
440− { _target_path = exprPath
728+ { _target_path = Just exprPath
441 , _target_attr = Just attr
729 , _target_attr = Just attr
730+ , _target_expr = Nothing
443− , _nixBuildConfig_outLink = OutLink_None
446−unpackThunk :: FilePath
733+-- | Safely update thunk using a custom action
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'
743+ updateThunkFromTmp p'
448−unpackThunk thunkDir = readThunk thunkDir >>= \case
746+ copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
449− Left err -> fail $ "thunk unpack: " <> show err
747+ Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
748+ Right ThunkData_Packed{} -> do
749+ let tmpThunk = tmpDir </> "thunk"
750+ callProcessAndLogOutput (Notice, Error) $
751+ proc cp ["-r", "-T", thunkDir, tmpThunk]
753+ Right _ -> failWith "Thunk is not packed"
754+ updateThunkFromTmp p' = do
755+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
756+ callProcessAndLogOutput (Notice, Error) $
757+ proc cp ["-r", "-T", p', p]
759+finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
760+finalMsg noTrail s = if noTrail then Nothing else Just s
762+-- | Check that we are not somewhere inside the thunk directory
763+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764+checkThunkDirectory thunkDir = do
765+ currentDir <- liftIO getCurrentDirectory
766+ thunkDir' <- liftIO $ canonicalizePath thunkDir
767+ when (thunkDir' `L.isInfixOf` currentDir) $
768+ failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
770+ -- Don't let thunk commands work when directly given an unpacked repo
771+ when (takeFileName thunkDir == unpackedDirName) $
772+ readThunk (takeDirectory thunkDir) >>= \case
773+ Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
776+unpackThunk :: MonadObelisk m => FilePath -> m ()
777+unpackThunk = unpackThunk' False
779+unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
780+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
781+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
450 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
782 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
451− Right (ThunkData_Checkout _) -> fail "thunk unpack: thunk is already unpacked"
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
452− Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
784+ Right (ThunkData_Packed _ tptr) -> do
453− ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
785+ let (thunkParent, thunkName) = splitFileName thunkDir
454− mauth <- getHubAuth "github.com"
786+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
455− repoResult <- executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
787+ let
456− githubURI <- either throwIO (return . repoSshUrl) repoResult >>= \case
788+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
457− Nothing -> fail "Cannot determine clone URI for thunk source"
789+ newSpec = case _thunkPtr_source tptr of
458− Just c -> return $ T.unpack $ getUrl c
790+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
459− callProcess "hub" --TODO: Depend on hub explicitly
791+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
460− [ "clone"
792+ withSpinner' ("Fetching thunk " <> T.pack thunkName)
461− , "-n"
793+ (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
462− , githubURI
794+ let unpackedPath = tmpThunk </> unpackedDirName
463− , tmpRepo
795+ gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
465− let obGitDir = tmpRepo </> ".git" </> "obelisk"
797+ let normalizeMore = dropTrailingPathSeparator . normalise
466− --If this directory already exists then something is weird and we should fail
798+ when (normalizeMore unpackedPath /= normalizeMore tmpThunk) $ -- Only write meta data if the checkout is not inplace
467− createDirectory obGitDir
799+ createThunk tmpThunk $ Left newSpec
468− callProcess "cp"
800+
469− [ "-r"
801+ liftIO $ do
470− , "-T"
802+ removePathForcibly thunkDir
471− , thunkDir </> "."
803+ renameDirectory tmpThunk thunkDir
472− , obGitDir </> "orig-thunk"
804+
473− ]
805+gitCloneForThunkUnpack
474− let checkoutOptions = concat
806+ :: MonadObelisk m
475− [ ["-C", tmpRepo]
807+ => GitSource -- ^ Git source to use
476− , pure "checkout"
808+ -> Ref hash -- ^ Commit hash to reset to
477− , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)
809+ -> FilePath -- ^ Directory to clone into
478− , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr
810+ -> m ()
479− ]
811+gitCloneForThunkUnpack gitSrc commit dir = do
480− callProcess "hub" checkoutOptions
812+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
481− callProcess "rm"
813+ git $ [ "clone" ]
482− [ "-r"
814+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
483− , thunkDir
815+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
816+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc
817+ [ "--branch", T.unpack $ untagName branch ]
818+ git ["reset", "--hard", Ref.toHexString commit]
819+ when (_gitSource_fetchSubmodules gitSrc) $
820+ git ["submodule", "update", "--recursive", "--init"]
822+--TODO: add a rollback mode to pack to the original thunk
823+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
824+packThunk = packThunk' False
826+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
827+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
828+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
830+ ("Packing thunk " <> T.pack thunkDir)
831+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
833+ let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
834+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
835+ liftIO $ removePathForcibly thunkDir
836+ createThunk thunkDir $ Right thunkPtr
839+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
840+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
842+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of
843+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }
844+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
848+ = CheckClean_FullCheck
849+ -- ^ Check that the repo is clean, including .gitignored files
850+ | CheckClean_NotIgnored
851+ -- ^ Check that the repo is clean, not including .gitignored files
852+ | CheckClean_NoCheck
853+ -- ^ Don't check that the repo is clean
855+getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
856+getThunkPtr gitCheckClean dir mPrivate = do
857+ let repoLocations = nubOrd $ map (first normalise)
858+ [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]
859+ repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
860+ thunkDir <- case repoLocation' of
861+ Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
862+ Just (_, path) -> pure $ normalise $ dir </> path
864+ let (checkClean, checkIgnored) = case gitCheckClean of
865+ CheckClean_FullCheck -> (True, True)
866+ CheckClean_NotIgnored -> (True, False)
867+ CheckClean_NoCheck -> (False, False)
868+ when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
869+ "thunk pack: thunk checkout contains unsaved modifications"
871+ -- Check whether there are any stashes
872+ when checkClean $ do
873+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
874+ unless (T.null stashOutput) $
875+ failWith $ T.unlines $
876+ [ "thunk pack: thunk checkout has stashes"
878+ ] ++ T.lines stashOutput
880+ -- Get current branch
881+ (mCurrentBranch, mCurrentCommit) <- do
882+ b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
883+ c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
885+ (Just "HEAD") -> failWith $ T.unlines
886+ [ "thunk pack: You are in 'detached HEAD' state."
887+ , "If you want to pack at the current ref \
888+ \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
485− callProcess "mv"
890+ _ -> return (b, c)
487− , tmpRepo
892+ -- Get information on all branches and their (optional) designated upstream
488− , thunkDir
893+ -- correspondents
894+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
896+ , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
900+ (headInfo :: Map Text (Maybe (Text, Text)))
901+ <- fmap Map.fromList $ forM headDump $ \line -> do
902+ (branch : restOfLine) <- pure $ T.words line
903+ mUpstream <- case restOfLine of
905+ [u, r] -> pure $ Just (u, r)
906+ (_:_) -> failWith "git for-each-ref invalid output"
907+ pure (branch, mUpstream)
909+ putLog Debug $ "branches: " <> T.pack (show headInfo)
911+ let errorMap :: Map Text ()
912+ headUpstream :: Map Text (Text, Text)
913+ (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
917+ putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)
919+ -- Check that every branch has a remote equivalent
920+ when checkClean $ do
921+ let untrackedBranches = Map.keys errorMap
922+ when (not $ L.null untrackedBranches) $ failWith $ T.unlines $
923+ [ "thunk pack: Certain branches in the thunk have no upstream branch \
924+ \set. This means we don't know to check whether all your work is \
925+ \saved. The offending branches are:"
927+ , T.unwords untrackedBranches
929+ , "To fix this, you probably want to do:"
932+ ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++
934+ , "These will push the branches to the default remote under the same \
935+ \name, and (thanks to the `-u`) remember that choice so you don't \
936+ \get this error again."
939+ -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
940+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
941+ (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
942+ [ "rev-list", "--left-right"
943+ , T.unpack branch <> "..." <> T.unpack upstream
490− return ()
945+ let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
491− ThunkSource_Git _s -> do
946+ behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
492− $notImplemented
947+ pure (upstream, (ahead, behind))
494−--TODO: add force mode to pack even if changes are present
949+ -- Those branches which have commits ahead of, i.e. not on, the upstream
495−--TODO: add a rollback mode to pack to the original thunk
950+ -- branch. Purely being behind is fine.
496−packThunk :: FilePath
951+ let nonGood = Map.filter ((/= 0) . fst . snd) stats
498− -> IO ()
953+ when (not $ Map.null nonGood) $ failWith $ T.unlines $
499−packThunk thunkDir upstream = readThunk thunkDir >>= \case
954+ [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
500− Left err -> fail $ "thunk pack: " <> show err
955+ , ""
501− Right (ThunkData_Packed _) -> fail "pack: thunk is already packed"
956+ ] ++
502− Right (ThunkData_Checkout _) -> do
957+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
503− thunkPtr <- getThunkPtr thunkDir upstream
958+ [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
504− callProcess "rm"
959+ [ ""
505− [ "-rf"
960+ , "Please push these upstream and try again. (Or just fetch, if they are somehow \
506− , thunkDir
961+ \pushed but this repo's remote tracking branches don't know it.)"
508− createThunk thunkDir thunkPtr
963+
509− return ()
964+ when checkClean $ do
511−getThunkPtr :: FilePath -> String -> IO ThunkPtr
512−getThunkPtr thunkDir upstream = do
513− --Check whether the working directory is clean
514− statusOutput <- readProcess "hub"
516− , "status", "--porcelain", "--ignored" ] ""
517− diffOutput <- readProcess "hub" [ "-C", thunkDir , "diff" ] ""
518− case null statusOutput && null diffOutput of
520− statusDebug <- readProcess "hub"
521− [ "-C", thunkDir, "status", "--ignored" ] ""
523− [ "thunk pack: thunk checkout contains unsaved modifications"
525− ] ++ lines statusDebug
528− -- Check whether there are any stashes
529− stashOutput <- readProcess "hub" [ "-C", thunkDir, "stash", "list" ] ""
530− case null stashOutput of
533− [ "thunk pack: thunk checkout has stashes"
535− ] ++ lines stashOutput
538− --Check whether all local heads are pushed
539− repoHeads <- lines <$> readProcess "hub"
541− , "for-each-ref", "--format=%(refname:short)", "refs/heads/"
543− remotes <- lines <$> readProcess "hub" [ "-C", thunkDir, "remote" ] ""
544− --Check that the upstream specified actually exists
545− case L.find (== upstream) remotes of
546− Nothing -> fail $ "thunk pack: upstream " <> upstream <> " does not exist"
548− -- iterate over cartesian product
549− forM_ repoHeads $ \hd -> do
550− [localRev] <- lines <$> readProcess "hub" [ "-C", thunkDir, "rev-parse", hd ] ""
551− forM_ remotes $ \rm -> do
552− --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
553− [remoteMergeRev] <- lines <$> readProcess "hub"
557− , "remotes/" <> rm <> "/" <> hd
559− case remoteMergeRev == localRev of
560− False -> fail $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
563− --We assume it's safe to pack the thunk at this point
965+ -- We assume it's safe to pack the thunk at this point
966+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
968+ let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
564− [remoteUri'] <- lines <$> readProcess "hub"
970+ [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
565− [ "-C", thunkDir
971+ [ "config"
566− , "config", "--get", "remote." <> upstream <> ".url"
972+ , "--get"
973+ , "remote." <> T.unpack remote <> ".url"
976+ remoteUri <- case parseGitUri remoteUri' of
569− let uriParseFailure = "Could not identify git remote: " <> remoteUri'
977+ Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
570− mRemoteUri = parseURIReference remoteUri'
978+ Just uri -> pure uri
571− <|> parseSshShorthand remoteUri'
979+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
572− thunkPtr <- case mRemoteUri of
980+
573− Nothing -> fail uriParseFailure
981+-- | Get the latest revision available from the given source
574− Just remoteUri -> do
982+getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
575− refs <- fmap (refsToTuples . words) . lines <$> readProcess "hub"
983+getLatestRev os = do
576− [ "-C"
984+ let gitS = thunkSourceToGitSource os
577− , thunkDir
985+ (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
578− , "show-ref"
986+ case os of
579− , "--head" ] ""
987+ ThunkSource_GitHub s -> githubThunkRev s commit
580− -- safe because exactly one hash is associated with HEAD
988+ ThunkSource_Git s -> gitThunkRev s commit
581− let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
989+
582− remoteHeads = Map.fromList $ catMaybes $ fmap
990+-- | Convert a URI to a thunk
583− (\(x,y) -> (,) x <$> L.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
991+--
584− refs
992+-- If the URL is a github URL, we try to just download an archive for
585− localHeads = Map.fromList $ catMaybes $ fmap
993+-- performance. If that doesn't work (e.g. authentication issue), we fall back
586− (\(x,y) -> (,) x <$> L.stripPrefix "refs/heads/" y)
994+-- on just doing things the normal way for git repos in general, and save it as
587− refs
995+-- a regular git thunk.
588− currentUpstreamBranch = Map.lookup currentHead remoteHeads
996+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
589− <|> Map.lookup currentHead localHeads
997+uriThunkPtr uri mPrivate mbranch mcommit = do
590− if
998+ commit <- case mcommit of
591− | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch
999+ Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
592− | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch
1000+ (Just c) -> return c
593− return thunkPtr
1001+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
594− where
1002+ ThunkSource_GitHub s -> do
595− refsToTuples [x, y] = (x, y)
1003+ rev <- runExceptT $ githubThunkRev s commit
596− refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
1004+ case rev of
597− isGithubThunk u
1005+ Right r -> pure (ThunkSource_GitHub s, r)
1008+\Failed to fetch archive from GitHub. This is probably a private repo. \
1009+\Falling back on normal fetchgit. Original failure:"
1011+ let s' = forgetGithub True s
1012+ (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
1013+ ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
1015+ { _thunkPtr_rev = rev
1016+ , _thunkPtr_source = src
1019+-- | N.B. Cannot infer all fields.
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
598− | Just uriAuth <- uriAuthority u
1026+ | Right uriAuth <- URI.uriAuthority u
599− = case uriScheme u of
1027+ , Just scheme <- URI.unRText <$> URI.uriScheme u
600− "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""
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
601− s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"
1034+ s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
602− && uriRegName uriAuth == "github.com"
1035+ && URI.unRText (URI.authHost uriAuth) == "github.com"
603− | otherwise = False
1036+ , Just (_, owner :| [repoish]) <- URI.uriPath u
604− githubThunkPtr u commit' branch' = do
1037+ = \mbranch -> do
605− ["/", owner', repo'] <- return $ splitDirectories (uriPath u)
1038+ isPrivate <- getIsPrivate
606− let owner = N (T.pack owner')
1039+ pure $ ThunkSource_GitHub $ GitHubSource
607− repo = N (T.pack (dropExtension repo'))
1040+ { _gitHubSource_owner = N $ URI.unRText owner
608− commit = N (T.pack commit')
1041+ , _gitHubSource_repo = N $ let
609− branch = N . T.pack <$> branch'
1042+ repoish' = URI.unRText repoish
610− mauth <- getHubAuth "github.com"
1043+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
611− repoResult <- executeRequestMaybe mauth $ repositoryR owner repo
1044+ , _gitHubSource_branch = N <$> mbranch
612− repoIsPrivate <- either throwIO (return . repoPrivate) repoResult
1045+ , _gitHubSource_private = isPrivate
613− archiveResult <- executeRequestMaybe mauth $
614− archiveForR owner repo ArchiveFormatTarball (Just (untagName commit))
615− archiveUri <- either throwIO return archiveResult
616− hash <- getNixSha256ForUriUnpacked archiveUri
618− { _thunkPtr_rev = ThunkRev
619− { _thunkRev_commit = commitNameToRef commit
620− , _thunkRev_nixSha256 = hash
622− , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
1047+
623− { _gitHubSource_owner = owner
1048+ | otherwise = \mbranch -> do
624− , _gitHubSource_repo = repo
1049+ isPrivate <- getIsPrivate
625− , _gitHubSource_branch = branch
1050+ pure $ ThunkSource_Git $ GitSource
626− , _gitHubSource_private = repoIsPrivate
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
1057+ getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
1059+guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
1060+guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
1062+ uriAttempt:xs -> do
1063+ result <- readCreateProcessWithExitCode $
1070+ , T.unpack $ gitUriToText uriAttempt
1073+ (ExitSuccess, _, _) -> pure False -- Must be a public repo
1076+ urisToTry = nubOrd $
1077+ -- Include the original URI if it isn't using SSH because SSH will certainly fail.
1078+ [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>
1079+ [changeScheme "https" uri, changeScheme "http" uri]
1080+ changeScheme scheme (GitUri u) = GitUri $ u
1081+ { URI.uriScheme = URI.mkScheme scheme
1082+ , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u
629− gitThunkPtr u _commit' _branch' = do
1084+
630− case uriScheme u of
1085+-- Funny signature indicates no effects depend on the optional branch name.
631− "https:" -> return ()
1086+githubThunkRev
632− "git:" -> return ()
1087+ :: forall m
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
1103+ , URI.uriPath = Just ( False
1104+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
1106+ , URI.uriQuery = []
1107+ , URI.uriFragment = Nothing
1109+ hash <- getNixSha256ForUriUnpacked archiveUri
1110+ putLog Debug $ "Nix sha256 is " <> hash
1112+ { _thunkRev_commit = commitNameToRef $ N commit
1113+ , _thunkRev_nixSha256 = hash
1116+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
1117+ forcePP = URI.mkPathPiece . untagName
1124+gitThunkRev s commit = do
1125+ let u = _gitSource_url s
1126+ protocols = ["file", "https", "ssh", "git"]
1127+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
1128+ unless (T.toLower scheme `elem` protocols) $
633− _ -> fail $ "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"
1129+ failWith $ "obelisk currently only supports "
634− $notImplemented
1130+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
635− parseSshShorthand uri' = do
1131+ hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
1132+ putLog Informational $ "Nix sha256 is " <> hash
1134+ { _thunkRev_commit = commitNameToRef (N commit)
1135+ , _thunkRev_nixSha256 = hash
1138+-- | Given the URI to a git remote, and an optional branch name, return the name
1139+-- of the branch along with the hash of the commit at tip of that branch.
1141+-- If the branch name is passed in, it is returned exactly as-is. If it is not
1142+-- passed it, the default branch of the repo is used instead.
1145+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
1146+gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
1147+ (_, bothMaps) <- gitLsRemote
1148+ (T.unpack $ gitUriToText uri)
1149+ (GitRef_Branch <$> mbranch)
1151+ branch <- case mbranch of
1152+ Nothing -> withExitFailMessage "Failed to find default branch" $ do
1153+ b <- rethrowE $ gitLookupDefaultBranch bothMaps
1154+ putLog Debug $ "Default branch for remote repo " <> uriMsg <> " is " <> b
1157+ commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)
1158+ putLog Informational $ "Latest commit in branch " <> branch
1159+ <> " from remote repo " <> uriMsg
1160+ <> " is " <> commit
1161+ pure (branch, commit)
1163+ rethrowE = either failWith pure
1164+ uriMsg = gitUriToText uri
1166+parseGitUri :: Text -> Maybe GitUri
1167+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
1169+parseFileURI :: Text -> Maybe URI.URI
1170+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
1172+parseAbsoluteURI :: Text -> Maybe URI.URI
1173+parseAbsoluteURI uri = do
1174+ parsedUri <- URI.mkURI uri
1175+ guard $ URI.isPathAbsolute parsedUri
1178+parseSshShorthand :: Text -> Maybe URI.URI
1179+parseSshShorthand uri = do
636− -- This is what git does to check that the remote
1180+ -- This is what git does to check that the remote
637− -- is not a local file path when parsing shorthand.
1181+ -- is not a local file path when parsing shorthand.
638− -- Last referenced from here:
1182+ -- Last referenced from here:
639− -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
1183+ -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
640− let uri = T.pack uri'
1184+ let
641− (authAndHostname, colonAndPath) = T.break (== ':') uri
1185+ (authAndHostname, colonAndPath) = T.break (== ':') uri
642− properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
1186+ properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
643− -- Shorthand is valid iff a colon is present and it occurs before the first slash
1187+ -- Shorthand is valid iff a colon is present and it occurs before the first slash
644− -- This check is used to disambiguate a filepath containing a colon from shorthand
1188+ -- This check is used to disambiguate a filepath containing a colon from shorthand
645− guard $ isNothing (T.findIndex (=='/') authAndHostname)
1189+ guard $ isNothing (T.findIndex (=='/') authAndHostname)
646− && not (T.null colonAndPath)
1190+ && not (T.null colonAndPath)
647− parseURI $ T.unpack properUri
1191+ URI.mkURI properUri