diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# Revision history for nix-thunk + +## 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/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,66 @@ +cabal-version: >=1.10 +name: nix-thunk +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +copyright: Obsidian Systems LLC 2020 +maintainer: maintainer@obsidian.systems +author: Obsidian Systems LLC +bug-reports: https://github.com/obsidiansystems/nix-thunk +synopsis: Virtual vendorization with Nix +description: + nix-thunk lets you manage source code depencies 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 + +library + exposed-modules: + Nix.Thunk + Nix.Thunk.Command + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + aeson >=1.4.4.0 && <1.5, + aeson-pretty >=0.8.7 && <0.9, + base >=4.12.0.0 && <4.13, + bytestring >=0.10.8.2 && <0.11, + cli-extras >=0.1.0.0 && <0.2, + cli-git >=0.1.0.0 && <0.2, + cli-nix >=0.1.0.0 && <0.2, + containers >=0.6.0.1 && <0.7, + data-default >=0.7.1.1 && <0.8, + 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.7, + filepath >=1.4.2.1 && <1.5, + git >=0.3.0 && <0.4, + github ==0.22.*, + here >=1.2.13 && <1.3, + lens >=4.17.1 && <4.18, + logging-effect >=1.3.4 && <1.4, + megaparsec >=7.0.5 && <7.1, + modern-uri >=0.3.1.0 && <0.4, + mtl >=2.2.2 && <2.3, + optparse-applicative >=0.14.3.0 && <0.15, + temporary ==1.3.*, + text >=1.2.3.1 && <1.3, + time >=1.8.0.2 && <1.9, + unix >=2.7.2.2 && <2.8, + which >=0.1.0.0 && <0.2, + yaml >=0.11.1.2 && <0.12 + +executable nix-thunk + main-is: src-bin/nix-thunk.hs + default-language: Haskell2010 + build-depends: + base >=4.12.0.0 && <4.13, + nix-thunk -any, + cli-extras >=0.1.0.0 && <0.2, + optparse-applicative >=0.14.3.0 && <0.15, + text >=1.2.3.1 && <1.3 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,47 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PackageImports #-} +import "nix-thunk" Nix.Thunk +import "nix-thunk" Nix.Thunk.Command +import Options.Applicative +import Cli.Extras +import qualified Data.Text.IO as T +import System.Environment +import System.Exit +import Data.Void + +data Args = Args + { _args_verbose :: Bool + , _args_command :: ThunkOption + } + +verbose :: Parser Bool +verbose = flag False True $ mconcat + [ long "verbose" + , short 'v' + , help "Produce more detailed output" + ] + +args :: Parser Args +args = Args <$> verbose <*> thunkOption + +argsInfo :: ParserInfo Args +argsInfo = info (args <**> helper) $ mconcat + [ fullDesc + , progDesc "Manage source repositories using Nix" + ] + +parserPrefs :: ParserPrefs +parserPrefs = defaultPrefs + { prefShowHelpOnEmpty = True + } + +main :: IO Void +main = do + args <- getArgs + args' <- handleParseResult $ execParserPure parserPrefs argsInfo args + cliConf <- mkDefaultCliConfig args + runCli cliConf (runThunkOption (_args_command args')) >>= \case + Right () -> exitWith ExitSuccess + Left e -> do + T.putStrLn $ prettyNixThunkError e + exitWith $ ExitFailure 2 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,1270 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Nix.Thunk + ( ThunkSource (..) + , GitHubSource (..) + , ThunkRev (..) + , getLatestRev + , gitCloneForThunkUnpack + , thunkSourceToGitSource + , ThunkPtr (..) + , ThunkData (..) + , readThunk + , CheckClean (..) + , getThunkPtr + , packThunk + , createThunk + , ThunkPackConfig (..) + , ThunkConfig (..) + , updateThunkToLatest + , ThunkUpdateConfig (..) + , unpackThunk + , ThunkSpec (..) + , ThunkFileSpec (..) + , NixThunkError + , nixBuildAttrWithCache + , attrCacheFileName + , prettyNixThunkError + ) where + +import Control.Applicative +import Control.Lens (ifor, ifor_, (.~), makePrisms) +import Control.Monad +import Control.Monad.Extra (findM) +import Control.Monad.Catch (MonadCatch, handle, MonadMask) +import Control.Monad.Fail (MonadFail) +import Control.Monad.Except +import Control.Monad.Log (MonadLog) +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 qualified Data.ByteString.Lazy as LBS +import Data.Containers.ListUtils (nubOrd) +import Data.Either.Combinators (fromRight') +import Data.Foldable (toList) +import Data.Functor ((<&>)) +import Data.Git.Ref (Ref) +import qualified Data.Git.Ref as Ref +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.Yaml (parseMaybe) +import GitHub +import GitHub.Data.Name +import System.Directory +import System.Exit +import System.FilePath +import System.IO.Temp +import qualified Text.URI as URI +import Cli.Extras +import Control.Exception (displayException, try) +import Data.Either.Combinators (rightToMaybe) +import Data.Traversable +import System.IO.Error (isDoesNotExistError) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import System.Posix.Files +import Data.Default +import Data.Function +import Bindings.Cli.Git +import Bindings.Cli.Coreutils (cp) +import Bindings.Cli.Nix + +-------------------------------------------------------------------------------- +-- Hacks +-------------------------------------------------------------------------------- + +type MonadInfallibleNixThunk m = + ( CliLog m + , HasCliConfig 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 pf -> prettyProcessFailure pf + 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 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 + +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 String + , _thunkUpdateConfig_config :: ThunkConfig + } deriving Show + +data ThunkPackConfig = ThunkPackConfig + { _thunkPackConfig_force :: Bool + , _thunkPackConfig_config :: ThunkConfig + } 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 + } + +getThunkGitBranch :: ThunkPtr -> Maybe Text +getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of + ThunkSource_GitHub s -> _gitHubSource_branch s + ThunkSource_Git s -> _gitSource_branch s + +commitNameToRef :: Name Commit -> Ref Ref.SHA1 +commitNameToRef (N c) = Ref.fromHex $ 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 "nix-prefetch-url" ["--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 $ + proc "nix-prefetch-git" $ 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 + +--TODO: Pretty print these +data ReadThunkError + = ReadThunkError_UnrecognizedThunk + | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath) + | ReadThunkError_MissingPaths (NonEmpty FilePath) + | ReadThunkError_UnparseablePtr FilePath String + | ReadThunkError_FileError IOError + | ReadThunkError_FileDoesNotMatch FilePath Text + | ReadThunkError_UnrecognizedState String + | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr + deriving (Show) + +unpackedDirName :: FilePath +unpackedDirName = "." + +attrCacheFileName :: FilePath +attrCacheFileName = ".attr-cache" + +-- | 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 + case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of + Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir ) <$> fs + Nothing -> pure () + case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of + Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir ) <$> fs + Nothing -> pure () + datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case + ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath + ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir expectedPath)) <&> \case + False -> Nothing + True -> Just ThunkData_Checkout + ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError 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 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 (ThunkData_Packed thunkSpec v) + Left e -> throwError $ ReadThunkError_UnparseablePtr (dir expectedPath) e + + case nonEmpty datas of + Nothing -> throwError ReadThunkError_UnrecognizedThunk + Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b) + 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 $ expectedPath :| [] + False -> pure () + + -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed" + mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout + mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked + mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked + mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) = + if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB + + bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present" + + 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 -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest + x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|] + +-- | Read a thunk and validate that it is exactly a packed thunk. +-- If additional data is present, fail. +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 = Ref.fromHexString 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 -> failWith [i|Invalid thunk at ${target}: ${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" .= Ref.toHexString (_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" .= Ref.toHexString (_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 => FilePath -> Either ThunkSpec ThunkPtr -> m () +createThunk target ptrInfo = + 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 + +createThunkWithLatest :: MonadNixThunk m => FilePath -> ThunkSource -> m () +createThunkWithLatest target s = do + rev <- getLatestRev s + createThunk target $ Right $ ThunkPtr + { _thunkPtr_source = s + , _thunkPtr_rev = rev + } + +updateThunkToLatest :: MonadNixThunk m => ThunkUpdateConfig -> FilePath -> m () +updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do + checkThunkDirectory target + -- check to see if thunk should be updated to a specific branch or just update it's current branch + case mBranch of + Nothing -> do + (overwrite, ptr) <- readThunk target >>= \case + Left err -> failWith [i|Thunk update: ${err}|] + Right c -> case c of + ThunkData_Packed _ t -> return (target, t) + ThunkData_Checkout -> failWith "cannot update an unpacked thunk" + let src = _thunkPtr_source ptr + rev <- getLatestRev src + overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr + { _thunkPtr_source = src + , _thunkPtr_rev = rev + } + Just branch -> readThunk target >>= \case + Left err -> failWith [i|Thunk update: ${err}|] + Right c -> case c of + ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch + 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.|] + where + spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") + +setThunk :: MonadNixThunk m => ThunkConfig -> FilePath -> GitSource -> String -> m () +setThunk thunkConfig target gs branch = do + newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing + overwriteThunk target newThunkPtr + updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target + +-- | 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 = + 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 +|] + +parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr +parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v -> + ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v + +gitThunkSpecs :: NonEmpty ThunkSpec +gitThunkSpecs = + 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 +|] + +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 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 = 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 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 -> failWith $ "withThunkUnpacked: " <> T.pack (show 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 -> failWith [i|Invalid thunk at ${thunkDir}: ${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 + let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir + git $ [ "clone" ] + ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc] + ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ] + ++ do branch <- maybeToList $ _gitSource_branch gitSrc + [ "--branch", T.unpack $ untagName branch ] + git ["reset", "--hard", Ref.toHexString commit] + when (_gitSource_fetchSubmodules gitSrc) $ + git ["submodule", "update", "--recursive", "--init"] + +--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 <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig) + 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 +getThunkPtr gitCheckClean dir mPrivate = do + let repoLocations = nubOrd $ map (first normalise) + [(".git", "."), (unpackedDirName ".git", unpackedDirName)] + repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir ) . fst + thunkDir <- case repoLocation' of + Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|] + Just (_, path) -> pure $ normalise $ dir path + + 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 $ 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) + + -- Get information on all branches and their (optional) designated upstream + -- correspondents + headDump :: [Text] <- T.lines <$> readGitProcess thunkDir + [ "for-each-ref" + , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)" + , "refs/heads/" + ] + + (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 $ + [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:" + , "" + ] ++ + flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat + [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++ + [ "" + , "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'] <- fmap 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 + 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) + case os of + ThunkSource_GitHub s -> githubThunkRev s commit + ThunkSource_Git s -> gitThunkRev s 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 -> gitGetCommitBranch uri mbranch >>= return . snd + (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 + } + +-- | 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 + } + +-- 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 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,73 @@ +{-# LANGUAGE FlexibleContexts #-} +module Nix.Thunk.Command where + +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.Foldable (for_) +import Data.List.NonEmpty (NonEmpty (..)) +import Nix.Thunk +import Cli.Extras (HasCliConfig, Output) +import Options.Applicative +import System.FilePath + +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 (long "branch" <> metavar "BRANCH" <> help "Use the given branch when looking for the latest 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 + +data ThunkOption = ThunkOption + { _thunkOption_thunks :: NonEmpty FilePath + , _thunkOption_command :: ThunkCommand + } deriving Show + +data ThunkCommand + = ThunkCommand_Update ThunkUpdateConfig + | ThunkCommand_Unpack + | ThunkCommand_Pack ThunkPackConfig + deriving Show + +thunkOption :: Parser ThunkOption +thunkOption = hsubparser $ mconcat + [ command "update" $ info (thunkOptionWith $ ThunkCommand_Update <$> thunkUpdateConfig) $ progDesc "Update packed thunk to latest revision available on the tracked branch" + , command "unpack" $ info (thunkOptionWith $ pure ThunkCommand_Unpack) $ progDesc "Unpack thunk into git checkout of revision it points to" + , command "pack" $ info (thunkOptionWith $ ThunkCommand_Pack <$> thunkPackConfig) $ progDesc "Pack git checkout or unpacked thunk into thunk that points at the current branch's upstream" + ] + where + thunkOptionWith f = ThunkOption + <$> ((:|) + <$> thunkDirArg (metavar "THUNKDIRS..." <> help "Paths to directories containing thunk data") + <*> many (thunkDirArg mempty) + ) + <*> f + thunkDirArg opts = fmap (dropTrailingPathSeparator . normalise) $ strArgument $ action "directory" <> opts + +runThunkOption + :: ( MonadLog Output m + , HasCliConfig m + , MonadIO m + , MonadMask m + , MonadError NixThunkError m + , MonadFail m + ) + => ThunkOption -> m () +runThunkOption to = case _thunkOption_command to of + ThunkCommand_Update config -> for_ thunks (updateThunkToLatest config) + ThunkCommand_Unpack -> for_ thunks unpackThunk + ThunkCommand_Pack config -> for_ thunks (packThunk config) + where thunks = _thunkOption_thunks to