diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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..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 ``, 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,112 @@ +nix-thunk +========= +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/nix-thunk.svg)](https://hackage.haskell.org/package/nix-thunk) [![Github CI](https://github.com/obsidiansystems/nix-thunk/workflows/github-action/badge.svg)](https://github.com/obsidiansystems/nix-thunk/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](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 ``), `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 }/path/to/subfolder" ]; +} +``` +becomes +``` +{ + imports = [ "${nix-thunk.thunkSource }/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) + +*** + +![Obsidian Systems](https://obsidian.systems/static/images/ObsidianSystemsLogo.svg) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/nix-thunk.cabal b/nix-thunk.cabal new file mode 100644 --- /dev/null +++ b/nix-thunk.cabal @@ -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 diff --git a/src-bin/nix-thunk.hs b/src-bin/nix-thunk.hs new file mode 100644 --- /dev/null +++ b/src-bin/nix-thunk.hs @@ -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 diff --git a/src/Nix/Thunk.hs b/src/Nix/Thunk.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Thunk.hs @@ -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 diff --git a/src/Nix/Thunk/Command.hs b/src/Nix/Thunk/Command.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Thunk/Command.hs @@ -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 diff --git a/src/Nix/Thunk/Internal.hs b/src/Nix/Thunk/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Thunk/Internal.hs @@ -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 {}).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 {}).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 {}).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 {}).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 {}).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 @@ 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 @@ 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 {}).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 {}).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 {}).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 {}).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 @@ 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 @@ 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 '' +-- 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 ' 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