nix-thunk (empty) → 0.7.2.2
raw patch · 9 files changed
Files
- CHANGELOG.md +78/−0
- LICENSE +30/−0
- README.md +112/−0
- Setup.hs +2/−0
- nix-thunk.cabal +78/−0
- src-bin/nix-thunk.hs +59/−0
- src/Nix/Thunk.hs +39/−0
- src/Nix/Thunk/Command.hs +97/−0
- src/Nix/Thunk/Internal.hs +1686/−0
+ CHANGELOG.md view
@@ -0,0 +1,78 @@+# Revision history for nix-thunk++## 0.7.2.2++* Support GHC 9.12++## 0.7.2.1+* Loosen version bounds+* Fix issue where thunk branches aren't updated when the user specifies --branch on nix-thunk update+* Swap default.nix and lib.nix++## 0.7.2.0+* Support retrieving revs that aren't on the default branch when a branch isn't specified. To use this functionality, update your thunks.++## 0.7.1.0+* Allow specifying `--rev` when doing `update` to update to a specific revision.++## 0.7.0.1++* Support GHC 9.6++## 0.7.0.0++* Caching now works+* [#42](https://github.com/obsidiansystems/nix-thunk/pull/42) Thunk read errors are now presented in a more informative manner.+* [#43](https://github.com/obsidiansystems/nix-thunk/pull/43) `nix-thunk` will now ensure that any `git` processes invoked during its execution have a clean configuration.+ This prevents `nix-thunk` crashing when e.g. the user's configuration `git` is valid only in a version newer than what `nix-thunk` links against, and works towards making thunks more reproducible by ensuring that thunk URIs are resolvable independently of the user's environment.++## 0.6.1.0++* [#36](https://github.com/obsidiansystems/nix-thunk/pull/36) Expose the internals of the `nix-thunk` library.++## 0.6.0.0++* [#34](https://github.com/obsidiansystems/nix-thunk/pull/34) Fix an+ issue where thunks could not be fetched without `nix-thunk` (or one of+ its dependents, e.g. `obelisk`) being installed. Please update all+ your thunks to use the new v8 thunk spec.++ Updating your thunk can be done by running `nix-thunk unpack $path; nix-thunk pack $path`.++* [#35](https://github.com/obsidiansystems/nix-thunk/pull/35) Determine remote using git-config when `branch.<name>.merge` option is set+ (Fixes [obelisk#792](https://github.com/obsidiansystems/obelisk/issues/792).)++## 0.5.1.0++* Bump to cli-nix 0.2.0.0; This ensures that `nix-prefetch-git` can always be found.++## 0.5.0.0++* Fix a critical bug where v6 thunks can not be used to fetch non-GitHub repositories. Please update all your thunks to use the new v7 thunk spec.+ Updating your thunk can be done by running `nix-thunk unpack $path; nix-thunk pack $path`.+* Building a functional `nix-thunk` _must_ be done using the included Nix derivation.++## 0.4.0.0++* The default thunk specification ("v6") now uses a pinned version of nixpkgs, rather than the magic `<nixpkgs>`, for fetching thunks. This ensures that thunks can be fetched even in an environment where `NIX_PATH` is unset.++## 0.3.0.0++* Fix readThunk when thunk is checked out [#4](https://github.com/obsidiansystems/nix-thunk/pull/4)+* Fix removal of .git from default destination [#10](https://github.com/obsidiansystems/nix-thunk/pull/10)++## 0.2.0.3++* Default to GHC 8.8.4 and update dependency bounds++## 0.2.0.2+* Add support for GHC 8.8.4.++## 0.2.0.1+* Fix parsing of --rev arguments++## 0.2.0.0+* Add nix-thunk create. This caused some minor breakage to the Haskell library API, but not the Nix or command line interfaces.++## 0.1.0.0+* Initial release. Extracted the Nix part of this code from https://github.com/obsidiansystems/reflex-platform and the Haskell part from https://github.com/obsidiansystems/obelisk
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020 Obsidian Systems LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Obsidian Systems LLC nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,112 @@+nix-thunk+=========+[](https://haskell.org) [](https://hackage.haskell.org/package/nix-thunk) [](https://github.com/obsidiansystems/nix-thunk/actions) [](https://github.com/obsidiansystems/nix-thunk/blob/master/LICENSE)++nix-thunk is a lightweight Nix dependency manager, focused on making it easy to contribute improvements back to libraries you depend on.++nix-thunk does this by creating and managing "thunks" - directories that stand in for full git repositories.+Like git submodules, they pin a specific commit of the target repository, but unlike git submodules, you don't have to clone them to use them.+nix-thunk makes them "transparent" to Nix scripts, so any script that calls `import path/to/some/thunk` will work the same on the thunk as it does on the original repository.++* [Installation](#installation)+* [Command Usage](#command-usage)+ * [Create a dependency](#create-a-dependency)+ * [Work on a dependency](#work-on-a-dependency)+ * [Update a dependency](#update-a-dependency)+* [Nix Usage](#nix-usage)+* [Contributing](#contributing)+* [License](#license)++## Installation++```bash+nix-env -f https://github.com/obsidiansystems/nix-thunk/archive/master.tar.gz -iA command+```++**WARNING**: It is _not_ possible to compile `nix-thunk` without Nix.+To ensure that packed thunks are buildable even in environments where diamond paths are unavailable (specifically `<nixpkgs>`), `nix-thunk` _must_ be built with knowledge of a known-good nixpkgs, _and_ for `nix-thunk` to be able to manipulate these thunks, it must _always_ be the same version of nixpkgs.++## Command Usage++### Create a dependency++```bash+nix-thunk create https://example.com/some-dep+```++If you have already cloned the dependency as a git repository, you can just `pack` it instead:++```bash+nix-thunk pack some-dep+```++### Work on a dependency++If you discover a bug fix or improvement that your dependency needs, you can use `nix-thunk unpack path/to/your/dependency` to turn the thunk back into a full checkout of the repository.+Your Nix scripts should continue working, and you can modify the dependency's source code, push it to a branch or a fork, send a pull request, and then use `nix-thunk pack path/to/your/dependency` to pack it back up into a thunk.+When the dependency accepts your pull request, you can easily update the thunk.++```bash+nix-thunk unpack some-dep+# Improve some-dep and push your work to a branch+nix-thunk pack some-dep+```++### Update a dependency++For routine updates, you can run `nix-thunk update path/to/your/dependency` to point the thunk at the latest version of the dependency without needing to do a `nix-thunk unpack` or a `git clone`.++```bash+nix-thunk update some-dep+```++## Nix Usage++The [`default.nix`](default.nix) file in this repository defines the nix function, `thunkSource`.+This can be used in your nix files to access the contents of thunks.+In the following example, a thunk is used in place of the source location argument to `callCabal2nix`.+`thunkSource` works whether the thunk is packed or unpacked, making it convenient to run nix commands with modified thunks.++```nix+ haskellPackages = pkgs.haskell.packages.ghc865.override {+ overrides = self: super: {+ which = self.callCabal2nix "which" (thunkSource ./dep/which) {};+ };+ };+```++You can also represent in nix all the thunks of a given directory+```nix+let sources = nix-thunk.mapSubdirectories nix-thunk.thunkSource ./dep;+```+```nix+{ which = self.callCabal2nix "which" sources.which {}; }+```++You can also access subfolders of a thunk.+For example:++```nix+{+ imports = [ "${builtins.fetchTarball <some-tar-url>}/path/to/subfolder" ];+}+```+becomes+```+{+ imports = [ "${nix-thunk.thunkSource <thunk-location>}/path/to/subfolder>" ];+}+```++## Contributing++Pull requests are welcome.+For major changes, please open an issue first to discuss what you would like to change.+See the [contribution guide](CONTRIBUTING.md) for more details.++## License+[BSD3](./LICENSE)++***++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ nix-thunk.cabal view
@@ -0,0 +1,78 @@+cabal-version: >=1.10+name: nix-thunk+version: 0.7.2.2+license: BSD3+license-file: LICENSE+copyright: Obsidian Systems LLC 2020-2022+maintainer: maintainer@obsidian.systems+author: Obsidian Systems LLC+bug-reports: https://github.com/obsidiansystems/nix-thunk+synopsis: Lightweight dependency management with Nix+description:+ nix-thunk lets you manage source code dependencies in a lightweight and reproducible way, using Nix. Each source repository is represented by a stub directory, which refers to the original Git repository. nix-thunk can easily update these dependencies.+ .+ If you need to make improvements to the original repositories, nix-thunk can unpack them in-place, so that changes can be tested right away, and then pack them back up when you're done. This makes it easy to send a pull request to the upstream repo while your project continues on a fork, then switch back to upstream once your pull request has been merged.++category: Nix, Git+build-type: Simple+extra-source-files:+ CHANGELOG.md+ README.md++tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.5 || ==9.4.5 || ==9.6.1 || ==9.8.2 || ==9.10.1 || ==9.12.2++library+ exposed-modules:+ Nix.Thunk+ Nix.Thunk.Internal+ Nix.Thunk.Command++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ aeson >=1.4.4.0 && <2.3+ , aeson-pretty >=0.8.7 && <0.9+ , base >=4.12.0.0 && <4.22+ , bytestring >=0.10.8.2 && <0.13+ , cli-extras >=0.2.1.0 && <0.3+ , cli-git >=0.2.0.0 && <0.3+ , cli-nix >=0.2.0.0 && <0.3+ , containers >=0.6.0.1 && <0.8+ , cryptonite >=0.25 && <0.31+ , data-default >=0.7.1.1 && <0.9+ , directory >=1.3.3.0 && <1.4+ , either >=5.0.1.1 && <5.1+ , exceptions >=0.10.3 && <0.11+ , extra >=1.6.18 && <1.9+ , filepath >=1.4.2.1 && <1.6+ , github >=0.25 && <0.31+ , here >=1.2.13 && <1.3+ , lens >=4.17.1 && <5.4+ , logging-effect >=1.3.4 && <1.5+ , megaparsec >=7.0.5 && <9.8+ , memory >=0.14 && <0.19+ , modern-uri >=0.3.1.0 && <0.4+ , monad-logger >=0.3.30 && <0.4+ , mtl >=2.2.2 && <2.4+ , optparse-applicative >=0.14.3.0 && <0.20+ , temporary >=1.3 && <1.4+ , text >=1.2.3.1 && <2.2+ , time >=1.8.0.2 && <1.15+ , unix >=2.7.2.2 && <2.9+ , which >=0.2 && <0.3+ , yaml >=0.11.1.2 && <0.12++executable nix-thunk+ main-is: src-bin/nix-thunk.hs+ default-language: Haskell2010+ build-depends:+ base+ , cli-extras+ , nix-thunk+ , optparse-applicative+ , text++source-repository head+ type: git+ location: git://github.com/obsidiansystems/nix-thunk.git
+ src-bin/nix-thunk.hs view
@@ -0,0 +1,59 @@+import Nix.Thunk+import Nix.Thunk.Command+import Options.Applicative+import Cli.Extras+import qualified Data.Text.IO as T+import System.Environment+import System.Exit+import System.IO+import Data.List+import Data.Void++data Args = Args+ { _args_verbose :: Bool+ , _args_command :: ThunkCommand+ }++verbose :: Parser Bool+verbose = flag False True $ mconcat+ [ long "verbose"+ , short 'v'+ , help "Produce more detailed output"+ ]++args :: Parser Args+args = Args <$> verbose <*> thunkCommand++argsInfo :: ParserInfo Args+argsInfo = info (args <**> helper) $ mconcat+ [ fullDesc+ , progDesc "Manage source repositories using Nix"+ ]++parserPrefs :: ParserPrefs+parserPrefs = defaultPrefs+ { prefShowHelpOnEmpty = True+ }++main :: IO ()+main =+ do+ args <- getArgs+ args' <- handleParseResult $ execParserPure parserPrefs argsInfo args+ let logLevel = if _args_verbose args' then Debug else Notice+ notInteractive <- not <$> isInteractiveTerm args+ cliConf <- newCliConfig logLevel notInteractive notInteractive (\e -> (prettyNixThunkError e, ExitFailure 1))+ runCli cliConf (runThunkCommand (_args_command args'))+ where+ isInteractiveTerm args = do+ isTerm <- hIsTerminalDevice stdout+ -- Running in bash/fish/zsh completion+ let inShellCompletion = isInfixOf "completion" $ unwords args++ -- Respect the user’s TERM environment variable. Dumb terminals+ -- like Eshell cannot handle lots of control sequences that the+ -- spinner uses.+ termEnv <- lookupEnv "TERM"+ let isDumb = termEnv == Just "dumb"++ return $ isTerm && not inShellCompletion && not isDumb
+ src/Nix/Thunk.hs view
@@ -0,0 +1,39 @@+module Nix.Thunk+ ( ThunkSource (..)+ , GitHubSource (..)+ , ThunkRev (..)+ , getLatestRev+ , gitCloneForThunkUnpack+ , thunkSourceToGitSource+ , ThunkPtr (..)+ , ThunkData (..)+ , readThunk+ , CheckClean (..)+ , getThunkPtr+ , packThunk+ , createThunk+ , createThunk'+ , createWorktree+ , CreateWorktreeConfig (..)+ , ThunkPackConfig (..)+ , ThunkConfig (..)+ , updateThunkToLatest+ , updateThunk+ , ThunkUpdateConfig (..)+ , unpackThunk+ , ThunkSpec (..)+ , ThunkFileSpec (..)+ , NixThunkError+ , nixBuildAttrWithCache+ , attrCacheFileName+ , prettyNixThunkError+ , ThunkCreateSource (..)+ , ThunkCreateConfig (..)+ , parseGitUri+ , GitUri (..)+ , uriThunkPtr+ , Ref(..)+ , refFromHexString+ ) where++import Nix.Thunk.Internal
+ src/Nix/Thunk/Command.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+module Nix.Thunk.Command where++import Cli.Extras (HasCliConfig, Output)+import Control.Monad.Catch (MonadMask)+import Control.Monad.Error.Class (MonadError)+import Control.Monad.Fail (MonadFail)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Log (MonadLog)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Text as T+import Options.Applicative+import System.FilePath++import Nix.Thunk++thunkConfig :: Parser ThunkConfig+thunkConfig = ThunkConfig+ <$>+ ( flag' (Just True) (long "private" <> help "Mark thunks as pointing to a private repository")+ <|> flag' (Just False) (long "public" <> help "Mark thunks as pointing to a public repository")+ <|> pure Nothing+ )++thunkUpdateConfig :: Parser ThunkUpdateConfig+thunkUpdateConfig = ThunkUpdateConfig+ <$> optional (strOption (short 'b' <> long "branch" <> metavar "BRANCH" <> help "Use the given branch when looking for the latest revision"))+ <*> optional (strOption (short 'r' <> long "rev" <> metavar "REVISION" <> help "Update to this specific revision"))+ <*> thunkConfig++thunkPackConfig :: Parser ThunkPackConfig+thunkPackConfig = ThunkPackConfig+ <$> switch (long "force" <> short 'f' <> help "Force packing thunks even if there are branches not pushed upstream, uncommitted changes, stashes. This will cause changes that have not been pushed upstream to be lost; use with care.")+ <*> thunkConfig++thunkCreateConfig :: Parser ThunkCreateConfig+thunkCreateConfig = ThunkCreateConfig+ <$> argument source (metavar "URI" <> help "Address of the target repository")+ <*> optional (strOption (short 'b' <> long "branch" <> metavar "BRANCH" <> help "Point the new thunk at the given branch"))+ <*> optional (option (refFromHexString <$> str) (long "rev" <> long "revision" <> metavar "REVISION" <> help "Point the new thunk at the given revision"))+ <*> thunkConfig+ <*> optional (strArgument (action "directory" <> metavar "DESTINATION" <> help "The name of a new directory to create for the thunk"))+ where+ source = (ThunkCreateSource_Absolute <$> maybeReader (parseGitUri . T.pack))+ <|> (ThunkCreateSource_Relative <$> str)++createWorktreeConfig :: Parser CreateWorktreeConfig+createWorktreeConfig = CreateWorktreeConfig+ <$> optional (strOption (short 'b' <> long "branch" <> metavar "BRANCH" <> help "create a new branch"))+ <*> switch (long "detach" <> short 'd' <> help "detach HEAD at the commit specified in thunk")++data ThunkCommand+ = ThunkCommand_Update ThunkUpdateConfig (NonEmpty FilePath)+ | ThunkCommand_Unpack (NonEmpty FilePath)+ | ThunkCommand_Worktree CreateWorktreeConfig (FilePath, FilePath)+ | ThunkCommand_Pack ThunkPackConfig (NonEmpty FilePath)+ | ThunkCommand_Create ThunkCreateConfig+ deriving Show++thunkDirList :: Parser (NonEmpty FilePath)+thunkDirList = (:|)+ <$> dirArg (metavar "THUNKDIRS..." <> help "Paths to directories containing thunk data")+ <*> many (dirArg mempty)++createWorktreeArgs :: Parser (FilePath, FilePath)+createWorktreeArgs = (,)+ <$> dirArg (metavar "THUNKDIR" <> help "Path to directory containing thunk data")+ <*> dirArg (metavar "GITDIR" <> help "Path to local git repo")++dirArg :: Mod ArgumentFields FilePath -> Parser FilePath+dirArg opts = fmap (dropTrailingPathSeparator . normalise) $ strArgument $ action "directory" <> opts++thunkCommand :: Parser ThunkCommand+thunkCommand = hsubparser $ mconcat+ [ command "update" $ info (ThunkCommand_Update <$> thunkUpdateConfig <*> thunkDirList) $ progDesc "Update packed thunk to latest revision available on the tracked branch"+ , command "unpack" $ info (ThunkCommand_Unpack <$> thunkDirList) $ progDesc "Unpack thunk into git checkout of revision it points to"+ , command "worktree" $ info (ThunkCommand_Worktree <$> createWorktreeConfig <*> createWorktreeArgs) $ progDesc "Create a git worktree of the thunk using the specified local git repo"+ , command "pack" $ info (ThunkCommand_Pack <$> thunkPackConfig <*> thunkDirList) $ progDesc "Pack git checkout or unpacked thunk into thunk that points at the current branch's upstream"+ , command "create" $ info (ThunkCommand_Create <$> thunkCreateConfig) $ progDesc "Create a packed thunk without cloning the repository first"+ ]++runThunkCommand+ :: ( MonadLog Output m+ , HasCliConfig NixThunkError m+ , MonadIO m+ , MonadMask m+ , MonadError NixThunkError m+ , MonadFail m+ )+ => ThunkCommand -> m ()+runThunkCommand = \case+ ThunkCommand_Update config dirs -> mapM_ (updateThunkToLatest config) dirs+ ThunkCommand_Unpack dirs -> mapM_ unpackThunk dirs+ ThunkCommand_Worktree config (thunkDir, gitDir) -> createWorktree thunkDir gitDir config+ ThunkCommand_Pack config dirs -> mapM_ (packThunk config) dirs+ ThunkCommand_Create config -> createThunk' config
+ src/Nix/Thunk/Internal.hs view
@@ -0,0 +1,1686 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+module Nix.Thunk.Internal where++import Bindings.Cli.Coreutils (cp)+import Bindings.Cli.Git+ ( ensureCleanGitRepo,+ gitLookupCommitForRef,+ gitLookupDefaultBranch,+ gitLsRemote,+ gitProc,+ gitProcNoRepo,+ isolateGitProc,+ CommitId,+ GitRef(GitRef_Branch) )+import Bindings.Cli.Nix+import Cli.Extras+import Control.Applicative+import Control.Exception (Exception, displayException, throw, try)+import Control.Lens ((.~), ifor, ifor_, makePrisms)+import Control.Monad+import Control.Monad.Catch (MonadCatch, MonadMask, handle)+import Control.Monad.Except+import Control.Monad.Extra (findM)+import Control.Monad.Fail (MonadFail)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Log (MonadLog)+import Crypto.Hash (Digest, HashAlgorithm, SHA1, digestFromByteString)+import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import Data.Aeson.Encode.Pretty+import qualified Data.Aeson.Types as Aeson+import Data.Bifunctor (first)+import Data.ByteArray.Encoding (Base(..), convertFromBase, convertToBase)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS+import Data.Containers.ListUtils (nubOrd)+import Data.Data (Data)+import Data.Default+import Data.Either.Combinators (fromRight', rightToMaybe)+import Data.Foldable (for_, toList)+import Data.Function+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty(..), nonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String.Here.Interpolated (i)+import Data.String.Here.Uninterpolated (here)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding+import qualified Data.Text.IO as T+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Traversable+import Data.Typeable (Typeable)+import Data.Yaml (parseMaybe)+import GitHub+import GitHub.Data.Name+import System.Directory+import System.Exit+import System.FilePath+import System.IO.Error (isDoesNotExistError)+import System.IO.Temp+import System.Posix.Files+import qualified Text.URI as URI++--------------------------------------------------------------------------------+-- Hacks+--------------------------------------------------------------------------------++type MonadInfallibleNixThunk m =+ ( CliLog m+ , HasCliConfig NixThunkError m+ , MonadIO m+ , MonadMask m+ )++type MonadNixThunk m =+ ( MonadInfallibleNixThunk m+ , CliThrow NixThunkError m+ , MonadFail m+ )++data NixThunkError+ = NixThunkError_ProcessFailure ProcessFailure+ | NixThunkError_Unstructured Text++prettyNixThunkError :: NixThunkError -> Text+prettyNixThunkError = \case+ NixThunkError_ProcessFailure (ProcessFailure p code) ->+ "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p+ NixThunkError_Unstructured msg -> msg++makePrisms ''NixThunkError++instance AsUnstructuredError NixThunkError where+ asUnstructuredError = _NixThunkError_Unstructured++instance AsProcessFailure NixThunkError where+ asProcessFailure = _NixThunkError_ProcessFailure++--------------------------------------------------------------------------------+-- End hacks+--------------------------------------------------------------------------------++--TODO: Support symlinked thunk data+data ThunkData+ = ThunkData_Packed ThunkSpec ThunkPtr+ -- ^ Packed thunk+ | ThunkData_Checkout+ -- ^ Checked out thunk that was unpacked from this pointer++-- | A reference to the exact data that a thunk should translate into+data ThunkPtr = ThunkPtr+ { _thunkPtr_rev :: ThunkRev+ , _thunkPtr_source :: ThunkSource+ }+ deriving (Show, Eq, Ord)++type NixSha256 = Text --TODO: Use a smart constructor and make this actually verify itself++-- | A specific revision of data; it may be available from multiple sources+data ThunkRev = ThunkRev+ { _thunkRev_commit :: Ref SHA1+ , _thunkRev_nixSha256 :: NixSha256+ }+ deriving (Show, Eq, Ord)++-- | A location from which a thunk's data can be retrieved+data ThunkSource+ -- | A source specialized for GitHub+ = ThunkSource_GitHub GitHubSource+ -- | A plain repo source+ | ThunkSource_Git GitSource+ deriving (Show, Eq, Ord)++thunkSourceToGitSource :: ThunkSource -> GitSource+thunkSourceToGitSource = \case+ ThunkSource_GitHub s -> forgetGithub False s+ ThunkSource_Git s -> s++setThunkSourceBranch :: Maybe (Name Branch) -> ThunkSource -> ThunkSource+setThunkSourceBranch mb = \case+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_branch = mb }+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_branch = mb }++data GitHubSource = GitHubSource+ { _gitHubSource_owner :: Name Owner+ , _gitHubSource_repo :: Name Repo+ , _gitHubSource_branch :: Maybe (Name Branch)+ , _gitHubSource_private :: Bool+ }+ deriving (Show, Eq, Ord)++newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)++gitUriToText :: GitUri -> Text+gitUriToText (GitUri uri)+ | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"+ , Just (_, path) <- URI.uriPath uri+ = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)+ | otherwise = URI.render uri++data GitSource = GitSource+ { _gitSource_url :: GitUri+ , _gitSource_branch :: Maybe (Name Branch)+ , _gitSource_fetchSubmodules :: Bool+ , _gitSource_private :: Bool+ }+ deriving (Show, Eq, Ord)++newtype ThunkConfig = ThunkConfig+ { _thunkConfig_private :: Maybe Bool+ } deriving Show++data ThunkUpdateConfig = ThunkUpdateConfig+ { _thunkUpdateConfig_branch :: Maybe Text+ , _thunkUpdateConfig_ref :: Maybe Text+ , _thunkUpdateConfig_thunk :: ThunkConfig+ } deriving Show++data ThunkPackConfig = ThunkPackConfig+ { _thunkPackConfig_force :: Bool+ , _thunkPackConfig_config :: ThunkConfig+ } deriving Show++-- | The source to be used for creating thunks.+data ThunkCreateSource+ = ThunkCreateSource_Absolute GitUri+ -- ^ Create a thunk from an absolute reference to a Git repository:+ -- URIs like @file://@, @https://@, @ssh://@ etc.+ | ThunkCreateSource_Relative FilePath+ -- ^ Create a thunk from a local folder. If the folder exists, then+ -- it is made absolute using the current working directory and+ -- treated as a @file://@ URL.+ deriving Show++data ThunkCreateConfig = ThunkCreateConfig+ { _thunkCreateConfig_uri :: ThunkCreateSource+ , _thunkCreateConfig_branch :: Maybe (Name Branch)+ , _thunkCreateConfig_rev :: Maybe (Ref SHA1)+ , _thunkCreateConfig_config :: ThunkConfig+ , _thunkCreateConfig_destination :: Maybe FilePath+ } deriving Show++data CreateWorktreeConfig = CreateWorktreeConfig+ { _createWorktreeConfig_branch :: Maybe String+ , _createWorktreeConfig_detach :: Bool+ } deriving Show++-- | Convert a GitHub source to a regular Git source. Assumes no submodules.+forgetGithub :: Bool -> GitHubSource -> GitSource+forgetGithub useSsh s = GitSource+ { _gitSource_url = GitUri $ URI.URI+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"+ , URI.uriAuthority = Right $ URI.Authority+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing+ <$ guard useSsh+ , URI.authHost = fromRight' $ URI.mkHost "github.com"+ , URI.authPort = Nothing+ }+ , URI.uriPath = Just ( False+ , fromRight' . URI.mkPathPiece <$>+ untagName (_gitHubSource_owner s)+ :| [ untagName (_gitHubSource_repo s) <> ".git" ]+ )+ , URI.uriQuery = []+ , URI.uriFragment = Nothing+ }+ , _gitSource_branch = _gitHubSource_branch s+ , _gitSource_fetchSubmodules = False+ , _gitSource_private = _gitHubSource_private s+ }++commitNameToRef :: Name Commit -> Ref SHA1+commitNameToRef (N c) = refFromHex $ encodeUtf8 c++-- TODO: Use spinner here.+getNixSha256ForUriUnpacked+ :: MonadNixThunk m+ => GitUri+ -> m NixSha256+getNixSha256ForUriUnpacked uri =+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do+ [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]+ pure hash++nixPrefetchGit :: MonadNixThunk m => GitUri -> Text -> Bool -> m NixSha256+nixPrefetchGit uri rev fetchSubmodules =+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do+ out <- readProcessAndLogStderr Debug $ ignoreGitConfig $+ proc nixPrefetchGitPath $ filter (/="")+ [ "--url", T.unpack $ gitUriToText uri+ , "--rev", T.unpack rev+ , if fetchSubmodules then "--fetch-submodules" else ""+ , "--quiet"+ ]++ case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of+ Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out+ Just x -> pure x++data ReadThunkError+ = ReadThunkError_UnrecognizedThunk+ -- ^ A generic error that can happen while reading a thunk.+ | ReadThunkError_UnrecognizedPaths (Maybe ThunkSpec) (NonEmpty FilePath)+ -- ^ The thunk directory has extraneous paths. The 'Maybe' value+ -- indicates whether we have matched the rest of the files to a valid+ -- specification, and if so, which specification it was.+ | ReadThunkError_MissingPaths (NonEmpty FilePath)+ -- ^ The thunk directory has missing paths.+ | ReadThunkError_UnparseablePtr FilePath String+ -- ^ We could not parse the given file as per the thunk specification.+ -- The 'String' is a parser-specific error message.+ | ReadThunkError_FileError FilePath IOError+ -- ^ We encountered an 'IOError' while reading the given file.+ | ReadThunkError_FileDoesNotMatch FilePath Text+ -- ^ We read the given file just fine, but its contents do not match+ -- what was expected for the specification.+ | ReadThunkError_AmbiguousPackedState ThunkSpec ThunkSpec+ -- ^ We parsed two valid thunk specs for this directory.++-- | Pretty-print a 'ReadThunkError' for display to the user+prettyReadThunkError :: ReadThunkError -> Text+prettyReadThunkError =+ \case+ ReadThunkError_UnrecognizedPaths (Just spec) (f :| fs) ->+ -- Limit to five unrecognised paths so that the user doesn't get+ -- utterly spammed:+ T.unlines ( "The directory matched spec " <> _thunkSpec_name spec <> ", but the following file(s) are extraneous:"+ : map ((" " <>) . T.pack) (f:take 4 fs))+ <> if length fs > 5 then "... and " <> T.pack (show (length fs - 4)) <> " others." else mempty++ ReadThunkError_MissingPaths (f :| fs) ->+ T.unlines $ "The following path(s) are missing from the thunk directory:"+ :map ((" " <>) . T.pack) (f:fs)++ ReadThunkError_FileError path ioe -> "I/O error while reading the file " <> T.pack path <> ":\n" <> T.pack (show ioe)+ ReadThunkError_UnparseablePtr path str -> "Syntax error while reading the file " <> T.pack path <> ":\n" <> T.pack str+ ReadThunkError_FileDoesNotMatch path _ -> "The file " <> T.pack path <> " does not have the right contents for this thunk specification."+ ReadThunkError_AmbiguousPackedState speca specb ->+ "The given thunk directory is ambiguous: It matches both " <> _thunkSpec_name speca <> " and " <> _thunkSpec_name specb <> "."++ ReadThunkError_UnrecognizedThunk -> generic+ ReadThunkError_UnrecognizedPaths{} -> generic+ where+ generic = T.pack "The directory did not match any valid thunk specification.\nRun with -v to see why each spec did not match."++-- | Fail due to a 'ReadThunkError' with a standardised error message.+failReadThunkErrorWhile+ :: MonadError NixThunkError m+ => Text+ -- ^ String describing what we were doing.+ -> ReadThunkError -- ^ The error+ -> m a+failReadThunkErrorWhile what rte = failWith $ "Failure reading thunk " <> what <> ":\n" <> prettyReadThunkError rte++-- | Did we manage to match the thunk directory to one or more known+-- thunk specs before raising this error?+didMatchThunkSpec :: ReadThunkError -> Bool+didMatchThunkSpec (ReadThunkError_UnrecognizedPaths x _) = isJust x+didMatchThunkSpec ReadThunkError_AmbiguousPackedState{} = True+didMatchThunkSpec _ = False++unpackedDirName :: FilePath+unpackedDirName = "."++attrCacheFileName :: FilePath+attrCacheFileName = ".attr-cache"++-- | A path from which our known-good nixpkgs can be fetched.+-- __NOTE__: This path is hardcoded, and only exists so subsumed thunk+-- specs (v7 specifically) can be parsed.+pinnedNixpkgsPath :: FilePath+pinnedNixpkgsPath = "/nix/store/qjg458n31xk1l6lj26c3b871d4i4is98-source"++-- | Specification for how a file in a thunk version works.+data ThunkFileSpec+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache++-- | Specification for how a set of files in a thunk version work.+data ThunkSpec = ThunkSpec+ { _thunkSpec_name :: !Text+ , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)+ }++thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)+thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]++-- | Attempts to match a 'ThunkSpec' to a given directory.+matchThunkSpecToDir+ :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)+ => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory+ -> FilePath -- ^ Path to directory+ -> Set FilePath -- ^ Set of file paths relative to the given directory+ -> m ThunkData+matchThunkSpecToDir thunkSpec dir dirFiles = do+ isCheckout <- fmap or $ flip Map.traverseWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath))+ _ -> pure False+ case isCheckout of+ True -> pure ThunkData_Checkout+ False -> do+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath+ ThunkFileSpec_CheckoutIndicator -> pure Nothing -- Handled above+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError expectedPath e) $ do+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)+ case T.strip expectedContents == T.strip actualContents of+ True -> pure Nothing+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError expectedPath e) $ do+ let path = dir </> expectedPath+ liftIO (doesFileExist path) >>= \case+ False -> pure Nothing+ True -> do+ actualContents <- liftIO $ LBS.readFile path+ case parser actualContents of+ Right v -> pure $ Just (thunkSpec, v)+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e+ let matched = thunkSpec <$ nonEmpty datas+ for_ (nonEmpty (toList $ dirFiles `Set.difference` expectedPaths)) $ \fs ->+ throwError $ ReadThunkError_UnrecognizedPaths matched $ (dir </>) <$> fs+ for_ (nonEmpty (toList $ requiredPaths `Set.difference` dirFiles)) $ \fs ->+ throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs++ uncurry ThunkData_Packed <$> case nonEmpty datas of+ Nothing -> throwError ReadThunkError_UnrecognizedThunk+ Just xs -> fold1WithM xs $ \a@(speca, ptrA) (specb, ptrB) ->+ if ptrA == ptrB then pure a else throwError $ ReadThunkError_AmbiguousPackedState speca specb+ where+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath++ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec++ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec+ isRequiredFileSpec = \case+ ThunkFileSpec_FileMatches _ -> True+ _ -> False++ dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case+ True -> throwError $ ReadThunkError_UnrecognizedPaths Nothing $ expectedPath :| []+ False -> pure ()++ fold1WithM (x :| xs) f = foldM f x xs++readThunkWith+ :: (MonadNixThunk m)+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)+readThunkWith specTypes dir = do+ dirFiles <- Set.fromList <$> liftIO (listDirectory dir)+ let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering+ flip fix specs $ \loop -> \case+ [] -> pure $ Left ReadThunkError_UnrecognizedThunk+ spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case+ Left e+ -- If we matched one or more thunk specs, we fail early to tell+ -- the user exactly what's wrong:+ | didMatchThunkSpec e -> pure $ Left e+ -- Otherwise, keep looping:+ | otherwise -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${prettyReadThunkError e}|] *> loop rest+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]++-- | Read a packed or unpacked thunk based on predefined thunk specifications.+readThunk :: (MonadNixThunk m) => FilePath -> m (Either ReadThunkError ThunkData)+readThunk = readThunkWith thunkSpecTypes++parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr+parseThunkPtr parseSrc v = do+ rev <- v Aeson..: "rev"+ sha256 <- v Aeson..: "sha256"+ src <- parseSrc v+ pure $ ThunkPtr+ { _thunkPtr_rev = ThunkRev+ { _thunkRev_commit = refFromHexString rev+ , _thunkRev_nixSha256 = sha256+ }+ , _thunkPtr_source = src+ }++parseGitHubSource :: Aeson.Object -> Aeson.Parser GitHubSource+parseGitHubSource v = do+ owner <- v Aeson..: "owner"+ repo <- v Aeson..: "repo"+ branch <- v Aeson..:! "branch"+ private <- v Aeson..:? "private"+ pure $ GitHubSource+ { _gitHubSource_owner = owner+ , _gitHubSource_repo = repo+ , _gitHubSource_branch = branch+ , _gitHubSource_private = fromMaybe False private+ }++parseGitSource :: Aeson.Object -> Aeson.Parser GitSource+parseGitSource v = do+ Just url <- parseGitUri <$> v Aeson..: "url"+ branch <- v Aeson..:! "branch"+ fetchSubmodules <- v Aeson..:! "fetchSubmodules"+ private <- v Aeson..:? "private"+ pure $ GitSource+ { _gitSource_url = url+ , _gitSource_branch = branch+ , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules+ , _gitSource_private = fromMaybe False private+ }++overwriteThunk :: MonadNixThunk m => FilePath -> ThunkPtr -> m ()+overwriteThunk target thunk = do+ -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)+ readThunk target >>= \case+ Left e -> failReadThunkErrorWhile "while overwriting" e+ Right _ -> pure ()++ --TODO: Is there a safer way to do this overwriting?+ liftIO $ removePathForcibly target+ createThunk target $ Right thunk++thunkPtrToSpec :: ThunkPtr -> ThunkSpec+thunkPtrToSpec thunk = case _thunkPtr_source thunk of+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs++-- It's important that formatting be very consistent here, because+-- otherwise when people update thunks, their patches will be messy+encodeThunkPtrData :: ThunkPtr -> LBS.ByteString+encodeThunkPtrData (ThunkPtr rev src) = case src of+ ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes+ [ Just $ "owner" .= _gitHubSource_owner s+ , Just $ "repo" .= _gitHubSource_repo s+ , ("branch" .=) <$> _gitHubSource_branch s+ , Just $ "rev" .= refToHexString (_thunkRev_commit rev)+ , Just $ "sha256" .= _thunkRev_nixSha256 rev+ , Just $ "private" .= _gitHubSource_private s+ ]+ ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes+ [ Just $ "url" .= gitUriToText (_gitSource_url s)+ , Just $ "rev" .= refToHexString (_thunkRev_commit rev)+ , ("branch" .=) <$> _gitSource_branch s+ , Just $ "sha256" .= _thunkRev_nixSha256 rev+ , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s+ , Just $ "private" .= _gitSource_private s+ ]+ where+ githubCfg = defConfig+ { confIndent = Spaces 2+ , confCompare = keyOrder+ [ "owner"+ , "repo"+ , "branch"+ , "private"+ , "rev"+ , "sha256"+ ] <> compare+ , confTrailingNewline = True+ }+ plainGitCfg = defConfig+ { confIndent = Spaces 2+ , confCompare = keyOrder+ [ "url"+ , "rev"+ , "sha256"+ , "private"+ , "fetchSubmodules"+ ] <> compare+ , confTrailingNewline = True+ }++createThunk' :: MonadNixThunk m => ThunkCreateConfig -> m ()+createThunk' config = do+ newThunkPtr <- thunkCreateSourcePtr+ (_thunkCreateConfig_uri config)+ (_thunkConfig_private $ _thunkCreateConfig_config config)+ (untagName <$> _thunkCreateConfig_branch config)+ (T.pack . show <$> _thunkCreateConfig_rev config)+ let trailingDirectoryName = reverse . takeWhile (/= '/') . dropWhile (=='/') . reverse+ dropDotGit :: FilePath -> FilePath+ dropDotGit origName = fromMaybe origName $ stripExtension "git" origName++ defaultDestinationForGitUri :: GitUri -> FilePath+ defaultDestinationForGitUri = dropDotGit . trailingDirectoryName . T.unpack . URI.render . unGitUri++ destination <- case _thunkCreateConfig_uri config of+ ThunkCreateSource_Absolute uri -> pure $ fromMaybe (defaultDestinationForGitUri uri) $ _thunkCreateConfig_destination config+ ThunkCreateSource_Relative _ -> case _thunkCreateConfig_destination config of+ Nothing -> failWith "When using a relative path as the thunk source, the destination path must be specified."+ Just dst -> pure dst+ createThunk destination $ Right newThunkPtr++createThunk :: MonadNixThunk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()+createThunk target ptrInfo = do+ isdir <- liftIO $ doesDirectoryExist target+ when isdir $ do+ isempty <- null <$> liftIO (listDirectory target)+ unless isempty $ failWith $ "Refusing to create thunk in non-empty directory " <> T.pack target++ ifor_ (_thunkSpec_files spec) $ \path -> \case+ ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content+ ThunkFileSpec_Ptr _ -> case ptrInfo of+ Left _ -> pure () -- We can't write the ptr without it+ Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)+ _ -> pure ()+ where+ spec = either id thunkPtrToSpec ptrInfo+ withReadyPath path f = do+ let fullPath = target </> path+ putLog Debug $ "Writing thunk file " <> T.pack fullPath+ liftIO $ createDirectoryIfMissing True $ takeDirectory fullPath+ f fullPath++updateThunkToLatest :: MonadNixThunk m => ThunkUpdateConfig -> FilePath -> m ()+updateThunkToLatest cfg target = do+ withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do+ checkThunkDirectory target+ readThunk target >>= \case+ Left err -> failReadThunkErrorWhile "during an update" err+ Right c -> case c of+ 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.|]+ ThunkData_Packed _ t -> case _thunkUpdateConfig_ref cfg of+ Just ref -> do+ newThunkPtr <- uriThunkPtr+ (_gitSource_url $ thunkSourceToGitSource $ _thunkPtr_source t)+ (_thunkConfig_private $ _thunkUpdateConfig_thunk cfg)+ (_thunkUpdateConfig_branch cfg)+ (Just ref)+ overwriteThunk target newThunkPtr+ Nothing -> do+ let newSrc :: ThunkSource+ newSrc = case _thunkUpdateConfig_branch cfg of+ Nothing -> _thunkPtr_source t+ Just b -> setThunkSourceBranch (Just $ N b) $ _thunkPtr_source t+ rev <- getLatestRev newSrc+ overwriteThunk target $ modifyThunkPtrByConfig (_thunkUpdateConfig_thunk cfg) $ ThunkPtr+ { _thunkPtr_source = newSrc+ , _thunkPtr_rev = rev+ }++-- | All recognized github standalone loaders, ordered from newest to oldest.+-- This tool will only ever produce the newest one when it writes a thunk.+gitHubThunkSpecs :: NonEmpty ThunkSpec+gitHubThunkSpecs =+ gitHubThunkSpecV8 :|+ [ gitHubThunkSpecV7+ , gitHubThunkSpecV6+ , gitHubThunkSpecV5+ , gitHubThunkSpecV4+ , gitHubThunkSpecV3+ , gitHubThunkSpecV2+ , gitHubThunkSpecV1+ ]++gitHubThunkSpecV1 :: ThunkSpec+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"++gitHubThunkSpecV2 :: ThunkSpec+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines+ [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on NixThunk, etc.+ , "import ((import <nixpkgs> {}).fetchFromGitHub ("+ , " let json = builtins.fromJSON (builtins.readFile ./github.json);"+ , " in { inherit (json) owner repo rev sha256;"+ , " private = json.private or false;"+ , " }"+ , "))"+ ]++gitHubThunkSpecV3 :: ThunkSpec+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines+ [ "# DO NOT HAND-EDIT THIS FILE"+ , "let"+ , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"+ , " then fetchFromGitHubPrivate args"+ , " else (import <nixpkgs> {}).fetchFromGitHub (builtins.removeAttrs args [\"branch\"]);"+ , " fetchFromGitHubPrivate ="+ , " { owner, repo, rev, branch ? null, name ? null, sha256 ? null, private ? false"+ , " , fetchSubmodules ? false, githubBase ? \"github.com\", ..."+ , " }: assert !fetchSubmodules;"+ , " builtins.fetchGit ({"+ , " url = \"ssh://git@${githubBase}/${owner}/${repo}.git\";"+ , " inherit rev;"+ , " }"+ , " // (if branch == null then {} else { ref = branch; })"+ , " // (if name == null then {} else { inherit name; }));"+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"+ ]++gitHubThunkSpecV4 :: ThunkSpec+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines+ [ "# DO NOT HAND-EDIT THIS FILE"+ , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"+ , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"+ , " inherit owner repo rev sha256 fetchSubmodules private;"+ , " };"+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"+ ]++legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec+legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)+ , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)+ , (attrCacheFileName, ThunkFileSpec_AttrCache)+ , (".git", ThunkFileSpec_CheckoutIndicator)+ ]++gitHubThunkSpecV5 :: ThunkSpec+gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|+# DO NOT HAND-EDIT THIS FILE+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:+ if !fetchSubmodules && !private then builtins.fetchTarball {+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;+ } else (import <nixpkgs> {}).fetchFromGitHub {+ inherit owner repo rev sha256 fetchSubmodules private;+ };+ json = builtins.fromJSON (builtins.readFile ./github.json);+in fetch json+|]++-- | See 'gitHubThunkSpecV7'.+--+-- __NOTE__: v6 spec thunks are broken! They import the pinned nixpkgs+-- in an incorrect way. GitHub thunks for public repositories with no+-- submodules will still work, but update as soon as possible.+gitHubThunkSpecV6 :: ThunkSpec+gitHubThunkSpecV6 = mkThunkSpec "github-v6" "github.json" parseGitHubJsonBytes [here|+# DO NOT HAND-EDIT THIS FILE+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:+ if !fetchSubmodules && !private then builtins.fetchTarball {+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;+ } else (builtins.fetchTarball {+ url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";+ sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";+}).fetchFromGitHub {+ inherit owner repo rev sha256 fetchSubmodules private;+ };+ json = builtins.fromJSON (builtins.readFile ./github.json);+in fetch json+|]++-- | Specification for GitHub thunks which use a specific, pinned+-- version of nixpkgs for fetching, rather than using @<nixpkgs>@ from+-- @NIX_PATH@. The "v7" specs ensure that thunks can be fetched even+-- when @NIX_PATH@ is unset.+gitHubThunkSpecV7 :: ThunkSpec+gitHubThunkSpecV7 = mkThunkSpec "github-v7" "github.json" parseGitHubJsonBytes [i|# DO NOT HAND-EDIT THIS FILE+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:+ if !fetchSubmodules && !private then builtins.fetchTarball {+ url = "https://github.com/\${owner}/\${repo}/archive/\${rev}.tar.gz"; inherit sha256;+ } else (import ${pinnedNixpkgsPath} {}).fetchFromGitHub {+ inherit owner repo rev sha256 fetchSubmodules private;+ };+ json = builtins.fromJSON (builtins.readFile ./github.json);+in fetch json|]++-- | Specification for GitHub thunks which use a specific, pinned+-- version of nixpkgs for fetching, rather than using @<nixpkgs>@ from+-- @NIX_PATH@.+--+-- Unlike 'gitHubThunKSpecV7', this thunk specification fetches the+-- nixpkgs tarball from GitHub, so it will fail on environments without+-- a network connection.+gitHubThunkSpecV8 :: ThunkSpec+gitHubThunkSpecV8 = mkThunkSpec "github-v8" "github.json" parseGitHubJsonBytes [here|+# DO NOT HAND-EDIT THIS FILE+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:+ if !fetchSubmodules && !private then builtins.fetchTarball {+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;+ } else (import (builtins.fetchTarball {+ url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";+ sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";+}) {}).fetchFromGitHub {+ inherit owner repo rev sha256 fetchSubmodules private;+ };+ json = builtins.fromJSON (builtins.readFile ./github.json);+in fetch json+|]++parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr+parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->+ ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v++gitThunkSpecs :: NonEmpty ThunkSpec+gitThunkSpecs =+ gitThunkSpecV9 :|+ [ gitThunkSpecV8+ , gitThunkSpecV7+ , gitThunkSpecV6+ , gitThunkSpecV5+ , gitThunkSpecV4+ , gitThunkSpecV3+ , gitThunkSpecV2+ , gitThunkSpecV1+ ]++gitThunkSpecV1 :: ThunkSpec+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines+ [ "# DO NOT HAND-EDIT THIS FILE"+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"+ , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"+ ]++gitThunkSpecV2 :: ThunkSpec+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines+ [ "# DO NOT HAND-EDIT THIS FILE"+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"+ , " if builtins.hasAttr \"fetchGit\" builtins"+ , " then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"+ , " else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"+ ]++-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@+-- and will fail to find commits without this because it does shallow clones.+gitThunkSpecV3 :: ThunkSpec+gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines+ [ "# DO NOT HAND-EDIT THIS FILE"+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"+ , " if firstChar == \"/\" then /. + url"+ , " else if firstChar == \".\" then ./. + url"+ , " else url;"+ , " in if !fetchSubmodules && private then builtins.fetchGit {"+ , " url = realUrl; inherit rev;"+ , " } else (import <nixpkgs> {}).fetchgit {"+ , " url = realUrl; inherit rev sha256;"+ , " };"+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"+ ]++gitThunkSpecV4 :: ThunkSpec+gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines+ [ "# DO NOT HAND-EDIT THIS FILE"+ , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"+ , " if firstChar == \"/\" then /. + url"+ , " else if firstChar == \".\" then ./. + url"+ , " else url;"+ , " in if !fetchSubmodules && private then builtins.fetchGit {"+ , " url = realUrl; inherit rev;"+ , " ${if branch == null then null else \"ref\"} = branch;"+ , " } else (import <nixpkgs> {}).fetchgit {"+ , " url = realUrl; inherit rev sha256;"+ , " };"+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"+ ]++legacyGitThunkSpec :: Text -> Text -> ThunkSpec+legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)+ , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)+ , (attrCacheFileName, ThunkFileSpec_AttrCache)+ , (".git", ThunkFileSpec_CheckoutIndicator)+ ]++gitThunkSpecV5 :: ThunkSpec+gitThunkSpecV5 = mkThunkSpec "git-v5" "git.json" parseGitJsonBytes [here|+# DO NOT HAND-EDIT THIS FILE+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:+ let realUrl = let firstChar = builtins.substring 0 1 url; in+ if firstChar == "/" then /. + url+ else if firstChar == "." then ./. + url+ else url;+ in if !fetchSubmodules && private then builtins.fetchGit {+ url = realUrl; inherit rev;+ ${if branch == null then null else "ref"} = branch;+ } else (import <nixpkgs> {}).fetchgit {+ url = realUrl; inherit rev sha256;+ };+ json = builtins.fromJSON (builtins.readFile ./git.json);+in fetch json+|]++-- | See 'gitThunkSpecV7'.+-- __NOTE__: v6 spec thunks are broken! They import the pinned nixpkgs+-- in an incorrect way. GitHub thunks for public repositories with no+-- submodules will still work, but update as soon as possible.+gitThunkSpecV6 :: ThunkSpec+gitThunkSpecV6 = mkThunkSpec "git-v6" "git.json" parseGitJsonBytes [here|+# DO NOT HAND-EDIT THIS FILE+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:+ let realUrl = let firstChar = builtins.substring 0 1 url; in+ if firstChar == "/" then /. + url+ else if firstChar == "." then ./. + url+ else url;+ in if !fetchSubmodules && private then builtins.fetchGit {+ url = realUrl; inherit rev;+ ${if branch == null then null else "ref"} = branch;+ } else (builtins.fetchTarball {+ url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";+ sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";+}).fetchgit {+ url = realUrl; inherit rev sha256;+ };+ json = builtins.fromJSON (builtins.readFile ./git.json);+in fetch json+|]++-- | Specification for Git thunks which use a specific, pinned version+-- of nixpkgs for fetching, rather than using @<nixpkgs>@ from+-- @NIX_PATH@. The "v7" specs ensure that thunks can be fetched even+-- when @NIX_PATH@ is unset.+gitThunkSpecV7 :: ThunkSpec+gitThunkSpecV7 = mkThunkSpec "git-v7" "git.json" parseGitJsonBytes [i|# DO NOT HAND-EDIT THIS FILE+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:+ let realUrl = let firstChar = builtins.substring 0 1 url; in+ if firstChar == "/" then /. + url+ else if firstChar == "." then ./. + url+ else url;+ in if !fetchSubmodules && private then builtins.fetchGit {+ url = realUrl; inherit rev;+ \${if branch == null then null else "ref"} = branch;+ } else (import ${pinnedNixpkgsPath} {}).fetchgit {+ url = realUrl; inherit rev sha256;+ };+ json = builtins.fromJSON (builtins.readFile ./git.json);+in fetch json|]++-- | Specification for Git thunks which use a specific, pinned version+-- version of nixpkgs for fetching, rather than using @<nixpkgs>@ from+-- @NIX_PATH@.+--+-- Unlike 'gitHubThunKSpecV7', this thunk specification fetches the+-- nixpkgs tarball from GitHub, so it will fail on environments without+-- a network connection.+gitThunkSpecV8 :: ThunkSpec+gitThunkSpecV8 = mkThunkSpec "git-v8" "git.json" parseGitJsonBytes [i|# DO NOT HAND-EDIT THIS FILE+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:+ let realUrl = let firstChar = builtins.substring 0 1 url; in+ if firstChar == "/" then /. + url+ else if firstChar == "." then ./. + url+ else url;+ in if !fetchSubmodules && private then builtins.fetchGit {+ url = realUrl; inherit rev;+ \${if branch == null then null else "ref"} = branch;+ } else (import (builtins.fetchTarball {+ url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";+ sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";+}) {}).fetchgit {+ url = realUrl; inherit rev sha256;+ };+ json = builtins.fromJSON (builtins.readFile ./git.json);+in fetch json|]++-- | Improves V8 by supporting retrieving revs from any branch, when a branch is not provided+-- Previously, it would only work for revs that were present on the default branch+gitThunkSpecV9 :: ThunkSpec+gitThunkSpecV9 = mkThunkSpec "git-v9" "git.json" parseGitHubJsonBytes [here|+# DO NOT HAND-EDIT THIS FILE+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:+ let realUrl = let firstChar = builtins.substring 0 1 url; in+ if firstChar == "/" then /. + url+ else if firstChar == "." then ./. + url+ else url;+ in if !fetchSubmodules && private then builtins.fetchGit {+ url = realUrl; inherit rev;+ ${if branch == null then null else "ref"} = branch;+ allRefs = branch == null;+ } else (import (builtins.fetchTarball {+ url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";+ sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";+ }) {}).fetchgit {+ url = realUrl; inherit rev sha256;+ };+ json = builtins.fromJSON (builtins.readFile ./git.json);+in fetch json+|]++parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr+parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource++mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec+mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList+ [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)+ , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)+ , (jsonFileName, ThunkFileSpec_Ptr parser)+ , (attrCacheFileName, ThunkFileSpec_AttrCache)+ , (normalise $ unpackedDirName </> ".git", ThunkFileSpec_CheckoutIndicator)+ ]+ where+ defaultNixViaSrc = [here|+# DO NOT HAND-EDIT THIS FILE+import (import ./thunk.nix)+|]+++parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a+parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes++-- | Checks a cache directory to see if there is a fresh symlink+-- to the result of building an attribute of a thunk.+-- If no cache hit is found, nix-build is called to build the attribute+-- and the result is symlinked into the cache.+nixBuildThunkAttrWithCache+ :: ( MonadIO m+ , MonadLog Output m+ , HasCliConfig NixThunkError m+ , MonadMask m+ , MonadError NixThunkError m+ , MonadFail m+ )+ => ThunkSpec+ -> FilePath+ -- ^ Path to directory containing Thunk+ -> String+ -- ^ Attribute to build+ -> m (Maybe FilePath)+ -- ^ Symlink to cached or built nix output+-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'+-- the caching mechanism will fail as it merely measures the modification+-- time of the cache link and the expression to build.+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do+ latestChange <- liftIO $ do+ let+ getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime+ thunkFileNames = L.delete attrCacheFileName $ Map.keys $ _thunkSpec_files thunkSpec+ maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames++ let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $+ _thunkSpec_files thunkSpec+ for cachePaths' $ \cachePaths ->+ fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do+ let+ cachePath = thunkDir </> cacheDir </> attr <.> "out"+ cacheErrHandler e+ | isDoesNotExistError e = pure Nothing -- expected from a cache miss+ | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)+ cacheHit <- handle cacheErrHandler $ do+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath+ pure $ if latestChange <= cacheTime+ then Just cachePath+ else Nothing+ case cacheHit of+ Just c -> pure c+ Nothing -> do+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]+ liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)+ (cachePath <$) $ nixCmd $ NixCmd_Build $ def+ & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath+ & nixCmdConfig_target .~ Target+ { _target_path = Just thunkDir+ , _target_attr = Just attr+ , _target_expr = Nothing+ }++-- | Build a nix attribute, and cache the result if possible+nixBuildAttrWithCache+ :: ( MonadLog Output m+ , HasCliConfig NixThunkError m+ , MonadIO m+ , MonadMask m+ , MonadError NixThunkError m+ , MonadFail m+ )+ => FilePath+ -- ^ Path to directory containing Thunk+ -> String+ -- ^ Attribute to build+ -> m FilePath+ -- ^ Symlink to cached or built nix output+nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case+ -- Only packed thunks are cached. In particular, checkouts are not.+ Right (ThunkData_Packed spec _) ->+ maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr+ _ -> build+ where+ build = nixCmd $ NixCmd_Build $ def+ & nixBuildConfig_outLink .~ OutLink_None+ & nixCmdConfig_target .~ Target+ { _target_path = Just exprPath+ , _target_attr = Just attr+ , _target_expr = Nothing+ }++-- | Safely update thunk using a custom action+--+-- A temporary working space is used to do any update. When the custom+-- action successfully completes, the resulting (packed) thunk is copied+-- back to the original location.+updateThunk :: MonadNixThunk m => FilePath -> (FilePath -> m a) -> m a+updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do+ p' <- copyThunkToTmp tmpDir p+ unpackThunk' True p'+ result <- f p'+ updateThunkFromTmp p'+ return result+ where+ copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case+ Left err -> failReadThunkErrorWhile "during an update" err+ Right ThunkData_Packed{} -> do+ let tmpThunk = tmpDir </> "thunk"+ callProcessAndLogOutput (Notice, Error) $+ proc cp ["-r", "-T", thunkDir, tmpThunk]+ return tmpThunk+ Right _ -> failWith "Thunk is not packed"+ updateThunkFromTmp p' = do+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'+ callProcessAndLogOutput (Notice, Error) $+ proc cp ["-r", "-T", p', p]++finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)+finalMsg noTrail s = if noTrail then Nothing else Just s++-- | Check that we are not somewhere inside the thunk directory+checkThunkDirectory :: MonadNixThunk m => FilePath -> m ()+checkThunkDirectory thunkDir = do+ currentDir <- liftIO getCurrentDirectory+ thunkDir' <- liftIO $ canonicalizePath thunkDir+ when (thunkDir' `L.isInfixOf` currentDir) $+ failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]++ -- Don't let thunk commands work when directly given an unpacked repo+ when (takeFileName thunkDir == unpackedDirName) $+ readThunk (takeDirectory thunkDir) >>= \case+ Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]+ Left _ -> pure ()++unpackThunk :: MonadNixThunk m => FilePath -> m ()+unpackThunk = unpackThunk' False++unpackThunk' :: MonadNixThunk m => Bool -> FilePath -> m ()+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case+ Left err -> failReadThunkErrorWhile "while unpacking" err+ --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]+ Right (ThunkData_Packed _ tptr) -> do+ let (thunkParent, thunkName) = splitFileName thunkDir+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do+ let+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr+ newSpec = case _thunkPtr_source tptr of+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs+ withSpinner' ("Fetching thunk " <> T.pack thunkName)+ (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do+ let unpackedPath = tmpThunk </> unpackedDirName+ gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath++ let normalizeMore = dropTrailingPathSeparator . normalise+ when (normalizeMore unpackedPath /= normalizeMore tmpThunk) $ -- Only write meta data if the checkout is not inplace+ createThunk tmpThunk $ Left newSpec++ liftIO $ do+ removePathForcibly thunkDir+ renameDirectory tmpThunk thunkDir++gitCloneForThunkUnpack+ :: MonadNixThunk m+ => GitSource -- ^ Git source to use+ -> Ref hash -- ^ Commit hash to reset to+ -> FilePath -- ^ Directory to clone into+ -> m ()+gitCloneForThunkUnpack gitSrc commit dir = do+ _ <- readGitProcess dir $ [ "clone" ]+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc+ [ "--branch", T.unpack $ untagName branch ]+ _ <- readGitProcess dir ["reset", "--hard", refToHexString commit]+ when (_gitSource_fetchSubmodules gitSrc) $+ void $ readGitProcess dir ["submodule", "update", "--recursive", "--init"]++createWorktree :: MonadNixThunk m => FilePath -> FilePath -> CreateWorktreeConfig -> m ()+createWorktree thunkDir gitDir config = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case+ Left err -> failReadThunkErrorWhile "while creating worktree" err+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]+ Right (ThunkData_Packed _ tptr) -> do++ ensureGitRevExist gitDir tptr++ let (thunkParent, thunkName) = splitFileName thunkDir+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do+ withSpinner' ("Creating worktree for " <> T.pack thunkName)+ (Just (const $ "Created worktree for " <> T.pack thunkName)) $ do+ currentDir <- liftIO getCurrentDirectory+ let worktreePath = currentDir </> tmpThunk </> unpackedDirName+ thunkFullPath = currentDir </> thunkDir </> unpackedDirName++ -- Create a new branch with the user specified name if provided+ -- else fallback to the branch specified in thunk+ -- If a local branch already exists in gitDir, the worktree creation will fail+ -- In which case the user should specify an alternate branch or use "-d"+ mBranchName = case _createWorktreeConfig_branch config of+ Just b -> Just b+ _ -> T.unpack . untagName <$> _gitSource_branch (thunkSourceToGitSource $ _thunkPtr_source tptr)++ _ <- readGitProcess gitDir $+ [ "worktree", "add"+ , worktreePath+ , refToHexString (_thunkRev_commit $ _thunkPtr_rev tptr)+ ] ++ (if _createWorktreeConfig_detach config+ then ["-d"]+ else maybe [] (\b -> ["-b", b]) mBranchName)++ liftIO $ removePathForcibly thunkDir++ _ <- readGitProcess gitDir+ [ "worktree", "move"+ , normalise worktreePath+ , normalise thunkFullPath]+ pure ()++-- | Ensures that the git repo contains the revision specified in the ThunkPtr+-- by doing fetch from remote if necessary.+ensureGitRevExist :: MonadNixThunk m => FilePath -> ThunkPtr -> m ()+ensureGitRevExist gitDir tptr = do+ isdir <- liftIO $ doesDirectoryExist gitDir+ -- check .git+ unless isdir $ failWith $ "Git directory does not exist: " <> T.pack gitDir++ (exitCode, _, _) <- readCreateProcessWithExitCode $+ gitProc gitDir+ [ "reflog"+ , "exists"+ , refToHexString (_thunkRev_commit $ _thunkPtr_rev tptr)+ ]++ when (exitCode /= ExitSuccess) $ do+ void $ readGitProcess gitDir+ [ "fetch"+ , T.unpack $ gitUriToText (_gitSource_url $ thunkSourceToGitSource $ _thunkPtr_source tptr)+ , refToHexString (_thunkRev_commit $ _thunkPtr_rev tptr)+ ]+++-- | Read a git process ignoring the global configuration (according to 'ignoreGitConfig').+readGitProcess :: MonadNixThunk m => FilePath -> [String] -> m Text+readGitProcess dir = readProcessAndLogOutput (Notice, Notice) . ignoreGitConfig . gitProc dir++-- | Prevent the called process from reading Git configuration. This+-- isn't as locked-down as 'isolateGitProc' to make sure the Git process+-- can still interact with the user (e.g. @ssh-askpass@), but it still+-- ignores enough of the configuration to ensure that thunks are+-- reproducible.+ignoreGitConfig :: ProcessSpec -> ProcessSpec+ignoreGitConfig = setEnvOverride (envfix <>)+ where+ -- Ignore both global (user's) and system (... system-wide) git+ -- configuration.+ envfix = Map.fromList+ [ ("GIT_CONFIG_NOSYSTEM", "yes")+ -- Git documentation says GIT_CONFIG_GLOBAL=/dev/null should+ -- prevent it from reading the global config file but that's a+ -- lie, actually.+ , ("HOME", "/dev/null")+ , ("XDG_CONFIG_HOME", "/dev/null")+ ]++--TODO: add a rollback mode to pack to the original thunk+packThunk :: MonadNixThunk m => ThunkPackConfig -> FilePath -> m ThunkPtr+packThunk = packThunk' False++packThunk' :: MonadNixThunk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]+ _ -> withSpinner'+ ("Packing thunk " <> T.pack thunkDir)+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $+ do+ let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck+ (thunkPtr, isWorktree) <- first (modifyThunkPtrByConfig thunkConfig)+ <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)+ if isWorktree+ then void $ do+ -- Remove the branch locally, and then remove the worktree+ case _gitSource_branch $ thunkSourceToGitSource $ _thunkPtr_source thunkPtr of+ Just branch -> do+ void $ readGitProcess thunkDir ["switch", "--detach"]+ void $ readGitProcess thunkDir ["branch", "-d", T.unpack $ untagName branch]+ Nothing -> pure () -- Should never happen+ readGitProcess thunkDir ["worktree", "remove", "."]+ else liftIO $ removePathForcibly thunkDir+ createThunk thunkDir $ Right thunkPtr+ pure thunkPtr++modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of+ Nothing -> ptr+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }+ }++data CheckClean+ = CheckClean_FullCheck+ -- ^ Check that the repo is clean, including .gitignored files+ | CheckClean_NotIgnored+ -- ^ Check that the repo is clean, not including .gitignored files+ | CheckClean_NoCheck+ -- ^ Don't check that the repo is clean++getThunkPtr :: forall m. MonadNixThunk m => CheckClean -> FilePath -> Maybe Bool -> m (ThunkPtr, Bool)+getThunkPtr gitCheckClean dir mPrivate = do+ let repoLocations = nubOrd $ map (first normalise)+ [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]+ repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst+ (thunkDir, isWorktree) <- case repoLocation' of+ Nothing -> do+ ff <- liftIO $ flip findM repoLocations $ doesFileExist . (dir </>) . fst+ case ff of+ Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]+ Just (gitPath, path) -> do+ putLog Informational "Couldn't find .git dir, looking for a worktree instead"+ fileContents <- liftIO $ T.readFile (dir </> gitPath)+ unless (T.isPrefixOf "gitdir: " fileContents) $ failWith [i|Can't find an unpacked thunk or worktree in ${dir}|]+ pure (normalise $ dir </> path, True)+ Just (_, path) -> pure (normalise $ dir </> path, False)++ let (checkClean, checkIgnored) = case gitCheckClean of+ CheckClean_FullCheck -> (True, True)+ CheckClean_NotIgnored -> (True, False)+ CheckClean_NoCheck -> (False, False)+ when checkClean $ ensureCleanGitRepo thunkDir checkIgnored+ "thunk pack: thunk checkout contains unsaved modifications"++ -- Check whether there are any stashes+ when (checkClean && not isWorktree) $ do+ stashOutput <- readGitProcess thunkDir ["stash", "list"]+ unless (T.null stashOutput) $+ failWith $ T.unlines $+ [ "thunk pack: thunk checkout has stashes"+ , "git stash list:"+ ] ++ T.lines stashOutput++ -- Get current branch+ (mCurrentBranch, mCurrentCommit) <- do+ b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]+ c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]+ case b of+ (Just "HEAD") -> failWith $ T.unlines+ [ "thunk pack: You are in 'detached HEAD' state."+ , "If you want to pack at the current ref \+ \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."+ ]+ _ -> return (b, c)++ let refs = if isWorktree+ -- Get information on current branch only+ then "refs/heads/" <> maybe "" T.unpack mCurrentBranch+ -- Get information on all branches and their (optional) designated+ -- upstream correspondents+ else "refs/heads/"+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir+ [ "for-each-ref"+ , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"+ , refs+ ]++ (headInfo :: Map Text (Maybe (Text, Text)))+ <- fmap Map.fromList $ forM headDump $ \line -> do+ (branch : restOfLine) <- pure $ T.words line+ mUpstream <- case restOfLine of+ [] -> pure Nothing+ [u, r] -> pure $ Just (u, r)+ (_:_) -> failWith "git for-each-ref invalid output"+ pure (branch, mUpstream)++ putLog Debug $ "branches: " <> T.pack (show headInfo)++ let errorMap :: Map Text ()+ headUpstream :: Map Text (Text, Text)+ (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case+ Nothing -> Left ()+ Just b -> Right b++ putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)++ -- Check that every branch has a remote equivalent+ when checkClean $ do+ let untrackedBranches = Map.keys errorMap+ when (not $ L.null untrackedBranches) $ failWith $ T.unlines $+ [ "thunk pack: Certain branches in the thunk have no upstream branch \+ \set. This means we don't know to check whether all your work is \+ \saved. The offending branches are:"+ , ""+ , T.unwords untrackedBranches+ , ""+ , "To fix this, you probably want to do:"+ , ""+ ] +++ ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) +++ [ ""+ , "These will push the branches to the default remote under the same \+ \name, and (thanks to the `-u`) remember that choice so you don't \+ \get this error again."+ ]++ -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do+ (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir+ [ "rev-list", "--left-right"+ , T.unpack branch <> "..." <> T.unpack upstream+ ]+ let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]+ behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]+ pure (upstream, (ahead, behind))++ -- Those branches which have commits ahead of, i.e. not on, the upstream+ -- branch. Purely being behind is fine.+ let nonGood = Map.filter ((/= 0) . fst . snd) stats++ when (not $ Map.null nonGood) $ failWith $ T.unlines $ mconcat+ [ [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"+ , ""+ ]+ , [ " " <> branch <> " ahead: " <> T.pack (show ahead) <> " behind: " <> T.pack (show behind) <> " remote branch " <> upstream+ | (branch, (upstream, (ahead, behind))) <- Map.toList nonGood+ ]+ , [ ""+ , "Please push these upstream and try again. (Or just fetch, if they are somehow \+ \pushed but this repo's remote tracking branches don't know it.)"+ ]+ ]++ when checkClean $ do+ -- We assume it's safe to pack the thunk at this point+ putLog Informational "All changes safe in git remotes. OK to pack thunk."++ let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch++ [remoteUri'] <- T.lines <$> readGitProcess thunkDir+ [ "config"+ , "--get"+ , "remote." <> T.unpack remote <> ".url"+ ]++ remoteUri <- case parseGitUri remoteUri' of+ Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'+ Just uri -> pure uri+ (, isWorktree) <$> uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit++-- | Get the latest revision available from the given source+getLatestRev :: MonadNixThunk m => ThunkSource -> m ThunkRev+getLatestRev os = do+ let gitS = thunkSourceToGitSource os+ (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)+ getThunkRev os commit++-- | Convert a URI to a thunk+--+-- If the URL is a github URL, we try to just download an archive for+-- performance. If that doesn't work (e.g. authentication issue), we fall back+-- on just doing things the normal way for git repos in general, and save it as+-- a regular git thunk.+uriThunkPtr :: MonadNixThunk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr+uriThunkPtr uri mPrivate mbranch mcommit = do+ commit <- case mcommit of+ Nothing -> snd <$> gitGetCommitBranch uri mbranch+ (Just c) -> return c+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case+ ThunkSource_GitHub s -> do+ rev <- runExceptT $ githubThunkRev s commit+ case rev of+ Right r -> pure (ThunkSource_GitHub s, r)+ Left e -> do+ putLog Warning "\+\Failed to fetch archive from GitHub. This is probably a private repo. \+\Falling back on normal fetchgit. Original failure:"+ putLog Warning $ prettyNixThunkError e+ let s' = forgetGithub True s+ (,) (ThunkSource_Git s') <$> gitThunkRev s' commit+ ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit+ pure $ ThunkPtr+ { _thunkPtr_rev = rev+ , _thunkPtr_source = src+ }++-- | Convert a 'ThunkCreateSource` to a 'ThunkPtr'.+thunkCreateSourcePtr+ :: MonadNixThunk m+ => ThunkCreateSource -- ^ Where is the repository?+ -> Maybe Bool -- ^ Is it private?+ -> Maybe Text -- ^ Shall we fetch a specific branch?+ -> Maybe Text -- ^ Shall we check out a specific commit?+ -> m ThunkPtr+thunkCreateSourcePtr source mPriv mBranch mCommit = do+ uri <- case source of+ ThunkCreateSource_Absolute uri -> pure uri+ ThunkCreateSource_Relative dir -> do+ isdir <- liftIO $ doesDirectoryExist dir+ if isdir+ then do+ absolute <- liftIO $ makeAbsolute dir+ pure $ fromMaybe (error "parsing a file:// URI should never fail") $+ parseGitUri ("file://" <> T.pack absolute)+ else failWith $ "Path does not refer to a directory: " <> T.pack dir+ uriThunkPtr uri mPriv mBranch mCommit++-- | N.B. Cannot infer all fields.+--+-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with+-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method+-- should be employed, and so we respect that.+uriToThunkSource :: MonadNixThunk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource+uriToThunkSource (GitUri u) mPrivate+ | Right uriAuth <- URI.uriAuthority u+ , Just scheme <- URI.unRText <$> URI.uriScheme u+ , case scheme of+ "ssh" -> uriAuth == URI.Authority+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing+ , URI.authHost = fromRight' $ URI.mkHost "github.com"+ , URI.authPort = Nothing+ }+ s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"+ && URI.unRText (URI.authHost uriAuth) == "github.com"+ , Just (_, owner :| [repoish]) <- URI.uriPath u+ = \mbranch -> do+ isPrivate <- getIsPrivate+ pure $ ThunkSource_GitHub $ GitHubSource+ { _gitHubSource_owner = N $ URI.unRText owner+ , _gitHubSource_repo = N $ let+ repoish' = URI.unRText repoish+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'+ , _gitHubSource_branch = N <$> mbranch+ , _gitHubSource_private = isPrivate+ }++ | otherwise = \mbranch -> do+ isPrivate <- getIsPrivate+ pure $ ThunkSource_Git $ GitSource+ { _gitSource_url = GitUri u+ , _gitSource_branch = N <$> mbranch+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?+ , _gitSource_private = isPrivate+ }+ where+ getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate++guessGitRepoIsPrivate :: MonadNixThunk m => GitUri -> m Bool+guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case+ [] -> pure True+ uriAttempt:xs -> do+ result <- readCreateProcessWithExitCode $+ isolateGitProc $+ gitProcNoRepo+ [ "ls-remote"+ , "--quiet"+ , "--exit-code"+ , "--symref"+ , T.unpack $ gitUriToText uriAttempt+ ]+ case result of+ (ExitSuccess, _, _) -> pure False -- Must be a public repo+ _ -> loop xs+ where+ urisToTry = nubOrd $+ -- Include the original URI if it isn't using SSH because SSH will certainly fail.+ [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>+ [changeScheme "https" uri, changeScheme "http" uri]+ changeScheme scheme (GitUri u) = GitUri $ u+ { URI.uriScheme = URI.mkScheme scheme+ , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u+ }++getThunkRev+ :: forall m+ . MonadNixThunk m+ => ThunkSource+ -> Text+ -> m ThunkRev+getThunkRev os commit = case os of+ ThunkSource_GitHub s -> githubThunkRev s commit+ ThunkSource_Git s -> gitThunkRev s commit++-- Funny signature indicates no effects depend on the optional branch name.+githubThunkRev+ :: forall m+ . MonadNixThunk m+ => GitHubSource+ -> Text+ -> m ThunkRev+githubThunkRev s commit = do+ owner <- forcePP $ _gitHubSource_owner s+ repo <- forcePP $ _gitHubSource_repo s+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"+ let archiveUri = GitUri $ URI.URI+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"+ , URI.uriAuthority = Right $ URI.Authority+ { URI.authUserInfo = Nothing+ , URI.authHost = fromRight' $ URI.mkHost "github.com"+ , URI.authPort = Nothing+ }+ , URI.uriPath = Just ( False+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]+ )+ , URI.uriQuery = []+ , URI.uriFragment = Nothing+ }+ hash <- getNixSha256ForUriUnpacked archiveUri+ putLog Debug $ "Nix sha256 is " <> hash+ return $ ThunkRev+ { _thunkRev_commit = commitNameToRef $ N commit+ , _thunkRev_nixSha256 = hash+ }+ where+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)+ forcePP = URI.mkPathPiece . untagName++gitThunkRev+ :: MonadNixThunk m+ => GitSource+ -> Text+ -> m ThunkRev+gitThunkRev s commit = do+ let u = _gitSource_url s+ protocols = ["file", "https", "ssh", "git"]+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u+ unless (T.toLower scheme `elem` protocols) $+ failWith $ "obelisk currently only supports "+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"+ hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s+ putLog Informational $ "Nix sha256 is " <> hash+ pure $ ThunkRev+ { _thunkRev_commit = commitNameToRef (N commit)+ , _thunkRev_nixSha256 = hash+ }++-- | Given the URI to a git remote, and an optional branch name, return the name+-- of the branch along with the hash of the commit at tip of that branch.+--+-- If the branch name is passed in, it is returned exactly as-is. If it is not+-- passed it, the default branch of the repo is used instead.++gitGetCommitBranch+ :: MonadNixThunk m => GitUri -> Maybe Text -> m (Text, CommitId)+gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do+ (_, bothMaps) <- gitLsRemote+ (T.unpack $ gitUriToText uri)+ (GitRef_Branch <$> mbranch)+ Nothing+ branch <- case mbranch of+ Nothing -> withExitFailMessage "Failed to find default branch" $ do+ b <- rethrowE $ gitLookupDefaultBranch bothMaps+ putLog Debug $ "Default branch for remote repo " <> uriMsg <> " is " <> b+ pure b+ Just b -> pure b+ commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)+ putLog Informational $ "Latest commit in branch " <> branch+ <> " from remote repo " <> uriMsg+ <> " is " <> commit+ pure (branch, commit)+ where+ rethrowE = either failWith pure+ uriMsg = gitUriToText uri++parseGitUri :: Text -> Maybe GitUri+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)++parseFileURI :: Text -> Maybe URI.URI+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing++parseAbsoluteURI :: Text -> Maybe URI.URI+parseAbsoluteURI uri = do+ parsedUri <- URI.mkURI uri+ guard $ URI.isPathAbsolute parsedUri+ pure parsedUri++parseSshShorthand :: Text -> Maybe URI.URI+parseSshShorthand uri = do+ -- This is what git does to check that the remote+ -- is not a local file path when parsing shorthand.+ -- Last referenced from here:+ -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712+ let+ (authAndHostname, colonAndPath) = T.break (== ':') uri+ properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath+ -- Shorthand is valid iff a colon is present and it occurs before the first slash+ -- This check is used to disambiguate a filepath containing a colon from shorthand+ guard $ isNothing (T.findIndex (=='/') authAndHostname)+ && not (T.null colonAndPath)+ URI.mkURI properUri++-- The following code has been adapted from the 'Data.Git.Ref',+-- which is apparently no longer maintained++-- | Represent a git reference (SHA1)+newtype Ref hash = Ref { unRef :: Digest hash }+ deriving (Eq, Ord, Typeable)++-- | Invalid Reference exception raised when+-- using something that is not a ref as a ref.+newtype RefInvalid = RefInvalid { unRefInvalid :: ByteString }+ deriving (Show, Eq, Data, Typeable)++instance Exception RefInvalid++refFromHexString :: HashAlgorithm hash => String -> Ref hash+refFromHexString = refFromHex . BSC.pack++refFromHex :: HashAlgorithm hash => BSC.ByteString -> Ref hash+refFromHex s =+ case convertFromBase Base16 s :: Either String ByteString of+ Left _ -> throw $ RefInvalid s+ Right h -> case digestFromByteString h of+ Nothing -> throw $ RefInvalid s+ Just d -> Ref d++-- | transform a ref into an hexadecimal string+refToHexString :: Ref hash -> String+refToHexString (Ref d) = show d++instance Show (Ref hash) where+ show (Ref bs) = BSC.unpack $ convertToBase Base16 bs