{-# 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 :: NixThunkError -> Text
prettyNixThunkError = \case
  NixThunkError_ProcessFailure (ProcessFailure CmdSpec
p Int
code) ->
    Text
"Process exited with code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
code) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CmdSpec -> Text
reconstructCommand CmdSpec
p
  NixThunkError_Unstructured Text
msg -> Text
msg

makePrisms ''NixThunkError

instance AsUnstructuredError NixThunkError where
  asUnstructuredError :: Prism' NixThunkError Text
asUnstructuredError = p Text (f Text) -> p NixThunkError (f NixThunkError)
Prism' NixThunkError Text
_NixThunkError_Unstructured

instance AsProcessFailure NixThunkError where
  asProcessFailure :: Prism' NixThunkError ProcessFailure
asProcessFailure = p ProcessFailure (f ProcessFailure)
-> p NixThunkError (f NixThunkError)
Prism' NixThunkError ProcessFailure
_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 -> ThunkRev
_thunkPtr_rev :: ThunkRev
  , ThunkPtr -> ThunkSource
_thunkPtr_source :: ThunkSource
  }
  deriving (Int -> ThunkPtr -> ShowS
[ThunkPtr] -> ShowS
ThunkPtr -> String
(Int -> ThunkPtr -> ShowS)
-> (ThunkPtr -> String) -> ([ThunkPtr] -> ShowS) -> Show ThunkPtr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThunkPtr -> ShowS
showsPrec :: Int -> ThunkPtr -> ShowS
$cshow :: ThunkPtr -> String
show :: ThunkPtr -> String
$cshowList :: [ThunkPtr] -> ShowS
showList :: [ThunkPtr] -> ShowS
Show, ThunkPtr -> ThunkPtr -> Bool
(ThunkPtr -> ThunkPtr -> Bool)
-> (ThunkPtr -> ThunkPtr -> Bool) -> Eq ThunkPtr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThunkPtr -> ThunkPtr -> Bool
== :: ThunkPtr -> ThunkPtr -> Bool
$c/= :: ThunkPtr -> ThunkPtr -> Bool
/= :: ThunkPtr -> ThunkPtr -> Bool
Eq, Eq ThunkPtr
Eq ThunkPtr =>
(ThunkPtr -> ThunkPtr -> Ordering)
-> (ThunkPtr -> ThunkPtr -> Bool)
-> (ThunkPtr -> ThunkPtr -> Bool)
-> (ThunkPtr -> ThunkPtr -> Bool)
-> (ThunkPtr -> ThunkPtr -> Bool)
-> (ThunkPtr -> ThunkPtr -> ThunkPtr)
-> (ThunkPtr -> ThunkPtr -> ThunkPtr)
-> Ord ThunkPtr
ThunkPtr -> ThunkPtr -> Bool
ThunkPtr -> ThunkPtr -> Ordering
ThunkPtr -> ThunkPtr -> ThunkPtr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ThunkPtr -> ThunkPtr -> Ordering
compare :: ThunkPtr -> ThunkPtr -> Ordering
$c< :: ThunkPtr -> ThunkPtr -> Bool
< :: ThunkPtr -> ThunkPtr -> Bool
$c<= :: ThunkPtr -> ThunkPtr -> Bool
<= :: ThunkPtr -> ThunkPtr -> Bool
$c> :: ThunkPtr -> ThunkPtr -> Bool
> :: ThunkPtr -> ThunkPtr -> Bool
$c>= :: ThunkPtr -> ThunkPtr -> Bool
>= :: ThunkPtr -> ThunkPtr -> Bool
$cmax :: ThunkPtr -> ThunkPtr -> ThunkPtr
max :: ThunkPtr -> ThunkPtr -> ThunkPtr
$cmin :: ThunkPtr -> ThunkPtr -> ThunkPtr
min :: ThunkPtr -> ThunkPtr -> ThunkPtr
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 -> Ref SHA1
_thunkRev_commit :: Ref SHA1
  , ThunkRev -> Text
_thunkRev_nixSha256 :: NixSha256
  }
  deriving (Int -> ThunkRev -> ShowS
[ThunkRev] -> ShowS
ThunkRev -> String
(Int -> ThunkRev -> ShowS)
-> (ThunkRev -> String) -> ([ThunkRev] -> ShowS) -> Show ThunkRev
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThunkRev -> ShowS
showsPrec :: Int -> ThunkRev -> ShowS
$cshow :: ThunkRev -> String
show :: ThunkRev -> String
$cshowList :: [ThunkRev] -> ShowS
showList :: [ThunkRev] -> ShowS
Show, ThunkRev -> ThunkRev -> Bool
(ThunkRev -> ThunkRev -> Bool)
-> (ThunkRev -> ThunkRev -> Bool) -> Eq ThunkRev
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThunkRev -> ThunkRev -> Bool
== :: ThunkRev -> ThunkRev -> Bool
$c/= :: ThunkRev -> ThunkRev -> Bool
/= :: ThunkRev -> ThunkRev -> Bool
Eq, Eq ThunkRev
Eq ThunkRev =>
(ThunkRev -> ThunkRev -> Ordering)
-> (ThunkRev -> ThunkRev -> Bool)
-> (ThunkRev -> ThunkRev -> Bool)
-> (ThunkRev -> ThunkRev -> Bool)
-> (ThunkRev -> ThunkRev -> Bool)
-> (ThunkRev -> ThunkRev -> ThunkRev)
-> (ThunkRev -> ThunkRev -> ThunkRev)
-> Ord ThunkRev
ThunkRev -> ThunkRev -> Bool
ThunkRev -> ThunkRev -> Ordering
ThunkRev -> ThunkRev -> ThunkRev
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ThunkRev -> ThunkRev -> Ordering
compare :: ThunkRev -> ThunkRev -> Ordering
$c< :: ThunkRev -> ThunkRev -> Bool
< :: ThunkRev -> ThunkRev -> Bool
$c<= :: ThunkRev -> ThunkRev -> Bool
<= :: ThunkRev -> ThunkRev -> Bool
$c> :: ThunkRev -> ThunkRev -> Bool
> :: ThunkRev -> ThunkRev -> Bool
$c>= :: ThunkRev -> ThunkRev -> Bool
>= :: ThunkRev -> ThunkRev -> Bool
$cmax :: ThunkRev -> ThunkRev -> ThunkRev
max :: ThunkRev -> ThunkRev -> ThunkRev
$cmin :: ThunkRev -> ThunkRev -> ThunkRev
min :: ThunkRev -> ThunkRev -> ThunkRev
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 (Int -> ThunkSource -> ShowS
[ThunkSource] -> ShowS
ThunkSource -> String
(Int -> ThunkSource -> ShowS)
-> (ThunkSource -> String)
-> ([ThunkSource] -> ShowS)
-> Show ThunkSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThunkSource -> ShowS
showsPrec :: Int -> ThunkSource -> ShowS
$cshow :: ThunkSource -> String
show :: ThunkSource -> String
$cshowList :: [ThunkSource] -> ShowS
showList :: [ThunkSource] -> ShowS
Show, ThunkSource -> ThunkSource -> Bool
(ThunkSource -> ThunkSource -> Bool)
-> (ThunkSource -> ThunkSource -> Bool) -> Eq ThunkSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThunkSource -> ThunkSource -> Bool
== :: ThunkSource -> ThunkSource -> Bool
$c/= :: ThunkSource -> ThunkSource -> Bool
/= :: ThunkSource -> ThunkSource -> Bool
Eq, Eq ThunkSource
Eq ThunkSource =>
(ThunkSource -> ThunkSource -> Ordering)
-> (ThunkSource -> ThunkSource -> Bool)
-> (ThunkSource -> ThunkSource -> Bool)
-> (ThunkSource -> ThunkSource -> Bool)
-> (ThunkSource -> ThunkSource -> Bool)
-> (ThunkSource -> ThunkSource -> ThunkSource)
-> (ThunkSource -> ThunkSource -> ThunkSource)
-> Ord ThunkSource
ThunkSource -> ThunkSource -> Bool
ThunkSource -> ThunkSource -> Ordering
ThunkSource -> ThunkSource -> ThunkSource
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ThunkSource -> ThunkSource -> Ordering
compare :: ThunkSource -> ThunkSource -> Ordering
$c< :: ThunkSource -> ThunkSource -> Bool
< :: ThunkSource -> ThunkSource -> Bool
$c<= :: ThunkSource -> ThunkSource -> Bool
<= :: ThunkSource -> ThunkSource -> Bool
$c> :: ThunkSource -> ThunkSource -> Bool
> :: ThunkSource -> ThunkSource -> Bool
$c>= :: ThunkSource -> ThunkSource -> Bool
>= :: ThunkSource -> ThunkSource -> Bool
$cmax :: ThunkSource -> ThunkSource -> ThunkSource
max :: ThunkSource -> ThunkSource -> ThunkSource
$cmin :: ThunkSource -> ThunkSource -> ThunkSource
min :: ThunkSource -> ThunkSource -> ThunkSource
Ord)

thunkSourceToGitSource :: ThunkSource -> GitSource
thunkSourceToGitSource :: ThunkSource -> GitSource
thunkSourceToGitSource = \case
  ThunkSource_GitHub GitHubSource
s -> Bool -> GitHubSource -> GitSource
forgetGithub Bool
False GitHubSource
s
  ThunkSource_Git GitSource
s -> GitSource
s

setThunkSourceBranch :: Maybe (Name Branch) -> ThunkSource -> ThunkSource
setThunkSourceBranch :: Maybe (Name Branch) -> ThunkSource -> ThunkSource
setThunkSourceBranch Maybe (Name Branch)
mb = \case
  ThunkSource_GitHub GitHubSource
s -> GitHubSource -> ThunkSource
ThunkSource_GitHub (GitHubSource -> ThunkSource) -> GitHubSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ GitHubSource
s { _gitHubSource_branch = mb }
  ThunkSource_Git GitSource
s -> GitSource -> ThunkSource
ThunkSource_Git (GitSource -> ThunkSource) -> GitSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ GitSource
s { _gitSource_branch = mb }

data GitHubSource = GitHubSource
  { GitHubSource -> Name Owner
_gitHubSource_owner :: Name Owner
  , GitHubSource -> Name Repo
_gitHubSource_repo :: Name Repo
  , GitHubSource -> Maybe (Name Branch)
_gitHubSource_branch :: Maybe (Name Branch)
  , GitHubSource -> Bool
_gitHubSource_private :: Bool
  }
  deriving (Int -> GitHubSource -> ShowS
[GitHubSource] -> ShowS
GitHubSource -> String
(Int -> GitHubSource -> ShowS)
-> (GitHubSource -> String)
-> ([GitHubSource] -> ShowS)
-> Show GitHubSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GitHubSource -> ShowS
showsPrec :: Int -> GitHubSource -> ShowS
$cshow :: GitHubSource -> String
show :: GitHubSource -> String
$cshowList :: [GitHubSource] -> ShowS
showList :: [GitHubSource] -> ShowS
Show, GitHubSource -> GitHubSource -> Bool
(GitHubSource -> GitHubSource -> Bool)
-> (GitHubSource -> GitHubSource -> Bool) -> Eq GitHubSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GitHubSource -> GitHubSource -> Bool
== :: GitHubSource -> GitHubSource -> Bool
$c/= :: GitHubSource -> GitHubSource -> Bool
/= :: GitHubSource -> GitHubSource -> Bool
Eq, Eq GitHubSource
Eq GitHubSource =>
(GitHubSource -> GitHubSource -> Ordering)
-> (GitHubSource -> GitHubSource -> Bool)
-> (GitHubSource -> GitHubSource -> Bool)
-> (GitHubSource -> GitHubSource -> Bool)
-> (GitHubSource -> GitHubSource -> Bool)
-> (GitHubSource -> GitHubSource -> GitHubSource)
-> (GitHubSource -> GitHubSource -> GitHubSource)
-> Ord GitHubSource
GitHubSource -> GitHubSource -> Bool
GitHubSource -> GitHubSource -> Ordering
GitHubSource -> GitHubSource -> GitHubSource
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GitHubSource -> GitHubSource -> Ordering
compare :: GitHubSource -> GitHubSource -> Ordering
$c< :: GitHubSource -> GitHubSource -> Bool
< :: GitHubSource -> GitHubSource -> Bool
$c<= :: GitHubSource -> GitHubSource -> Bool
<= :: GitHubSource -> GitHubSource -> Bool
$c> :: GitHubSource -> GitHubSource -> Bool
> :: GitHubSource -> GitHubSource -> Bool
$c>= :: GitHubSource -> GitHubSource -> Bool
>= :: GitHubSource -> GitHubSource -> Bool
$cmax :: GitHubSource -> GitHubSource -> GitHubSource
max :: GitHubSource -> GitHubSource -> GitHubSource
$cmin :: GitHubSource -> GitHubSource -> GitHubSource
min :: GitHubSource -> GitHubSource -> GitHubSource
Ord)

newtype GitUri = GitUri { GitUri -> URI
unGitUri :: URI.URI } deriving (GitUri -> GitUri -> Bool
(GitUri -> GitUri -> Bool)
-> (GitUri -> GitUri -> Bool) -> Eq GitUri
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GitUri -> GitUri -> Bool
== :: GitUri -> GitUri -> Bool
$c/= :: GitUri -> GitUri -> Bool
/= :: GitUri -> GitUri -> Bool
Eq, Eq GitUri
Eq GitUri =>
(GitUri -> GitUri -> Ordering)
-> (GitUri -> GitUri -> Bool)
-> (GitUri -> GitUri -> Bool)
-> (GitUri -> GitUri -> Bool)
-> (GitUri -> GitUri -> Bool)
-> (GitUri -> GitUri -> GitUri)
-> (GitUri -> GitUri -> GitUri)
-> Ord GitUri
GitUri -> GitUri -> Bool
GitUri -> GitUri -> Ordering
GitUri -> GitUri -> GitUri
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GitUri -> GitUri -> Ordering
compare :: GitUri -> GitUri -> Ordering
$c< :: GitUri -> GitUri -> Bool
< :: GitUri -> GitUri -> Bool
$c<= :: GitUri -> GitUri -> Bool
<= :: GitUri -> GitUri -> Bool
$c> :: GitUri -> GitUri -> Bool
> :: GitUri -> GitUri -> Bool
$c>= :: GitUri -> GitUri -> Bool
>= :: GitUri -> GitUri -> Bool
$cmax :: GitUri -> GitUri -> GitUri
max :: GitUri -> GitUri -> GitUri
$cmin :: GitUri -> GitUri -> GitUri
min :: GitUri -> GitUri -> GitUri
Ord, Int -> GitUri -> ShowS
[GitUri] -> ShowS
GitUri -> String
(Int -> GitUri -> ShowS)
-> (GitUri -> String) -> ([GitUri] -> ShowS) -> Show GitUri
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GitUri -> ShowS
showsPrec :: Int -> GitUri -> ShowS
$cshow :: GitUri -> String
show :: GitUri -> String
$cshowList :: [GitUri] -> ShowS
showList :: [GitUri] -> ShowS
Show)

gitUriToText :: GitUri -> Text
gitUriToText :: GitUri -> Text
gitUriToText (GitUri URI
uri)
  | (Text -> Text
T.toLower (Text -> Text) -> (RText 'Scheme -> Text) -> RText 'Scheme -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
uri) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"file"
  , Just (Bool
_, NonEmpty (RText 'PathPiece)
path) <- URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
uri
  = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" ((RText 'PathPiece -> Text) -> [RText 'PathPiece] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RText 'PathPiece -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText ([RText 'PathPiece] -> [Text]) -> [RText 'PathPiece] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (RText 'PathPiece)
path)
  | Bool
otherwise = URI -> Text
URI.render URI
uri

data GitSource = GitSource
  { GitSource -> GitUri
_gitSource_url :: GitUri
  , GitSource -> Maybe (Name Branch)
_gitSource_branch :: Maybe (Name Branch)
  , GitSource -> Bool
_gitSource_fetchSubmodules :: Bool
  , GitSource -> Bool
_gitSource_private :: Bool
  }
  deriving (Int -> GitSource -> ShowS
[GitSource] -> ShowS
GitSource -> String
(Int -> GitSource -> ShowS)
-> (GitSource -> String)
-> ([GitSource] -> ShowS)
-> Show GitSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GitSource -> ShowS
showsPrec :: Int -> GitSource -> ShowS
$cshow :: GitSource -> String
show :: GitSource -> String
$cshowList :: [GitSource] -> ShowS
showList :: [GitSource] -> ShowS
Show, GitSource -> GitSource -> Bool
(GitSource -> GitSource -> Bool)
-> (GitSource -> GitSource -> Bool) -> Eq GitSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GitSource -> GitSource -> Bool
== :: GitSource -> GitSource -> Bool
$c/= :: GitSource -> GitSource -> Bool
/= :: GitSource -> GitSource -> Bool
Eq, Eq GitSource
Eq GitSource =>
(GitSource -> GitSource -> Ordering)
-> (GitSource -> GitSource -> Bool)
-> (GitSource -> GitSource -> Bool)
-> (GitSource -> GitSource -> Bool)
-> (GitSource -> GitSource -> Bool)
-> (GitSource -> GitSource -> GitSource)
-> (GitSource -> GitSource -> GitSource)
-> Ord GitSource
GitSource -> GitSource -> Bool
GitSource -> GitSource -> Ordering
GitSource -> GitSource -> GitSource
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GitSource -> GitSource -> Ordering
compare :: GitSource -> GitSource -> Ordering
$c< :: GitSource -> GitSource -> Bool
< :: GitSource -> GitSource -> Bool
$c<= :: GitSource -> GitSource -> Bool
<= :: GitSource -> GitSource -> Bool
$c> :: GitSource -> GitSource -> Bool
> :: GitSource -> GitSource -> Bool
$c>= :: GitSource -> GitSource -> Bool
>= :: GitSource -> GitSource -> Bool
$cmax :: GitSource -> GitSource -> GitSource
max :: GitSource -> GitSource -> GitSource
$cmin :: GitSource -> GitSource -> GitSource
min :: GitSource -> GitSource -> GitSource
Ord)

newtype ThunkConfig = ThunkConfig
  { ThunkConfig -> Maybe Bool
_thunkConfig_private :: Maybe Bool
  } deriving Int -> ThunkConfig -> ShowS
[ThunkConfig] -> ShowS
ThunkConfig -> String
(Int -> ThunkConfig -> ShowS)
-> (ThunkConfig -> String)
-> ([ThunkConfig] -> ShowS)
-> Show ThunkConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThunkConfig -> ShowS
showsPrec :: Int -> ThunkConfig -> ShowS
$cshow :: ThunkConfig -> String
show :: ThunkConfig -> String
$cshowList :: [ThunkConfig] -> ShowS
showList :: [ThunkConfig] -> ShowS
Show

data ThunkUpdateConfig = ThunkUpdateConfig
  { ThunkUpdateConfig -> Maybe Text
_thunkUpdateConfig_branch :: Maybe Text
  , ThunkUpdateConfig -> Maybe Text
_thunkUpdateConfig_ref :: Maybe Text
  , ThunkUpdateConfig -> ThunkConfig
_thunkUpdateConfig_thunk :: ThunkConfig
  } deriving Int -> ThunkUpdateConfig -> ShowS
[ThunkUpdateConfig] -> ShowS
ThunkUpdateConfig -> String
(Int -> ThunkUpdateConfig -> ShowS)
-> (ThunkUpdateConfig -> String)
-> ([ThunkUpdateConfig] -> ShowS)
-> Show ThunkUpdateConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThunkUpdateConfig -> ShowS
showsPrec :: Int -> ThunkUpdateConfig -> ShowS
$cshow :: ThunkUpdateConfig -> String
show :: ThunkUpdateConfig -> String
$cshowList :: [ThunkUpdateConfig] -> ShowS
showList :: [ThunkUpdateConfig] -> ShowS
Show

data ThunkPackConfig = ThunkPackConfig
  { ThunkPackConfig -> Bool
_thunkPackConfig_force :: Bool
  , ThunkPackConfig -> ThunkConfig
_thunkPackConfig_config :: ThunkConfig
  } deriving Int -> ThunkPackConfig -> ShowS
[ThunkPackConfig] -> ShowS
ThunkPackConfig -> String
(Int -> ThunkPackConfig -> ShowS)
-> (ThunkPackConfig -> String)
-> ([ThunkPackConfig] -> ShowS)
-> Show ThunkPackConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThunkPackConfig -> ShowS
showsPrec :: Int -> ThunkPackConfig -> ShowS
$cshow :: ThunkPackConfig -> String
show :: ThunkPackConfig -> String
$cshowList :: [ThunkPackConfig] -> ShowS
showList :: [ThunkPackConfig] -> ShowS
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 Int -> ThunkCreateSource -> ShowS
[ThunkCreateSource] -> ShowS
ThunkCreateSource -> String
(Int -> ThunkCreateSource -> ShowS)
-> (ThunkCreateSource -> String)
-> ([ThunkCreateSource] -> ShowS)
-> Show ThunkCreateSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThunkCreateSource -> ShowS
showsPrec :: Int -> ThunkCreateSource -> ShowS
$cshow :: ThunkCreateSource -> String
show :: ThunkCreateSource -> String
$cshowList :: [ThunkCreateSource] -> ShowS
showList :: [ThunkCreateSource] -> ShowS
Show

data ThunkCreateConfig = ThunkCreateConfig
  { ThunkCreateConfig -> ThunkCreateSource
_thunkCreateConfig_uri         :: ThunkCreateSource
  , ThunkCreateConfig -> Maybe (Name Branch)
_thunkCreateConfig_branch      :: Maybe (Name Branch)
  , ThunkCreateConfig -> Maybe (Ref SHA1)
_thunkCreateConfig_rev         :: Maybe (Ref SHA1)
  , ThunkCreateConfig -> ThunkConfig
_thunkCreateConfig_config      :: ThunkConfig
  , ThunkCreateConfig -> Maybe String
_thunkCreateConfig_destination :: Maybe FilePath
  } deriving Int -> ThunkCreateConfig -> ShowS
[ThunkCreateConfig] -> ShowS
ThunkCreateConfig -> String
(Int -> ThunkCreateConfig -> ShowS)
-> (ThunkCreateConfig -> String)
-> ([ThunkCreateConfig] -> ShowS)
-> Show ThunkCreateConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThunkCreateConfig -> ShowS
showsPrec :: Int -> ThunkCreateConfig -> ShowS
$cshow :: ThunkCreateConfig -> String
show :: ThunkCreateConfig -> String
$cshowList :: [ThunkCreateConfig] -> ShowS
showList :: [ThunkCreateConfig] -> ShowS
Show

data CreateWorktreeConfig = CreateWorktreeConfig
  { CreateWorktreeConfig -> Maybe String
_createWorktreeConfig_branch :: Maybe String
  , CreateWorktreeConfig -> Bool
_createWorktreeConfig_detach :: Bool
  } deriving Int -> CreateWorktreeConfig -> ShowS
[CreateWorktreeConfig] -> ShowS
CreateWorktreeConfig -> String
(Int -> CreateWorktreeConfig -> ShowS)
-> (CreateWorktreeConfig -> String)
-> ([CreateWorktreeConfig] -> ShowS)
-> Show CreateWorktreeConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CreateWorktreeConfig -> ShowS
showsPrec :: Int -> CreateWorktreeConfig -> ShowS
$cshow :: CreateWorktreeConfig -> String
show :: CreateWorktreeConfig -> String
$cshowList :: [CreateWorktreeConfig] -> ShowS
showList :: [CreateWorktreeConfig] -> ShowS
Show

-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
forgetGithub :: Bool -> GitHubSource -> GitSource
forgetGithub :: Bool -> GitHubSource -> GitSource
forgetGithub Bool
useSsh GitHubSource
s = GitSource
  { _gitSource_url :: GitUri
_gitSource_url = URI -> GitUri
GitUri (URI -> GitUri) -> URI -> GitUri
forall a b. (a -> b) -> a -> b
$ URI.URI
    { uriScheme :: Maybe (RText 'Scheme)
URI.uriScheme = RText 'Scheme -> Maybe (RText 'Scheme)
forall a. a -> Maybe a
Just (RText 'Scheme -> Maybe (RText 'Scheme))
-> RText 'Scheme -> Maybe (RText 'Scheme)
forall a b. (a -> b) -> a -> b
$ Either SomeException (RText 'Scheme) -> RText 'Scheme
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'Scheme) -> RText 'Scheme)
-> Either SomeException (RText 'Scheme) -> RText 'Scheme
forall a b. (a -> b) -> a -> b
$ Text -> Either SomeException (RText 'Scheme)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Scheme)
URI.mkScheme (Text -> Either SomeException (RText 'Scheme))
-> Text -> Either SomeException (RText 'Scheme)
forall a b. (a -> b) -> a -> b
$ if Bool
useSsh then Text
"ssh" else Text
"https"
    , uriAuthority :: Either Bool Authority
URI.uriAuthority = Authority -> Either Bool Authority
forall a b. b -> Either a b
Right (Authority -> Either Bool Authority)
-> Authority -> Either Bool Authority
forall a b. (a -> b) -> a -> b
$ URI.Authority
        { authUserInfo :: Maybe UserInfo
URI.authUserInfo = RText 'Username -> Maybe (RText 'Password) -> UserInfo
URI.UserInfo (Either SomeException (RText 'Username) -> RText 'Username
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'Username) -> RText 'Username)
-> Either SomeException (RText 'Username) -> RText 'Username
forall a b. (a -> b) -> a -> b
$ Text -> Either SomeException (RText 'Username)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Username)
URI.mkUsername Text
"git") Maybe (RText 'Password)
forall a. Maybe a
Nothing
          UserInfo -> Maybe () -> Maybe UserInfo
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
useSsh
        , authHost :: RText 'Host
URI.authHost = Either SomeException (RText 'Host) -> RText 'Host
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'Host) -> RText 'Host)
-> Either SomeException (RText 'Host) -> RText 'Host
forall a b. (a -> b) -> a -> b
$ Text -> Either SomeException (RText 'Host)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Host)
URI.mkHost Text
"github.com"
        , authPort :: Maybe Word
URI.authPort = Maybe Word
forall a. Maybe a
Nothing
        }
    , uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath = (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. a -> Maybe a
Just ( Bool
False
                     , Either SomeException (RText 'PathPiece) -> RText 'PathPiece
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'PathPiece) -> RText 'PathPiece)
-> (Text -> Either SomeException (RText 'PathPiece))
-> Text
-> RText 'PathPiece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either SomeException (RText 'PathPiece)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'PathPiece)
URI.mkPathPiece (Text -> RText 'PathPiece)
-> NonEmpty Text -> NonEmpty (RText 'PathPiece)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                       Name Owner -> Text
forall entity. Name entity -> Text
untagName (GitHubSource -> Name Owner
_gitHubSource_owner GitHubSource
s)
                       Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [ Name Repo -> Text
forall entity. Name entity -> Text
untagName (GitHubSource -> Name Repo
_gitHubSource_repo GitHubSource
s) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".git" ]
                     )
    , uriQuery :: [QueryParam]
URI.uriQuery = []
    , uriFragment :: Maybe (RText 'Fragment)
URI.uriFragment = Maybe (RText 'Fragment)
forall a. Maybe a
Nothing
    }
  , _gitSource_branch :: Maybe (Name Branch)
_gitSource_branch = GitHubSource -> Maybe (Name Branch)
_gitHubSource_branch GitHubSource
s
  , _gitSource_fetchSubmodules :: Bool
_gitSource_fetchSubmodules = Bool
False
  , _gitSource_private :: Bool
_gitSource_private = GitHubSource -> Bool
_gitHubSource_private GitHubSource
s
  }

commitNameToRef :: Name Commit -> Ref SHA1
commitNameToRef :: Name Commit -> Ref SHA1
commitNameToRef (N Text
c) = ByteString -> Ref SHA1
forall hash. HashAlgorithm hash => ByteString -> Ref hash
refFromHex (ByteString -> Ref SHA1) -> ByteString -> Ref SHA1
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
c

-- TODO: Use spinner here.
getNixSha256ForUriUnpacked
  :: MonadNixThunk m
  => GitUri
  -> m NixSha256
getNixSha256ForUriUnpacked :: forall (m :: * -> *). MonadNixThunk m => GitUri -> m Text
getNixSha256ForUriUnpacked GitUri
uri =
  Text -> m Text -> m Text
forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage (Text
"nix-prefetch-url: Failed to determine sha256 hash of URL " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitUri -> Text
gitUriToText GitUri
uri) (m Text -> m Text) -> m Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
    [hash] <- (Text -> [Text]) -> m Text -> m [Text]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Text]
T.lines (m Text -> m [Text]) -> m Text -> m [Text]
forall a b. (a -> b) -> a -> b
$ (Severity, Severity) -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadFail m) =>
(Severity, Severity) -> ProcessSpec -> m Text
readProcessAndLogOutput (Severity
Debug, Severity
Debug) (ProcessSpec -> m Text) -> ProcessSpec -> m Text
forall a b. (a -> b) -> a -> b
$
      String -> [String] -> ProcessSpec
proc String
nixPrefetchUrlPath [String
"--unpack", String
"--type", String
"sha256", Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ GitUri -> Text
gitUriToText GitUri
uri]
    pure hash

nixPrefetchGit :: MonadNixThunk m => GitUri -> Text -> Bool -> m NixSha256
nixPrefetchGit :: forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Text -> Bool -> m Text
nixPrefetchGit GitUri
uri Text
rev Bool
fetchSubmodules =
  Text -> m Text -> m Text
forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage (Text
"nix-prefetch-git: Failed to determine sha256 hash of Git repo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitUri -> Text
gitUriToText GitUri
uri Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rev) (m Text -> m Text) -> m Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
    out <- Severity -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadMask m) =>
Severity -> ProcessSpec -> m Text
readProcessAndLogStderr Severity
Debug (ProcessSpec -> m Text) -> ProcessSpec -> m Text
forall a b. (a -> b) -> a -> b
$ ProcessSpec -> ProcessSpec
ignoreGitConfig (ProcessSpec -> ProcessSpec) -> ProcessSpec -> ProcessSpec
forall a b. (a -> b) -> a -> b
$
      String -> [String] -> ProcessSpec
proc String
nixPrefetchGitPath ([String] -> ProcessSpec) -> [String] -> ProcessSpec
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"")
        [ String
"--url", Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ GitUri -> Text
gitUriToText GitUri
uri
        , String
"--rev", Text -> String
T.unpack Text
rev
        , if Bool
fetchSubmodules then String
"--fetch-submodules" else String
""
        , String
"--quiet"
        ]

    case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of
      Maybe Text
Nothing -> Text -> m Text
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text
"nix-prefetch-git: unrecognized output " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
out
      Just Text
x -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
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 :: ReadThunkError -> Text
prettyReadThunkError =
  \case
    ReadThunkError_UnrecognizedPaths (Just ThunkSpec
spec) (String
f :| [String]
fs) ->
      -- Limit to five unrecognised paths so that the user doesn't get
      -- utterly spammed:
      [Text] -> Text
T.unlines ( Text
"The directory matched spec " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ThunkSpec -> Text
_thunkSpec_name ThunkSpec
spec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but the following file(s) are extraneous:"
                Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String
fString -> [String] -> [String]
forall a. a -> [a] -> [a]
:Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
4 [String]
fs))
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5 then Text
"... and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
fs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" others." else Text
forall a. Monoid a => a
mempty

    ReadThunkError_MissingPaths (String
f :| [String]
fs) ->
      [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
"The following path(s) are missing from the thunk directory:"
        Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:(String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String
fString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fs)

    ReadThunkError_FileError String
path IOError
ioe -> Text
"I/O error while reading the file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IOError -> String
forall a. Show a => a -> String
show IOError
ioe)
    ReadThunkError_UnparseablePtr String
path String
str -> Text
"Syntax error while reading the file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
str
    ReadThunkError_FileDoesNotMatch String
path Text
_ -> Text
"The file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not have the right contents for this thunk specification."
    ReadThunkError_AmbiguousPackedState ThunkSpec
speca ThunkSpec
specb ->
      Text
"The given thunk directory is ambiguous: It matches both " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ThunkSpec -> Text
_thunkSpec_name ThunkSpec
speca Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ThunkSpec -> Text
_thunkSpec_name ThunkSpec
specb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

    ReadThunkError
ReadThunkError_UnrecognizedThunk -> Text
generic
    ReadThunkError_UnrecognizedPaths{} -> Text
generic
  where
    generic :: Text
generic = String -> Text
T.pack String
"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 :: forall (m :: * -> *) a.
MonadError NixThunkError m =>
Text -> ReadThunkError -> m a
failReadThunkErrorWhile Text
what ReadThunkError
rte = Text -> m a
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text
"Failure reading thunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ReadThunkError -> Text
prettyReadThunkError ReadThunkError
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 -> Bool
didMatchThunkSpec (ReadThunkError_UnrecognizedPaths Maybe ThunkSpec
x NonEmpty String
_) = Maybe ThunkSpec -> Bool
forall a. Maybe a -> Bool
isJust Maybe ThunkSpec
x
didMatchThunkSpec ReadThunkError_AmbiguousPackedState{} = Bool
True
didMatchThunkSpec ReadThunkError
_ = Bool
False

unpackedDirName :: FilePath
unpackedDirName :: String
unpackedDirName = String
"."

attrCacheFileName :: FilePath
attrCacheFileName :: String
attrCacheFileName = String
".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 :: String
pinnedNixpkgsPath = String
"/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 -> Text
_thunkSpec_name :: !Text
  , ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files :: !(Map FilePath ThunkFileSpec)
  }

thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
thunkSpecTypes = NonEmpty ThunkSpec
gitThunkSpecs NonEmpty ThunkSpec
-> [NonEmpty ThunkSpec] -> NonEmpty (NonEmpty ThunkSpec)
forall a. a -> [a] -> NonEmpty a
:| [NonEmpty ThunkSpec
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 :: forall (m :: * -> *).
(MonadError ReadThunkError m, MonadIO m, MonadCatch m) =>
ThunkSpec -> String -> Set String -> m ThunkData
matchThunkSpecToDir ThunkSpec
thunkSpec String
dir Set String
dirFiles = do
  isCheckout <- (Map String Bool -> Bool) -> m (Map String Bool) -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map String Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (m (Map String Bool) -> m Bool) -> m (Map String Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ((String -> ThunkFileSpec -> m Bool)
 -> Map String ThunkFileSpec -> m (Map String Bool))
-> Map String ThunkFileSpec
-> (String -> ThunkFileSpec -> m Bool)
-> m (Map String Bool)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> ThunkFileSpec -> m Bool)
-> Map String ThunkFileSpec -> m (Map String Bool)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files ThunkSpec
thunkSpec) ((String -> ThunkFileSpec -> m Bool) -> m (Map String Bool))
-> (String -> ThunkFileSpec -> m Bool) -> m (Map String Bool)
forall a b. (a -> b) -> a -> b
$ \String
expectedPath -> \case
    ThunkFileSpec
ThunkFileSpec_CheckoutIndicator -> IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
doesDirectoryExist (String
dir String -> ShowS
</> String
expectedPath))
    ThunkFileSpec
_ -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  case isCheckout of
    Bool
True -> ThunkData -> m ThunkData
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThunkData
ThunkData_Checkout
    Bool
False -> do
      datas <- (Map String (ThunkSpec, ThunkPtr) -> [(ThunkSpec, ThunkPtr)])
-> m (Map String (ThunkSpec, ThunkPtr))
-> m [(ThunkSpec, ThunkPtr)]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map String (ThunkSpec, ThunkPtr) -> [(ThunkSpec, ThunkPtr)]
forall a. Map String a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (m (Map String (ThunkSpec, ThunkPtr)) -> m [(ThunkSpec, ThunkPtr)])
-> m (Map String (ThunkSpec, ThunkPtr))
-> m [(ThunkSpec, ThunkPtr)]
forall a b. (a -> b) -> a -> b
$ ((String -> ThunkFileSpec -> m (Maybe (ThunkSpec, ThunkPtr)))
 -> Map String ThunkFileSpec
 -> m (Map String (ThunkSpec, ThunkPtr)))
-> Map String ThunkFileSpec
-> (String -> ThunkFileSpec -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Map String (ThunkSpec, ThunkPtr))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> ThunkFileSpec -> m (Maybe (ThunkSpec, ThunkPtr)))
-> Map String ThunkFileSpec -> m (Map String (ThunkSpec, ThunkPtr))
forall (f :: * -> *) k a b.
Applicative f =>
(k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)
Map.traverseMaybeWithKey (ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files ThunkSpec
thunkSpec) ((String -> ThunkFileSpec -> m (Maybe (ThunkSpec, ThunkPtr)))
 -> m (Map String (ThunkSpec, ThunkPtr)))
-> (String -> ThunkFileSpec -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Map String (ThunkSpec, ThunkPtr))
forall a b. (a -> b) -> a -> b
$ \String
expectedPath -> \case
        ThunkFileSpec
ThunkFileSpec_AttrCache -> Maybe (ThunkSpec, ThunkPtr)
forall a. Maybe a
Nothing Maybe (ThunkSpec, ThunkPtr)
-> m () -> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m ()
forall {m :: * -> *}.
(MonadIO m, MonadError ReadThunkError m) =>
String -> m ()
dirMayExist String
expectedPath
        ThunkFileSpec
ThunkFileSpec_CheckoutIndicator -> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ThunkSpec, ThunkPtr)
forall a. Maybe a
Nothing -- Handled above
        ThunkFileSpec_FileMatches Text
expectedContents -> (IOError -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Maybe (ThunkSpec, ThunkPtr))
-> m (Maybe (ThunkSpec, ThunkPtr))
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOError
e :: IOError) -> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr)))
-> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. (a -> b) -> a -> b
$ String -> IOError -> ReadThunkError
ReadThunkError_FileError String
expectedPath IOError
e) (m (Maybe (ThunkSpec, ThunkPtr))
 -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Maybe (ThunkSpec, ThunkPtr))
-> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. (a -> b) -> a -> b
$ do
          actualContents <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Text
T.readFile (String -> IO Text) -> String -> IO Text
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
expectedPath)
          case T.strip expectedContents == T.strip actualContents of
            Bool
True -> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ThunkSpec, ThunkPtr)
forall a. Maybe a
Nothing
            Bool
False -> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr)))
-> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. (a -> b) -> a -> b
$ String -> Text -> ReadThunkError
ReadThunkError_FileDoesNotMatch (String
dir String -> ShowS
</> String
expectedPath) Text
expectedContents
        ThunkFileSpec_Ptr ByteString -> Either String ThunkPtr
parser -> (IOError -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Maybe (ThunkSpec, ThunkPtr))
-> m (Maybe (ThunkSpec, ThunkPtr))
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOError
e :: IOError) -> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr)))
-> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. (a -> b) -> a -> b
$ String -> IOError -> ReadThunkError
ReadThunkError_FileError String
expectedPath IOError
e) (m (Maybe (ThunkSpec, ThunkPtr))
 -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Maybe (ThunkSpec, ThunkPtr))
-> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. (a -> b) -> a -> b
$ do
          let path :: String
path = String
dir String -> ShowS
</> String
expectedPath
          IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
doesFileExist String
path) m Bool
-> (Bool -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False -> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ThunkSpec, ThunkPtr)
forall a. Maybe a
Nothing
            Bool
True -> do
              actualContents <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
LBS.readFile String
path
              case parser actualContents of
                Right ThunkPtr
v -> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr)))
-> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. (a -> b) -> a -> b
$ (ThunkSpec, ThunkPtr) -> Maybe (ThunkSpec, ThunkPtr)
forall a. a -> Maybe a
Just (ThunkSpec
thunkSpec, ThunkPtr
v)
                Left String
e -> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr)))
-> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
forall a b. (a -> b) -> a -> b
$ String -> String -> ReadThunkError
ReadThunkError_UnparseablePtr (String
dir String -> ShowS
</> String
expectedPath) String
e
      let matched = ThunkSpec
thunkSpec ThunkSpec
-> Maybe (NonEmpty (ThunkSpec, ThunkPtr)) -> Maybe ThunkSpec
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [(ThunkSpec, ThunkPtr)] -> Maybe (NonEmpty (ThunkSpec, ThunkPtr))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(ThunkSpec, ThunkPtr)]
datas
      for_ (nonEmpty (toList $ dirFiles `Set.difference` expectedPaths)) $ \NonEmpty String
fs ->
        ReadThunkError -> m (ZonkAny 0)
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m (ZonkAny 0))
-> ReadThunkError -> m (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ Maybe ThunkSpec -> NonEmpty String -> ReadThunkError
ReadThunkError_UnrecognizedPaths Maybe ThunkSpec
matched (NonEmpty String -> ReadThunkError)
-> NonEmpty String -> ReadThunkError
forall a b. (a -> b) -> a -> b
$ (String
dir String -> ShowS
</>) ShowS -> NonEmpty String -> NonEmpty String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty String
fs
      for_ (nonEmpty (toList $ requiredPaths `Set.difference` dirFiles)) $ \NonEmpty String
fs ->
        ReadThunkError -> m (ZonkAny 1)
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m (ZonkAny 1))
-> ReadThunkError -> m (ZonkAny 1)
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> ReadThunkError
ReadThunkError_MissingPaths (NonEmpty String -> ReadThunkError)
-> NonEmpty String -> ReadThunkError
forall a b. (a -> b) -> a -> b
$ (String
dir String -> ShowS
</>) ShowS -> NonEmpty String -> NonEmpty String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty String
fs

      uncurry ThunkData_Packed <$> case nonEmpty datas of
        Maybe (NonEmpty (ThunkSpec, ThunkPtr))
Nothing -> ReadThunkError -> m (ThunkSpec, ThunkPtr)
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ReadThunkError
ReadThunkError_UnrecognizedThunk
        Just NonEmpty (ThunkSpec, ThunkPtr)
xs -> NonEmpty (ThunkSpec, ThunkPtr)
-> ((ThunkSpec, ThunkPtr)
    -> (ThunkSpec, ThunkPtr) -> m (ThunkSpec, ThunkPtr))
-> m (ThunkSpec, ThunkPtr)
forall {m :: * -> *} {a}.
Monad m =>
NonEmpty a -> (a -> a -> m a) -> m a
fold1WithM NonEmpty (ThunkSpec, ThunkPtr)
xs (((ThunkSpec, ThunkPtr)
  -> (ThunkSpec, ThunkPtr) -> m (ThunkSpec, ThunkPtr))
 -> m (ThunkSpec, ThunkPtr))
-> ((ThunkSpec, ThunkPtr)
    -> (ThunkSpec, ThunkPtr) -> m (ThunkSpec, ThunkPtr))
-> m (ThunkSpec, ThunkPtr)
forall a b. (a -> b) -> a -> b
$ \a :: (ThunkSpec, ThunkPtr)
a@(ThunkSpec
speca, ThunkPtr
ptrA) (ThunkSpec
specb, ThunkPtr
ptrB) ->
          if ThunkPtr
ptrA ThunkPtr -> ThunkPtr -> Bool
forall a. Eq a => a -> a -> Bool
== ThunkPtr
ptrB then (ThunkSpec, ThunkPtr) -> m (ThunkSpec, ThunkPtr)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThunkSpec, ThunkPtr)
a else ReadThunkError -> m (ThunkSpec, ThunkPtr)
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m (ThunkSpec, ThunkPtr))
-> ReadThunkError -> m (ThunkSpec, ThunkPtr)
forall a b. (a -> b) -> a -> b
$ ThunkSpec -> ThunkSpec -> ReadThunkError
ReadThunkError_AmbiguousPackedState ThunkSpec
speca ThunkSpec
specb
  where
    rootPathsOnly :: Map String a -> Set String
rootPathsOnly = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String)
-> (Map String a -> [String]) -> Map String a -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe String
takeRootDir ([String] -> [String])
-> (Map String a -> [String]) -> Map String a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String a -> [String]
forall k a. Map k a -> [k]
Map.keys
    takeRootDir :: String -> Maybe String
takeRootDir = (NonEmpty String -> String)
-> Maybe (NonEmpty String) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty String -> String
forall a. NonEmpty a -> a
NonEmpty.head (Maybe (NonEmpty String) -> Maybe String)
-> (String -> Maybe (NonEmpty String)) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([String] -> Maybe (NonEmpty String))
-> (String -> [String]) -> String -> Maybe (NonEmpty String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitPath

    expectedPaths :: Set String
expectedPaths = Map String ThunkFileSpec -> Set String
forall {a}. Map String a -> Set String
rootPathsOnly (Map String ThunkFileSpec -> Set String)
-> Map String ThunkFileSpec -> Set String
forall a b. (a -> b) -> a -> b
$ ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files ThunkSpec
thunkSpec

    requiredPaths :: Set String
requiredPaths = Map String ThunkFileSpec -> Set String
forall {a}. Map String a -> Set String
rootPathsOnly (Map String ThunkFileSpec -> Set String)
-> Map String ThunkFileSpec -> Set String
forall a b. (a -> b) -> a -> b
$ (ThunkFileSpec -> Bool)
-> Map String ThunkFileSpec -> Map String ThunkFileSpec
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ThunkFileSpec -> Bool
isRequiredFileSpec (Map String ThunkFileSpec -> Map String ThunkFileSpec)
-> Map String ThunkFileSpec -> Map String ThunkFileSpec
forall a b. (a -> b) -> a -> b
$ ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files ThunkSpec
thunkSpec
    isRequiredFileSpec :: ThunkFileSpec -> Bool
isRequiredFileSpec = \case
      ThunkFileSpec_FileMatches Text
_ -> Bool
True
      ThunkFileSpec
_ -> Bool
False

    dirMayExist :: String -> m ()
dirMayExist String
expectedPath = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
expectedPath)) m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> ReadThunkError -> m ()
forall a. ReadThunkError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m ()) -> ReadThunkError -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe ThunkSpec -> NonEmpty String -> ReadThunkError
ReadThunkError_UnrecognizedPaths Maybe ThunkSpec
forall a. Maybe a
Nothing (NonEmpty String -> ReadThunkError)
-> NonEmpty String -> ReadThunkError
forall a b. (a -> b) -> a -> b
$ String
expectedPath String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []
      Bool
False -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    fold1WithM :: NonEmpty a -> (a -> a -> m a) -> m a
fold1WithM (a
x :| [a]
xs) a -> a -> m a
f = (a -> a -> m a) -> a -> [a] -> m a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM a -> a -> m a
f a
x [a]
xs

readThunkWith
  :: (MonadNixThunk m)
  => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
readThunkWith :: forall (m :: * -> *).
MonadNixThunk m =>
NonEmpty (NonEmpty ThunkSpec)
-> String -> m (Either ReadThunkError ThunkData)
readThunkWith NonEmpty (NonEmpty ThunkSpec)
specTypes String
dir = do
  dirFiles <- [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> m [String] -> m (Set String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO [String]
listDirectory String
dir)
  let specs = (NonEmpty ThunkSpec -> [ThunkSpec])
-> [NonEmpty ThunkSpec] -> [ThunkSpec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty ThunkSpec -> [ThunkSpec]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([NonEmpty ThunkSpec] -> [ThunkSpec])
-> [NonEmpty ThunkSpec] -> [ThunkSpec]
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty ThunkSpec) -> [NonEmpty ThunkSpec]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (NonEmpty ThunkSpec) -> [NonEmpty ThunkSpec])
-> NonEmpty (NonEmpty ThunkSpec) -> [NonEmpty ThunkSpec]
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty ThunkSpec) -> NonEmpty (NonEmpty ThunkSpec)
forall a. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
NonEmpty.transpose NonEmpty (NonEmpty ThunkSpec)
specTypes -- Interleave spec types so we try each one in a "fair" ordering
  flip fix specs $ \[ThunkSpec] -> m (Either ReadThunkError ThunkData)
loop -> \case
    [] -> Either ReadThunkError ThunkData
-> m (Either ReadThunkError ThunkData)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ReadThunkError ThunkData
 -> m (Either ReadThunkError ThunkData))
-> Either ReadThunkError ThunkData
-> m (Either ReadThunkError ThunkData)
forall a b. (a -> b) -> a -> b
$ ReadThunkError -> Either ReadThunkError ThunkData
forall a b. a -> Either a b
Left ReadThunkError
ReadThunkError_UnrecognizedThunk
    ThunkSpec
spec:[ThunkSpec]
rest -> ExceptT ReadThunkError m ThunkData
-> m (Either ReadThunkError ThunkData)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ThunkSpec
-> String -> Set String -> ExceptT ReadThunkError m ThunkData
forall (m :: * -> *).
(MonadError ReadThunkError m, MonadIO m, MonadCatch m) =>
ThunkSpec -> String -> Set String -> m ThunkData
matchThunkSpecToDir ThunkSpec
spec String
dir Set String
dirFiles) m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData
    -> m (Either ReadThunkError ThunkData))
-> m (Either ReadThunkError ThunkData)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left ReadThunkError
e
        -- If we matched one or more thunk specs, we fail early to tell
        -- the user exactly what's wrong:
        | ReadThunkError -> Bool
didMatchThunkSpec ReadThunkError
e -> Either ReadThunkError ThunkData
-> m (Either ReadThunkError ThunkData)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ReadThunkError ThunkData
 -> m (Either ReadThunkError ThunkData))
-> Either ReadThunkError ThunkData
-> m (Either ReadThunkError ThunkData)
forall a b. (a -> b) -> a -> b
$ ReadThunkError -> Either ReadThunkError ThunkData
forall a b. a -> Either a b
Left ReadThunkError
e
        -- Otherwise, keep looping:
        | Bool
otherwise -> Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${prettyReadThunkError e}|] m ()
-> m (Either ReadThunkError ThunkData)
-> m (Either ReadThunkError ThunkData)
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [ThunkSpec] -> m (Either ReadThunkError ThunkData)
loop [ThunkSpec]
rest
      x :: Either ReadThunkError ThunkData
x@(Right ThunkData
_) -> Either ReadThunkError ThunkData
x Either ReadThunkError ThunkData
-> m () -> m (Either ReadThunkError ThunkData)
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
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 :: forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk = NonEmpty (NonEmpty ThunkSpec)
-> String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
NonEmpty (NonEmpty ThunkSpec)
-> String -> m (Either ReadThunkError ThunkData)
readThunkWith NonEmpty (NonEmpty ThunkSpec)
thunkSpecTypes

parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
parseThunkPtr :: (Object -> Parser ThunkSource) -> Object -> Parser ThunkPtr
parseThunkPtr Object -> Parser ThunkSource
parseSrc Object
v = do
  rev <- Object
v Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"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 :: Object -> Parser GitHubSource
parseGitHubSource Object
v = do
  owner <- Object
v Object -> Key -> Parser (Name Owner)
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"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 :: Object -> Parser GitSource
parseGitSource Object
v = do
  Just url <- Text -> Maybe GitUri
parseGitUri (Text -> Maybe GitUri) -> Parser Text -> Parser (Maybe GitUri)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"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 :: forall (m :: * -> *). MonadNixThunk m => String -> ThunkPtr -> m ()
overwriteThunk String
target ThunkPtr
thunk = do
  -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
  String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk String
target m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ReadThunkError
e -> Text -> ReadThunkError -> m ()
forall (m :: * -> *) a.
MonadError NixThunkError m =>
Text -> ReadThunkError -> m a
failReadThunkErrorWhile Text
"while overwriting" ReadThunkError
e
    Right ThunkData
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  --TODO: Is there a safer way to do this overwriting?
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
target
  String -> Either ThunkSpec ThunkPtr -> m ()
forall (m :: * -> *).
MonadNixThunk m =>
String -> Either ThunkSpec ThunkPtr -> m ()
createThunk String
target (Either ThunkSpec ThunkPtr -> m ())
-> Either ThunkSpec ThunkPtr -> m ()
forall a b. (a -> b) -> a -> b
$ ThunkPtr -> Either ThunkSpec ThunkPtr
forall a b. b -> Either a b
Right ThunkPtr
thunk

thunkPtrToSpec :: ThunkPtr -> ThunkSpec
thunkPtrToSpec :: ThunkPtr -> ThunkSpec
thunkPtrToSpec ThunkPtr
thunk = case ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
thunk of
  ThunkSource_GitHub GitHubSource
_ -> NonEmpty ThunkSpec -> ThunkSpec
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty ThunkSpec
gitHubThunkSpecs
  ThunkSource_Git GitSource
_ -> NonEmpty ThunkSpec -> ThunkSpec
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty ThunkSpec
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 -> ByteString
encodeThunkPtrData (ThunkPtr ThunkRev
rev ThunkSource
src) = case ThunkSource
src of
  ThunkSource_GitHub GitHubSource
s -> Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
githubCfg (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
    [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"owner" Key -> Name Owner -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GitHubSource -> Name Owner
_gitHubSource_owner GitHubSource
s
    , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"repo" Key -> Name Repo -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GitHubSource -> Name Repo
_gitHubSource_repo GitHubSource
s
    , (Key
"branch" Key -> Name Branch -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Name Branch -> Pair) -> Maybe (Name Branch) -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GitHubSource -> Maybe (Name Branch)
_gitHubSource_branch GitHubSource
s
    , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"rev" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Ref SHA1 -> String
forall hash. Ref hash -> String
refToHexString (ThunkRev -> Ref SHA1
_thunkRev_commit ThunkRev
rev)
    , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"sha256" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThunkRev -> Text
_thunkRev_nixSha256 ThunkRev
rev
    , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"private" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GitHubSource -> Bool
_gitHubSource_private GitHubSource
s
    ]
  ThunkSource_Git GitSource
s -> Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
plainGitCfg (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
    [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"url" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GitUri -> Text
gitUriToText (GitSource -> GitUri
_gitSource_url GitSource
s)
    , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"rev" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Ref SHA1 -> String
forall hash. Ref hash -> String
refToHexString (ThunkRev -> Ref SHA1
_thunkRev_commit ThunkRev
rev)
    , (Key
"branch" Key -> Name Branch -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Name Branch -> Pair) -> Maybe (Name Branch) -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GitSource -> Maybe (Name Branch)
_gitSource_branch GitSource
s
    , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"sha256" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThunkRev -> Text
_thunkRev_nixSha256 ThunkRev
rev
    , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"fetchSubmodules" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GitSource -> Bool
_gitSource_fetchSubmodules GitSource
s
    , Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"private" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= GitSource -> Bool
_gitSource_private GitSource
s
    ]
 where
  githubCfg :: Config
githubCfg = Config
defConfig
    { confIndent = Spaces 2
    , confCompare = keyOrder
        [ "owner"
        , "repo"
        , "branch"
        , "private"
        , "rev"
        , "sha256"
        ] <> compare
    , confTrailingNewline = True
    }
  plainGitCfg :: Config
plainGitCfg = Config
defConfig
    { confIndent = Spaces 2
    , confCompare = keyOrder
        [ "url"
        , "rev"
        , "sha256"
        , "private"
        , "fetchSubmodules"
        ] <> compare
    , confTrailingNewline = True
    }

createThunk' :: MonadNixThunk m => ThunkCreateConfig -> m ()
createThunk' :: forall (m :: * -> *). MonadNixThunk m => ThunkCreateConfig -> m ()
createThunk' ThunkCreateConfig
config = do
  newThunkPtr <- ThunkCreateSource
-> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
forall (m :: * -> *).
MonadNixThunk m =>
ThunkCreateSource
-> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
thunkCreateSourcePtr
    (ThunkCreateConfig -> ThunkCreateSource
_thunkCreateConfig_uri ThunkCreateConfig
config)
    (ThunkConfig -> Maybe Bool
_thunkConfig_private (ThunkConfig -> Maybe Bool) -> ThunkConfig -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ThunkCreateConfig -> ThunkConfig
_thunkCreateConfig_config ThunkCreateConfig
config)
    (Name Branch -> Text
forall entity. Name entity -> Text
untagName (Name Branch -> Text) -> Maybe (Name Branch) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThunkCreateConfig -> Maybe (Name Branch)
_thunkCreateConfig_branch ThunkCreateConfig
config)
    (String -> Text
T.pack (String -> Text) -> (Ref SHA1 -> String) -> Ref SHA1 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref SHA1 -> String
forall a. Show a => a -> String
show (Ref SHA1 -> Text) -> Maybe (Ref SHA1) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThunkCreateConfig -> Maybe (Ref SHA1)
_thunkCreateConfig_rev ThunkCreateConfig
config)
  let trailingDirectoryName = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse
      dropDotGit :: FilePath -> FilePath
      dropDotGit String
origName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
origName (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
stripExtension String
"git" String
origName

      defaultDestinationForGitUri :: GitUri -> FilePath
      defaultDestinationForGitUri = ShowS
dropDotGit ShowS -> (GitUri -> String) -> GitUri -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trailingDirectoryName ShowS -> (GitUri -> String) -> GitUri -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (GitUri -> Text) -> GitUri -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Text
URI.render (URI -> Text) -> (GitUri -> URI) -> GitUri -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitUri -> URI
unGitUri

  destination <- case _thunkCreateConfig_uri config of
    ThunkCreateSource_Absolute GitUri
uri -> String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (GitUri -> String
defaultDestinationForGitUri GitUri
uri) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ThunkCreateConfig -> Maybe String
_thunkCreateConfig_destination ThunkCreateConfig
config
    ThunkCreateSource_Relative String
_ -> case ThunkCreateConfig -> Maybe String
_thunkCreateConfig_destination ThunkCreateConfig
config of
      Maybe String
Nothing -> Text -> m String
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith Text
"When using a relative path as the thunk source, the destination path must be specified."
      Just String
dst -> String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
dst
  createThunk destination $ Right newThunkPtr

createThunk :: MonadNixThunk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
createThunk :: forall (m :: * -> *).
MonadNixThunk m =>
String -> Either ThunkSpec ThunkPtr -> m ()
createThunk String
target Either ThunkSpec ThunkPtr
ptrInfo = do
  isdir <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
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) $ \String
path -> \case
    ThunkFileSpec_FileMatches Text
content -> String -> (String -> m ()) -> m ()
forall {m :: * -> *} {b}.
(CliLog m, MonadIO m) =>
String -> (String -> m b) -> m b
withReadyPath String
path ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
p -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
p Text
content
    ThunkFileSpec_Ptr ByteString -> Either String ThunkPtr
_ -> case Either ThunkSpec ThunkPtr
ptrInfo of
      Left ThunkSpec
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- We can't write the ptr without it
      Right ThunkPtr
ptr -> String -> (String -> m ()) -> m ()
forall {m :: * -> *} {b}.
(CliLog m, MonadIO m) =>
String -> (String -> m b) -> m b
withReadyPath String
path ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
p -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
p (ThunkPtr -> ByteString
encodeThunkPtrData ThunkPtr
ptr)
    ThunkFileSpec
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    spec :: ThunkSpec
spec = (ThunkSpec -> ThunkSpec)
-> (ThunkPtr -> ThunkSpec)
-> Either ThunkSpec ThunkPtr
-> ThunkSpec
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ThunkSpec -> ThunkSpec
forall a. a -> a
id ThunkPtr -> ThunkSpec
thunkPtrToSpec Either ThunkSpec ThunkPtr
ptrInfo
    withReadyPath :: String -> (String -> m b) -> m b
withReadyPath String
path String -> m b
f = do
      let fullPath :: String
fullPath = String
target String -> ShowS
</> String
path
      Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Writing thunk file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
fullPath
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
fullPath
      String -> m b
f String
fullPath

updateThunkToLatest :: MonadNixThunk m => ThunkUpdateConfig -> FilePath -> m ()
updateThunkToLatest :: forall (m :: * -> *).
MonadNixThunk m =>
ThunkUpdateConfig -> String -> m ()
updateThunkToLatest ThunkUpdateConfig
cfg String
target = do
  Text -> Maybe (() -> Text) -> m () -> m ()
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
Text -> Maybe (a -> Text) -> m a -> m a
withSpinner' (Text
"Updating thunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
target Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to latest") ((() -> Text) -> Maybe (() -> Text)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((() -> Text) -> Maybe (() -> Text))
-> (() -> Text) -> Maybe (() -> Text)
forall a b. (a -> b) -> a -> b
$ Text -> () -> Text
forall a b. a -> b -> a
const (Text -> () -> Text) -> Text -> () -> Text
forall a b. (a -> b) -> a -> b
$ Text
"Thunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
target Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" updated to latest") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> m ()
checkThunkDirectory String
target
    String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk String
target m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left ReadThunkError
err -> Text -> ReadThunkError -> m ()
forall (m :: * -> *) a.
MonadError NixThunkError m =>
Text -> ReadThunkError -> m a
failReadThunkErrorWhile Text
"during an update" ReadThunkError
err
      Right ThunkData
c -> case ThunkData
c of
        ThunkData
ThunkData_Checkout -> Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
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 ThunkSpec
_ ThunkPtr
t -> case ThunkUpdateConfig -> Maybe Text
_thunkUpdateConfig_ref ThunkUpdateConfig
cfg of
          Just Text
ref -> do
            newThunkPtr <- GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
uriThunkPtr
              (GitSource -> GitUri
_gitSource_url (GitSource -> GitUri) -> GitSource -> GitUri
forall a b. (a -> b) -> a -> b
$ ThunkSource -> GitSource
thunkSourceToGitSource (ThunkSource -> GitSource) -> ThunkSource -> GitSource
forall a b. (a -> b) -> a -> b
$ ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
t)
              (ThunkConfig -> Maybe Bool
_thunkConfig_private (ThunkConfig -> Maybe Bool) -> ThunkConfig -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ThunkUpdateConfig -> ThunkConfig
_thunkUpdateConfig_thunk ThunkUpdateConfig
cfg)
              (ThunkUpdateConfig -> Maybe Text
_thunkUpdateConfig_branch ThunkUpdateConfig
cfg)
              (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ref)
            overwriteThunk target newThunkPtr
          Maybe Text
Nothing -> do
            let newSrc :: ThunkSource
                newSrc :: ThunkSource
newSrc = case ThunkUpdateConfig -> Maybe Text
_thunkUpdateConfig_branch ThunkUpdateConfig
cfg of
                  Maybe Text
Nothing -> ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
t
                  Just Text
b -> Maybe (Name Branch) -> ThunkSource -> ThunkSource
setThunkSourceBranch (Name Branch -> Maybe (Name Branch)
forall a. a -> Maybe a
Just (Name Branch -> Maybe (Name Branch))
-> Name Branch -> Maybe (Name Branch)
forall a b. (a -> b) -> a -> b
$ Text -> Name Branch
forall entity. Text -> Name entity
N Text
b) (ThunkSource -> ThunkSource) -> ThunkSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
t
            rev <- ThunkSource -> m ThunkRev
forall (m :: * -> *). MonadNixThunk m => ThunkSource -> m ThunkRev
getLatestRev ThunkSource
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 :: NonEmpty ThunkSpec
gitHubThunkSpecs =
  ThunkSpec
gitHubThunkSpecV8 ThunkSpec -> [ThunkSpec] -> NonEmpty ThunkSpec
forall a. a -> [a] -> NonEmpty a
:|
  [ ThunkSpec
gitHubThunkSpecV7
  , ThunkSpec
gitHubThunkSpecV6
  , ThunkSpec
gitHubThunkSpecV5
  , ThunkSpec
gitHubThunkSpecV4
  , ThunkSpec
gitHubThunkSpecV3
  , ThunkSpec
gitHubThunkSpecV2
  , ThunkSpec
gitHubThunkSpecV1
  ]

gitHubThunkSpecV1 :: ThunkSpec
gitHubThunkSpecV1 :: ThunkSpec
gitHubThunkSpecV1 = Text -> Text -> ThunkSpec
legacyGitHubThunkSpec Text
"github-v1"
  Text
"import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"

gitHubThunkSpecV2 :: ThunkSpec
gitHubThunkSpecV2 :: ThunkSpec
gitHubThunkSpecV2 = Text -> Text -> ThunkSpec
legacyGitHubThunkSpec Text
"github-v2" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
  [ Text
"# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on NixThunk, etc.
  , Text
"import ((import <nixpkgs> {}).fetchFromGitHub ("
  , Text
"  let json = builtins.fromJSON (builtins.readFile ./github.json);"
  , Text
"  in { inherit (json) owner repo rev sha256;"
  , Text
"       private = json.private or false;"
  , Text
"     }"
  , Text
"))"
  ]

gitHubThunkSpecV3 :: ThunkSpec
gitHubThunkSpecV3 :: ThunkSpec
gitHubThunkSpecV3 = Text -> Text -> ThunkSpec
legacyGitHubThunkSpec Text
"github-v3" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
  [ Text
"# DO NOT HAND-EDIT THIS FILE"
  , Text
"let"
  , Text
"  fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
  , Text
"    then fetchFromGitHubPrivate args"
  , Text
"    else (import <nixpkgs> {}).fetchFromGitHub (builtins.removeAttrs args [\"branch\"]);"
  , Text
"  fetchFromGitHubPrivate ="
  , Text
"    { owner, repo, rev, branch ? null, name ? null, sha256 ? null, private ? false"
  , Text
"    , fetchSubmodules ? false, githubBase ? \"github.com\", ..."
  , Text
"    }: assert !fetchSubmodules;"
  , Text
"      builtins.fetchGit ({"
  , Text
"        url = \"ssh://git@${githubBase}/${owner}/${repo}.git\";"
  , Text
"        inherit rev;"
  , Text
"      }"
  , Text
"      // (if branch == null then {} else { ref = branch; })"
  , Text
"      // (if name == null then {} else { inherit name; }));"
  , Text
"in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
  ]

gitHubThunkSpecV4 :: ThunkSpec
gitHubThunkSpecV4 :: ThunkSpec
gitHubThunkSpecV4 = Text -> Text -> ThunkSpec
legacyGitHubThunkSpec Text
"github-v4" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
  [ Text
"# DO NOT HAND-EDIT THIS FILE"
  , Text
"let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
  , Text
"  if !fetchSubmodules && !private then builtins.fetchTarball {"
  , Text
"    url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
  , Text
"  } else (import <nixpkgs> {}).fetchFromGitHub {"
  , Text
"    inherit owner repo rev sha256 fetchSubmodules private;"
  , Text
"  };"
  , Text
"in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
  ]

legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
legacyGitHubThunkSpec Text
name Text
loader = Text -> Map String ThunkFileSpec -> ThunkSpec
ThunkSpec Text
name (Map String ThunkFileSpec -> ThunkSpec)
-> Map String ThunkFileSpec -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [(String, ThunkFileSpec)] -> Map String ThunkFileSpec
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (String
"default.nix", Text -> ThunkFileSpec
ThunkFileSpec_FileMatches (Text -> ThunkFileSpec) -> Text -> ThunkFileSpec
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
loader)
  , (String
"github.json" , (ByteString -> Either String ThunkPtr) -> ThunkFileSpec
ThunkFileSpec_Ptr ByteString -> Either String ThunkPtr
parseGitHubJsonBytes)
  , (String
attrCacheFileName, ThunkFileSpec
ThunkFileSpec_AttrCache)
  , (String
".git", ThunkFileSpec
ThunkFileSpec_CheckoutIndicator)
  ]

gitHubThunkSpecV5 :: ThunkSpec
gitHubThunkSpecV5 :: ThunkSpec
gitHubThunkSpecV5 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"github-v5" String
"github.json" ByteString -> Either String ThunkPtr
parseGitHubJsonBytes Text
[here|
# DO NOT HAND-EDIT THIS FILE
let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
  if !fetchSubmodules && !private then builtins.fetchTarball {
    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
  } else (import <nixpkgs> {}).fetchFromGitHub {
    inherit owner repo rev sha256 fetchSubmodules private;
  };
  json = builtins.fromJSON (builtins.readFile ./github.json);
in fetch json
|]

-- | See 'gitHubThunkSpecV7'.
--
-- __NOTE__: v6 spec thunks are broken! They import the pinned nixpkgs
-- in an incorrect way. GitHub thunks for public repositories with no
-- submodules will still work, but update as soon as possible.
gitHubThunkSpecV6 :: ThunkSpec
gitHubThunkSpecV6 :: ThunkSpec
gitHubThunkSpecV6 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"github-v6" String
"github.json" ByteString -> Either String ThunkPtr
parseGitHubJsonBytes Text
[here|
# DO NOT HAND-EDIT THIS FILE
let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
  if !fetchSubmodules && !private then builtins.fetchTarball {
    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
  } else (builtins.fetchTarball {
  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
}).fetchFromGitHub {
    inherit owner repo rev sha256 fetchSubmodules private;
  };
  json = builtins.fromJSON (builtins.readFile ./github.json);
in fetch json
|]

-- | Specification for GitHub thunks which use a specific, pinned
-- version of nixpkgs for fetching, rather than using @<nixpkgs>@ from
-- @NIX_PATH@. The "v7" specs ensure that thunks can be fetched even
-- when @NIX_PATH@ is unset.
gitHubThunkSpecV7 :: ThunkSpec
gitHubThunkSpecV7 :: ThunkSpec
gitHubThunkSpecV7 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"github-v7" String
"github.json" ByteString -> Either String ThunkPtr
parseGitHubJsonBytes [i|# DO NOT HAND-EDIT THIS FILE
let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
  if !fetchSubmodules && !private then builtins.fetchTarball {
    url = "https://github.com/\${owner}/\${repo}/archive/\${rev}.tar.gz"; inherit sha256;
  } else (import ${pinnedNixpkgsPath} {}).fetchFromGitHub {
    inherit owner repo rev sha256 fetchSubmodules private;
  };
  json = builtins.fromJSON (builtins.readFile ./github.json);
in fetch json|]

-- | Specification for GitHub thunks which use a specific, pinned
-- version of nixpkgs for fetching, rather than using @<nixpkgs>@ from
-- @NIX_PATH@.
--
-- Unlike 'gitHubThunKSpecV7', this thunk specification fetches the
-- nixpkgs tarball from GitHub, so it will fail on environments without
-- a network connection.
gitHubThunkSpecV8 :: ThunkSpec
gitHubThunkSpecV8 :: ThunkSpec
gitHubThunkSpecV8 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"github-v8" String
"github.json" ByteString -> Either String ThunkPtr
parseGitHubJsonBytes Text
[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 :: ByteString -> Either String ThunkPtr
parseGitHubJsonBytes = (Object -> Parser ThunkPtr) -> ByteString -> Either String ThunkPtr
forall a. (Object -> Parser a) -> ByteString -> Either String a
parseJsonObject ((Object -> Parser ThunkPtr)
 -> ByteString -> Either String ThunkPtr)
-> (Object -> Parser ThunkPtr)
-> ByteString
-> Either String ThunkPtr
forall a b. (a -> b) -> a -> b
$ (Object -> Parser ThunkSource) -> Object -> Parser ThunkPtr
parseThunkPtr ((Object -> Parser ThunkSource) -> Object -> Parser ThunkPtr)
-> (Object -> Parser ThunkSource) -> Object -> Parser ThunkPtr
forall a b. (a -> b) -> a -> b
$ \Object
v ->
  GitHubSource -> ThunkSource
ThunkSource_GitHub (GitHubSource -> ThunkSource)
-> Parser GitHubSource -> Parser ThunkSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser GitHubSource
parseGitHubSource Object
v Parser ThunkSource -> Parser ThunkSource -> Parser ThunkSource
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GitSource -> ThunkSource
ThunkSource_Git (GitSource -> ThunkSource)
-> Parser GitSource -> Parser ThunkSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser GitSource
parseGitSource Object
v

gitThunkSpecs :: NonEmpty ThunkSpec
gitThunkSpecs :: NonEmpty ThunkSpec
gitThunkSpecs =
  ThunkSpec
gitThunkSpecV9 ThunkSpec -> [ThunkSpec] -> NonEmpty ThunkSpec
forall a. a -> [a] -> NonEmpty a
:|
  [ ThunkSpec
gitThunkSpecV8
  , ThunkSpec
gitThunkSpecV7
  , ThunkSpec
gitThunkSpecV6
  , ThunkSpec
gitThunkSpecV5
  , ThunkSpec
gitThunkSpecV4
  , ThunkSpec
gitThunkSpecV3
  , ThunkSpec
gitThunkSpecV2
  , ThunkSpec
gitThunkSpecV1
  ]

gitThunkSpecV1 :: ThunkSpec
gitThunkSpecV1 :: ThunkSpec
gitThunkSpecV1 = Text -> Text -> ThunkSpec
legacyGitThunkSpec Text
"git-v1" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
  [ Text
"# DO NOT HAND-EDIT THIS FILE"
  , Text
"let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
  , Text
"  assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
  , Text
"in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
  ]

gitThunkSpecV2 :: ThunkSpec
gitThunkSpecV2 :: ThunkSpec
gitThunkSpecV2 = Text -> Text -> ThunkSpec
legacyGitThunkSpec Text
"git-v2" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
  [ Text
"# DO NOT HAND-EDIT THIS FILE"
  , Text
"let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
  , Text
"  if builtins.hasAttr \"fetchGit\" builtins"
  , Text
"    then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"
  , Text
"    else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"
  , Text
"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 :: ThunkSpec
gitThunkSpecV3 = Text -> Text -> ThunkSpec
legacyGitThunkSpec Text
"git-v3" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
  [ Text
"# DO NOT HAND-EDIT THIS FILE"
  , Text
"let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
  , Text
"  let realUrl = let firstChar = builtins.substring 0 1 url; in"
  , Text
"    if firstChar == \"/\" then /. + url"
  , Text
"    else if firstChar == \".\" then ./. + url"
  , Text
"    else url;"
  , Text
"  in if !fetchSubmodules && private then builtins.fetchGit {"
  , Text
"    url = realUrl; inherit rev;"
  , Text
"  } else (import <nixpkgs> {}).fetchgit {"
  , Text
"    url = realUrl; inherit rev sha256;"
  , Text
"  };"
  , Text
"in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
  ]

gitThunkSpecV4 :: ThunkSpec
gitThunkSpecV4 :: ThunkSpec
gitThunkSpecV4 = Text -> Text -> ThunkSpec
legacyGitThunkSpec Text
"git-v4" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
  [ Text
"# DO NOT HAND-EDIT THIS FILE"
  , Text
"let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
  , Text
"  let realUrl = let firstChar = builtins.substring 0 1 url; in"
  , Text
"    if firstChar == \"/\" then /. + url"
  , Text
"    else if firstChar == \".\" then ./. + url"
  , Text
"    else url;"
  , Text
"  in if !fetchSubmodules && private then builtins.fetchGit {"
  , Text
"    url = realUrl; inherit rev;"
  , Text
"    ${if branch == null then null else \"ref\"} = branch;"
  , Text
"  } else (import <nixpkgs> {}).fetchgit {"
  , Text
"    url = realUrl; inherit rev sha256;"
  , Text
"  };"
  , Text
"in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
  ]

legacyGitThunkSpec :: Text -> Text -> ThunkSpec
legacyGitThunkSpec :: Text -> Text -> ThunkSpec
legacyGitThunkSpec Text
name Text
loader = Text -> Map String ThunkFileSpec -> ThunkSpec
ThunkSpec Text
name (Map String ThunkFileSpec -> ThunkSpec)
-> Map String ThunkFileSpec -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [(String, ThunkFileSpec)] -> Map String ThunkFileSpec
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (String
"default.nix", Text -> ThunkFileSpec
ThunkFileSpec_FileMatches (Text -> ThunkFileSpec) -> Text -> ThunkFileSpec
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
loader)
  , (String
"git.json" , (ByteString -> Either String ThunkPtr) -> ThunkFileSpec
ThunkFileSpec_Ptr ByteString -> Either String ThunkPtr
parseGitJsonBytes)
  , (String
attrCacheFileName, ThunkFileSpec
ThunkFileSpec_AttrCache)
  , (String
".git", ThunkFileSpec
ThunkFileSpec_CheckoutIndicator)
  ]

gitThunkSpecV5 :: ThunkSpec
gitThunkSpecV5 :: ThunkSpec
gitThunkSpecV5 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"git-v5" String
"git.json" ByteString -> Either String ThunkPtr
parseGitJsonBytes Text
[here|
# DO NOT HAND-EDIT THIS FILE
let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
  let realUrl = let firstChar = builtins.substring 0 1 url; in
    if firstChar == "/" then /. + url
    else if firstChar == "." then ./. + url
    else url;
  in if !fetchSubmodules && private then builtins.fetchGit {
    url = realUrl; inherit rev;
    ${if branch == null then null else "ref"} = branch;
  } else (import <nixpkgs> {}).fetchgit {
    url = realUrl; inherit rev sha256;
  };
  json = builtins.fromJSON (builtins.readFile ./git.json);
in fetch json
|]

-- | See 'gitThunkSpecV7'.
-- __NOTE__: v6 spec thunks are broken! They import the pinned nixpkgs
-- in an incorrect way. GitHub thunks for public repositories with no
-- submodules will still work, but update as soon as possible.
gitThunkSpecV6 :: ThunkSpec
gitThunkSpecV6 :: ThunkSpec
gitThunkSpecV6 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"git-v6" String
"git.json" ByteString -> Either String ThunkPtr
parseGitJsonBytes Text
[here|
# DO NOT HAND-EDIT THIS FILE
let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
  let realUrl = let firstChar = builtins.substring 0 1 url; in
    if firstChar == "/" then /. + url
    else if firstChar == "." then ./. + url
    else url;
  in if !fetchSubmodules && private then builtins.fetchGit {
    url = realUrl; inherit rev;
    ${if branch == null then null else "ref"} = branch;
  } else (builtins.fetchTarball {
  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
}).fetchgit {
    url = realUrl; inherit rev sha256;
  };
  json = builtins.fromJSON (builtins.readFile ./git.json);
in fetch json
|]

-- | Specification for Git thunks which use a specific, pinned version
-- of nixpkgs for fetching, rather than using @<nixpkgs>@ from
-- @NIX_PATH@. The "v7" specs ensure that thunks can be fetched even
-- when @NIX_PATH@ is unset.
gitThunkSpecV7 :: ThunkSpec
gitThunkSpecV7 :: ThunkSpec
gitThunkSpecV7 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"git-v7" String
"git.json" ByteString -> Either String ThunkPtr
parseGitJsonBytes [i|# DO NOT HAND-EDIT THIS FILE
let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
  let realUrl = let firstChar = builtins.substring 0 1 url; in
    if firstChar == "/" then /. + url
    else if firstChar == "." then ./. + url
    else url;
  in if !fetchSubmodules && private then builtins.fetchGit {
    url = realUrl; inherit rev;
    \${if branch == null then null else "ref"} = branch;
  } else (import ${pinnedNixpkgsPath} {}).fetchgit {
    url = realUrl; inherit rev sha256;
  };
  json = builtins.fromJSON (builtins.readFile ./git.json);
in fetch json|]

-- | Specification for Git thunks which use a specific, pinned version
-- version of nixpkgs for fetching, rather than using @<nixpkgs>@ from
-- @NIX_PATH@.
--
-- Unlike 'gitHubThunKSpecV7', this thunk specification fetches the
-- nixpkgs tarball from GitHub, so it will fail on environments without
-- a network connection.
gitThunkSpecV8 :: ThunkSpec
gitThunkSpecV8 :: ThunkSpec
gitThunkSpecV8 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"git-v8" String
"git.json" ByteString -> Either String ThunkPtr
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 :: ThunkSpec
gitThunkSpecV9 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
"git-v9" String
"git.json" ByteString -> Either String ThunkPtr
parseGitHubJsonBytes Text
[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 :: ByteString -> Either String ThunkPtr
parseGitJsonBytes = (Object -> Parser ThunkPtr) -> ByteString -> Either String ThunkPtr
forall a. (Object -> Parser a) -> ByteString -> Either String a
parseJsonObject ((Object -> Parser ThunkPtr)
 -> ByteString -> Either String ThunkPtr)
-> (Object -> Parser ThunkPtr)
-> ByteString
-> Either String ThunkPtr
forall a b. (a -> b) -> a -> b
$ (Object -> Parser ThunkSource) -> Object -> Parser ThunkPtr
parseThunkPtr ((Object -> Parser ThunkSource) -> Object -> Parser ThunkPtr)
-> (Object -> Parser ThunkSource) -> Object -> Parser ThunkPtr
forall a b. (a -> b) -> a -> b
$ (GitSource -> ThunkSource)
-> Parser GitSource -> Parser ThunkSource
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GitSource -> ThunkSource
ThunkSource_Git (Parser GitSource -> Parser ThunkSource)
-> (Object -> Parser GitSource) -> Object -> Parser ThunkSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Parser GitSource
parseGitSource

mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
mkThunkSpec :: Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec Text
name String
jsonFileName ByteString -> Either String ThunkPtr
parser Text
srcNix = Text -> Map String ThunkFileSpec -> ThunkSpec
ThunkSpec Text
name (Map String ThunkFileSpec -> ThunkSpec)
-> Map String ThunkFileSpec -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [(String, ThunkFileSpec)] -> Map String ThunkFileSpec
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (String
"default.nix", Text -> ThunkFileSpec
ThunkFileSpec_FileMatches Text
defaultNixViaSrc)
  , (String
"thunk.nix", Text -> ThunkFileSpec
ThunkFileSpec_FileMatches Text
srcNix)
  , (String
jsonFileName, (ByteString -> Either String ThunkPtr) -> ThunkFileSpec
ThunkFileSpec_Ptr ByteString -> Either String ThunkPtr
parser)
  , (String
attrCacheFileName, ThunkFileSpec
ThunkFileSpec_AttrCache)
  , (ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
unpackedDirName String -> ShowS
</> String
".git", ThunkFileSpec
ThunkFileSpec_CheckoutIndicator)
  ]
  where
    defaultNixViaSrc :: Text
defaultNixViaSrc = Text
[here|
# DO NOT HAND-EDIT THIS FILE
import (import ./thunk.nix)
|]


parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
parseJsonObject :: forall a. (Object -> Parser a) -> ByteString -> Either String a
parseJsonObject Object -> Parser a
p ByteString
bytes = (Object -> Parser a) -> Object -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
Aeson.parseEither Object -> Parser a
p (Object -> Either String a)
-> Either String Object -> Either String a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> Either String Object
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
bytes

-- | Checks a cache directory to see if there is a fresh symlink
-- to the result of building an attribute of a thunk.
-- If no cache hit is found, nix-build is called to build the attribute
-- and the result is symlinked into the cache.
nixBuildThunkAttrWithCache
  :: ( MonadIO m
     , MonadLog Output m
     , HasCliConfig NixThunkError m
     , MonadMask m
     , MonadError NixThunkError m
     , MonadFail m
     )
  => ThunkSpec
  -> FilePath
  -- ^ Path to directory containing Thunk
  -> String
  -- ^ Attribute to build
  -> m (Maybe FilePath)
  -- ^ Symlink to cached or built nix output
-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
-- the caching mechanism will fail as it merely measures the modification
-- time of the cache link and the expression to build.
nixBuildThunkAttrWithCache :: forall (m :: * -> *).
(MonadIO m, MonadLog Output m, HasCliConfig NixThunkError m,
 MonadMask m, MonadError NixThunkError m, MonadFail m) =>
ThunkSpec -> String -> String -> m (Maybe String)
nixBuildThunkAttrWithCache ThunkSpec
thunkSpec String
thunkDir String
attr = do
  latestChange <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> m UTCTime) -> IO UTCTime -> m UTCTime
forall a b. (a -> b) -> a -> b
$ do
    let
      getModificationTimeMaybe :: String -> IO (Maybe UTCTime)
getModificationTimeMaybe = (Either IOError UTCTime -> Maybe UTCTime)
-> IO (Either IOError UTCTime) -> IO (Maybe UTCTime)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either IOError UTCTime -> Maybe UTCTime
forall a b. Either a b -> Maybe b
rightToMaybe (IO (Either IOError UTCTime) -> IO (Maybe UTCTime))
-> (String -> IO (Either IOError UTCTime))
-> String
-> IO (Maybe UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try @IOError (IO UTCTime -> IO (Either IOError UTCTime))
-> (String -> IO UTCTime) -> String -> IO (Either IOError UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO UTCTime
getModificationTime
      thunkFileNames :: [String]
thunkFileNames = String -> [String] -> [String]
forall a. Eq a => a -> [a] -> [a]
L.delete String
attrCacheFileName ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Map String ThunkFileSpec -> [String]
forall k a. Map k a -> [k]
Map.keys (Map String ThunkFileSpec -> [String])
-> Map String ThunkFileSpec -> [String]
forall a b. (a -> b) -> a -> b
$ ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files ThunkSpec
thunkSpec
    [UTCTime] -> UTCTime
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([UTCTime] -> UTCTime)
-> ([Maybe UTCTime] -> [UTCTime]) -> [Maybe UTCTime] -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe UTCTime] -> [UTCTime]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UTCTime] -> UTCTime) -> IO [Maybe UTCTime] -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe UTCTime)) -> [String] -> IO [Maybe UTCTime]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String -> IO (Maybe UTCTime)
getModificationTimeMaybe (String -> IO (Maybe UTCTime))
-> ShowS -> String -> IO (Maybe UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
thunkDir String -> ShowS
</>)) [String]
thunkFileNames

  let cachePaths' = [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([String] -> Maybe (NonEmpty String))
-> [String] -> Maybe (NonEmpty String)
forall a b. (a -> b) -> a -> b
$ Map String ThunkFileSpec -> [String]
forall k a. Map k a -> [k]
Map.keys (Map String ThunkFileSpec -> [String])
-> Map String ThunkFileSpec -> [String]
forall a b. (a -> b) -> a -> b
$ (ThunkFileSpec -> Bool)
-> Map String ThunkFileSpec -> Map String ThunkFileSpec
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\case ThunkFileSpec
ThunkFileSpec_AttrCache -> Bool
True; ThunkFileSpec
_ -> Bool
False) (Map String ThunkFileSpec -> Map String ThunkFileSpec)
-> Map String ThunkFileSpec -> Map String ThunkFileSpec
forall a b. (a -> b) -> a -> b
$
                      ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files ThunkSpec
thunkSpec
  for cachePaths' $ \NonEmpty String
cachePaths ->
    (NonEmpty String -> String) -> m (NonEmpty String) -> m String
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty String -> String
forall a. NonEmpty a -> a
NonEmpty.head (m (NonEmpty String) -> m String)
-> m (NonEmpty String) -> m String
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> (String -> m String) -> m (NonEmpty String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for NonEmpty String
cachePaths ((String -> m String) -> m (NonEmpty String))
-> (String -> m String) -> m (NonEmpty String)
forall a b. (a -> b) -> a -> b
$ \String
cacheDir -> do
      let
        cachePath :: String
cachePath = String
thunkDir String -> ShowS
</> String
cacheDir String -> ShowS
</> String
attr String -> ShowS
<.> String
"out"
        cacheErrHandler :: IOError -> f (Maybe a)
cacheErrHandler IOError
e
          | IOError -> Bool
isDoesNotExistError IOError
e = Maybe a -> f (Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing -- expected from a cache miss
          | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing Maybe a -> f () -> f (Maybe a)
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Severity -> Text -> f ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Error (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOError -> String
forall e. Exception e => e -> String
displayException IOError
e)
      cacheHit <- (IOError -> m (Maybe String))
-> m (Maybe String) -> m (Maybe String)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOError -> m (Maybe String)
forall {f :: * -> *} {a}. CliLog f => IOError -> f (Maybe a)
cacheErrHandler (m (Maybe String) -> m (Maybe String))
-> m (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
        cacheTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> m UTCTime) -> IO UTCTime -> m UTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (FileStatus -> POSIXTime) -> FileStatus -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochTime -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (EpochTime -> POSIXTime)
-> (FileStatus -> EpochTime) -> FileStatus -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> EpochTime
modificationTime (FileStatus -> UTCTime) -> IO FileStatus -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getSymbolicLinkStatus String
cachePath
        pure $ if latestChange <= cacheTime
          then Just cachePath
          else Nothing
      case cacheHit of
        Just String
c -> String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
c
        Maybe String
Nothing -> do
          Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String
thunkDir, String
": ", String
attr, String
" not cached, building ..."]
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
cachePath)
          (String
cachePath String -> m String -> m String
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ NixCmd -> m String
forall (m :: * -> *) e.
(MonadIO m, MonadMask m, MonadLog Output m, HasCliConfig e m,
 MonadError e m, AsProcessFailure e, MonadFail m) =>
NixCmd -> m String
nixCmd (NixCmd -> m String) -> NixCmd -> m String
forall a b. (a -> b) -> a -> b
$ NixBuildConfig -> NixCmd
NixCmd_Build (NixBuildConfig -> NixCmd) -> NixBuildConfig -> NixCmd
forall a b. (a -> b) -> a -> b
$ NixBuildConfig
forall a. Default a => a
def
            NixBuildConfig
-> (NixBuildConfig -> NixBuildConfig) -> NixBuildConfig
forall a b. a -> (a -> b) -> b
& (OutLink -> Identity OutLink)
-> NixBuildConfig -> Identity NixBuildConfig
Lens' NixBuildConfig OutLink
nixBuildConfig_outLink ((OutLink -> Identity OutLink)
 -> NixBuildConfig -> Identity NixBuildConfig)
-> OutLink -> NixBuildConfig -> NixBuildConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> OutLink
OutLink_IndirectRoot String
cachePath
            NixBuildConfig
-> (NixBuildConfig -> NixBuildConfig) -> NixBuildConfig
forall a b. a -> (a -> b) -> b
& (Target -> Identity Target)
-> NixBuildConfig -> Identity NixBuildConfig
forall c. HasNixCommonConfig c => Lens' c Target
Lens' NixBuildConfig Target
nixCmdConfig_target ((Target -> Identity Target)
 -> NixBuildConfig -> Identity NixBuildConfig)
-> Target -> NixBuildConfig -> NixBuildConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Target
              { _target_path :: Maybe String
_target_path = String -> Maybe String
forall a. a -> Maybe a
Just String
thunkDir
              , _target_attr :: Maybe String
_target_attr = String -> Maybe String
forall a. a -> Maybe a
Just String
attr
              , _target_expr :: Maybe String
_target_expr = Maybe String
forall a. Maybe a
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 :: forall (m :: * -> *).
(MonadLog Output m, HasCliConfig NixThunkError m, MonadIO m,
 MonadMask m, MonadError NixThunkError m, MonadFail m) =>
String -> String -> m String
nixBuildAttrWithCache String
exprPath String
attr = String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk String
exprPath m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m String) -> m String
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  -- Only packed thunks are cached. In particular, checkouts are not.
  Right (ThunkData_Packed ThunkSpec
spec ThunkPtr
_) ->
    m String -> (String -> m String) -> Maybe String -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m String
build String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> m String) -> m (Maybe String) -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ThunkSpec -> String -> String -> m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadLog Output m, HasCliConfig NixThunkError m,
 MonadMask m, MonadError NixThunkError m, MonadFail m) =>
ThunkSpec -> String -> String -> m (Maybe String)
nixBuildThunkAttrWithCache ThunkSpec
spec String
exprPath String
attr
  Either ReadThunkError ThunkData
_ -> m String
build
  where
    build :: m String
build = NixCmd -> m String
forall (m :: * -> *) e.
(MonadIO m, MonadMask m, MonadLog Output m, HasCliConfig e m,
 MonadError e m, AsProcessFailure e, MonadFail m) =>
NixCmd -> m String
nixCmd (NixCmd -> m String) -> NixCmd -> m String
forall a b. (a -> b) -> a -> b
$ NixBuildConfig -> NixCmd
NixCmd_Build (NixBuildConfig -> NixCmd) -> NixBuildConfig -> NixCmd
forall a b. (a -> b) -> a -> b
$ NixBuildConfig
forall a. Default a => a
def
      NixBuildConfig
-> (NixBuildConfig -> NixBuildConfig) -> NixBuildConfig
forall a b. a -> (a -> b) -> b
& (OutLink -> Identity OutLink)
-> NixBuildConfig -> Identity NixBuildConfig
Lens' NixBuildConfig OutLink
nixBuildConfig_outLink ((OutLink -> Identity OutLink)
 -> NixBuildConfig -> Identity NixBuildConfig)
-> OutLink -> NixBuildConfig -> NixBuildConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ OutLink
OutLink_None
      NixBuildConfig
-> (NixBuildConfig -> NixBuildConfig) -> NixBuildConfig
forall a b. a -> (a -> b) -> b
& (Target -> Identity Target)
-> NixBuildConfig -> Identity NixBuildConfig
forall c. HasNixCommonConfig c => Lens' c Target
Lens' NixBuildConfig Target
nixCmdConfig_target ((Target -> Identity Target)
 -> NixBuildConfig -> Identity NixBuildConfig)
-> Target -> NixBuildConfig -> NixBuildConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Target
        { _target_path :: Maybe String
_target_path = String -> Maybe String
forall a. a -> Maybe a
Just String
exprPath
        , _target_attr :: Maybe String
_target_attr = String -> Maybe String
forall a. a -> Maybe a
Just String
attr
        , _target_expr :: Maybe String
_target_expr = Maybe String
forall a. Maybe a
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 :: forall (m :: * -> *) a.
MonadNixThunk m =>
String -> (String -> m a) -> m a
updateThunk String
p String -> m a
f = String -> (String -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"obelisk-thunkptr-" ((String -> m a) -> m a) -> (String -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \String
tmpDir -> do
  p' <- String -> String -> m String
forall (m :: * -> *).
(MonadLog Output m, HasCliConfig NixThunkError m, MonadIO m,
 MonadMask m, MonadError NixThunkError m, MonadFail m) =>
String -> String -> m String
copyThunkToTmp String
tmpDir String
p
  unpackThunk' True p'
  result <- f p'
  updateThunkFromTmp p'
  return result
  where
    copyThunkToTmp :: String -> String -> m String
copyThunkToTmp String
tmpDir String
thunkDir = String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk String
thunkDir m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m String) -> m String
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left ReadThunkError
err -> Text -> ReadThunkError -> m String
forall (m :: * -> *) a.
MonadError NixThunkError m =>
Text -> ReadThunkError -> m a
failReadThunkErrorWhile Text
"during an update" ReadThunkError
err
      Right ThunkData_Packed{} -> do
        let tmpThunk :: String
tmpThunk = String
tmpDir String -> ShowS
</> String
"thunk"
        (Severity, Severity) -> ProcessSpec -> m ()
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadMask m) =>
(Severity, Severity) -> ProcessSpec -> m ()
callProcessAndLogOutput (Severity
Notice, Severity
Error) (ProcessSpec -> m ()) -> ProcessSpec -> m ()
forall a b. (a -> b) -> a -> b
$
          String -> [String] -> ProcessSpec
proc String
cp [String
"-r", String
"-T", String
thunkDir, String
tmpThunk]
        String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
tmpThunk
      Right ThunkData
_ -> Text -> m String
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith Text
"Thunk is not packed"
    updateThunkFromTmp :: String -> m ()
updateThunkFromTmp String
p' = do
      _ <- Bool -> ThunkPackConfig -> String -> m ThunkPtr
forall (m :: * -> *).
MonadNixThunk m =>
Bool -> ThunkPackConfig -> String -> m ThunkPtr
packThunk' Bool
True (Bool -> ThunkConfig -> ThunkPackConfig
ThunkPackConfig Bool
False (Maybe Bool -> ThunkConfig
ThunkConfig Maybe Bool
forall a. Maybe a
Nothing)) String
p'
      callProcessAndLogOutput (Notice, Error) $
        proc cp ["-r", "-T", p', p]

finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
finalMsg :: forall a. Bool -> (a -> Text) -> Maybe (a -> Text)
finalMsg Bool
noTrail a -> Text
s = if Bool
noTrail then Maybe (a -> Text)
forall a. Maybe a
Nothing else (a -> Text) -> Maybe (a -> Text)
forall a. a -> Maybe a
Just a -> Text
s

-- | Check that we are not somewhere inside the thunk directory
checkThunkDirectory :: MonadNixThunk m => FilePath -> m ()
checkThunkDirectory :: forall (m :: * -> *). MonadNixThunk m => String -> m ()
checkThunkDirectory String
thunkDir = do
  currentDir <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
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 ThunkData
_ -> Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
      Left ReadThunkError
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

unpackThunk :: MonadNixThunk m => FilePath -> m ()
unpackThunk :: forall (m :: * -> *). MonadNixThunk m => String -> m ()
unpackThunk = Bool -> String -> m ()
forall (m :: * -> *). MonadNixThunk m => Bool -> String -> m ()
unpackThunk' Bool
False

unpackThunk' :: MonadNixThunk m => Bool -> FilePath -> m ()
unpackThunk' :: forall (m :: * -> *). MonadNixThunk m => Bool -> String -> m ()
unpackThunk' Bool
noTrail String
thunkDir = String -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> m ()
checkThunkDirectory String
thunkDir m ()
-> m (Either ReadThunkError ThunkData)
-> m (Either ReadThunkError ThunkData)
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk String
thunkDir m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left ReadThunkError
err -> Text -> ReadThunkError -> m ()
forall (m :: * -> *) a.
MonadError NixThunkError m =>
Text -> ReadThunkError -> m a
failReadThunkErrorWhile Text
"while unpacking" ReadThunkError
err
  --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
  Right ThunkData
ThunkData_Checkout -> Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Thunk at ${thunkDir} is already unpacked|]
  Right (ThunkData_Packed ThunkSpec
_ ThunkPtr
tptr) -> do
    let (String
thunkParent, String
thunkName) = String -> (String, String)
splitFileName String
thunkDir
    String -> String -> (String -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
withTempDirectory String
thunkParent String
thunkName ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
tmpThunk -> do
      let
        gitSrc :: GitSource
gitSrc = ThunkSource -> GitSource
thunkSourceToGitSource (ThunkSource -> GitSource) -> ThunkSource -> GitSource
forall a b. (a -> b) -> a -> b
$ ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
tptr
        newSpec :: ThunkSpec
newSpec = case ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
tptr of
          ThunkSource_GitHub GitHubSource
_ -> NonEmpty ThunkSpec -> ThunkSpec
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty ThunkSpec
gitHubThunkSpecs
          ThunkSource_Git GitSource
_ -> NonEmpty ThunkSpec -> ThunkSpec
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty ThunkSpec
gitThunkSpecs
      Text -> Maybe (() -> Text) -> m () -> m ()
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
Text -> Maybe (a -> Text) -> m a -> m a
withSpinner' (Text
"Fetching thunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
thunkName)
                   (Bool -> (() -> Text) -> Maybe (() -> Text)
forall a. Bool -> (a -> Text) -> Maybe (a -> Text)
finalMsg Bool
noTrail ((() -> Text) -> Maybe (() -> Text))
-> (() -> Text) -> Maybe (() -> Text)
forall a b. (a -> b) -> a -> b
$ Text -> () -> Text
forall a b. a -> b -> a
const (Text -> () -> Text) -> Text -> () -> Text
forall a b. (a -> b) -> a -> b
$ Text
"Fetched thunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
thunkName) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        let unpackedPath :: String
unpackedPath = String
tmpThunk String -> ShowS
</> String
unpackedDirName
        GitSource -> Ref SHA1 -> String -> m ()
forall (m :: * -> *) hash.
MonadNixThunk m =>
GitSource -> Ref hash -> String -> m ()
gitCloneForThunkUnpack GitSource
gitSrc (ThunkRev -> Ref SHA1
_thunkRev_commit (ThunkRev -> Ref SHA1) -> ThunkRev -> Ref SHA1
forall a b. (a -> b) -> a -> b
$ ThunkPtr -> ThunkRev
_thunkPtr_rev ThunkPtr
tptr) String
unpackedPath

        let normalizeMore :: ShowS
normalizeMore = ShowS
dropTrailingPathSeparator ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normalise
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ShowS
normalizeMore String
unpackedPath String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ShowS
normalizeMore String
tmpThunk) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ -- Only write meta data if the checkout is not inplace
          String -> Either ThunkSpec ThunkPtr -> m ()
forall (m :: * -> *).
MonadNixThunk m =>
String -> Either ThunkSpec ThunkPtr -> m ()
createThunk String
tmpThunk (Either ThunkSpec ThunkPtr -> m ())
-> Either ThunkSpec ThunkPtr -> m ()
forall a b. (a -> b) -> a -> b
$ ThunkSpec -> Either ThunkSpec ThunkPtr
forall a b. a -> Either a b
Left ThunkSpec
newSpec

        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          String -> IO ()
removePathForcibly String
thunkDir
          String -> String -> IO ()
renameDirectory String
tmpThunk String
thunkDir

gitCloneForThunkUnpack
  :: MonadNixThunk m
  => GitSource -- ^ Git source to use
  -> Ref hash -- ^ Commit hash to reset to
  -> FilePath -- ^ Directory to clone into
  -> m ()
gitCloneForThunkUnpack :: forall (m :: * -> *) hash.
MonadNixThunk m =>
GitSource -> Ref hash -> String -> m ()
gitCloneForThunkUnpack GitSource
gitSrc Ref hash
commit String
dir = do
  _ <- String -> [String] -> m Text
forall (m :: * -> *).
MonadNixThunk m =>
String -> [String] -> m Text
readGitProcess String
dir ([String] -> m Text) -> [String] -> m Text
forall a b. (a -> b) -> a -> b
$ [ String
"clone" ]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++  [String
"--recursive" | GitSource -> Bool
_gitSource_fetchSubmodules GitSource
gitSrc]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++  [ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ GitUri -> Text
gitUriToText (GitUri -> Text) -> GitUri -> Text
forall a b. (a -> b) -> a -> b
$ GitSource -> GitUri
_gitSource_url GitSource
gitSrc ]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++  do branch <- Maybe (Name Branch) -> [Name Branch]
forall a. Maybe a -> [a]
maybeToList (Maybe (Name Branch) -> [Name Branch])
-> Maybe (Name Branch) -> [Name Branch]
forall a b. (a -> b) -> a -> b
$ GitSource -> Maybe (Name Branch)
_gitSource_branch GitSource
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 :: forall (m :: * -> *).
MonadNixThunk m =>
String -> String -> CreateWorktreeConfig -> m ()
createWorktree String
thunkDir String
gitDir CreateWorktreeConfig
config = String -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> m ()
checkThunkDirectory String
thunkDir m ()
-> m (Either ReadThunkError ThunkData)
-> m (Either ReadThunkError ThunkData)
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk String
thunkDir m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left ReadThunkError
err -> Text -> ReadThunkError -> m ()
forall (m :: * -> *) a.
MonadError NixThunkError m =>
Text -> ReadThunkError -> m a
failReadThunkErrorWhile Text
"while creating worktree" ReadThunkError
err
  Right ThunkData
ThunkData_Checkout -> Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Thunk at ${thunkDir} is already unpacked|]
  Right (ThunkData_Packed ThunkSpec
_ ThunkPtr
tptr) -> do

    String -> ThunkPtr -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> ThunkPtr -> m ()
ensureGitRevExist String
gitDir ThunkPtr
tptr

    let (String
thunkParent, String
thunkName) = String -> (String, String)
splitFileName String
thunkDir
    String -> String -> (String -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
withTempDirectory String
thunkParent String
thunkName ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
tmpThunk -> do
      Text -> Maybe (() -> Text) -> m () -> m ()
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
Text -> Maybe (a -> Text) -> m a -> m a
withSpinner' (Text
"Creating worktree for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
thunkName)
                   ((() -> Text) -> Maybe (() -> Text)
forall a. a -> Maybe a
Just (Text -> () -> Text
forall a b. a -> b -> a
const (Text -> () -> Text) -> Text -> () -> Text
forall a b. (a -> b) -> a -> b
$ Text
"Created worktree for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
thunkName)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        currentDir <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
        let worktreePath = String
currentDir String -> ShowS
</> String
tmpThunk String -> ShowS
</> String
unpackedDirName
            thunkFullPath = String
currentDir String -> ShowS
</> String
thunkDir String -> ShowS
</> String
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 -> Maybe String
_createWorktreeConfig_branch CreateWorktreeConfig
config of
              Just String
b -> String -> Maybe String
forall a. a -> Maybe a
Just String
b
              Maybe String
_ -> Text -> String
T.unpack (Text -> String) -> (Name Branch -> Text) -> Name Branch -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name Branch -> Text
forall entity. Name entity -> Text
untagName (Name Branch -> String) -> Maybe (Name Branch) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GitSource -> Maybe (Name Branch)
_gitSource_branch (ThunkSource -> GitSource
thunkSourceToGitSource (ThunkSource -> GitSource) -> ThunkSource -> GitSource
forall a b. (a -> b) -> a -> b
$ ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
tptr)

        _ <- readGitProcess gitDir $
          [ "worktree", "add"
          , worktreePath
          , refToHexString (_thunkRev_commit $ _thunkPtr_rev tptr)
          ] ++ (if _createWorktreeConfig_detach config
                then ["-d"]
                else maybe [] (\String
b -> [String
"-b",  String
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 :: forall (m :: * -> *). MonadNixThunk m => String -> ThunkPtr -> m ()
ensureGitRevExist String
gitDir ThunkPtr
tptr = do
  isdir <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
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 :: forall (m :: * -> *).
MonadNixThunk m =>
String -> [String] -> m Text
readGitProcess String
dir = (Severity, Severity) -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
 MonadFail m) =>
(Severity, Severity) -> ProcessSpec -> m Text
readProcessAndLogOutput (Severity
Notice, Severity
Notice) (ProcessSpec -> m Text)
-> ([String] -> ProcessSpec) -> [String] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessSpec -> ProcessSpec
ignoreGitConfig (ProcessSpec -> ProcessSpec)
-> ([String] -> ProcessSpec) -> [String] -> ProcessSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> ProcessSpec
gitProc String
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 :: ProcessSpec -> ProcessSpec
ignoreGitConfig = (Map String String -> Map String String)
-> ProcessSpec -> ProcessSpec
setEnvOverride (Map String String
envfix Map String String -> Map String String -> Map String String
forall a. Semigroup a => a -> a -> a
<>)
  where
    -- Ignore both global (user's) and system (... system-wide) git
    -- configuration.
    envfix :: Map String String
envfix = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (String
"GIT_CONFIG_NOSYSTEM", String
"yes")
      -- Git documentation says GIT_CONFIG_GLOBAL=/dev/null should
      -- prevent it from reading the global config file but that's a
      -- lie, actually.
      , (String
"HOME", String
"/dev/null")
      , (String
"XDG_CONFIG_HOME", String
"/dev/null")
      ]

--TODO: add a rollback mode to pack to the original thunk
packThunk :: MonadNixThunk m => ThunkPackConfig -> FilePath -> m ThunkPtr
packThunk :: forall (m :: * -> *).
MonadNixThunk m =>
ThunkPackConfig -> String -> m ThunkPtr
packThunk = Bool -> ThunkPackConfig -> String -> m ThunkPtr
forall (m :: * -> *).
MonadNixThunk m =>
Bool -> ThunkPackConfig -> String -> m ThunkPtr
packThunk' Bool
False

packThunk' :: MonadNixThunk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
packThunk' :: forall (m :: * -> *).
MonadNixThunk m =>
Bool -> ThunkPackConfig -> String -> m ThunkPtr
packThunk' Bool
noTrail (ThunkPackConfig Bool
force ThunkConfig
thunkConfig) String
thunkDir = String -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> m ()
checkThunkDirectory String
thunkDir m ()
-> m (Either ReadThunkError ThunkData)
-> m (Either ReadThunkError ThunkData)
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk String
thunkDir m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m ThunkPtr) -> m ThunkPtr
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Right ThunkData_Packed{} -> Text -> m ThunkPtr
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Thunk at ${thunkDir} is is already packed|]
  Either ReadThunkError ThunkData
_ -> Text -> Maybe (ThunkPtr -> Text) -> m ThunkPtr -> m ThunkPtr
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
Text -> Maybe (a -> Text) -> m a -> m a
withSpinner'
    (Text
"Packing thunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
thunkDir)
    (Bool -> (ThunkPtr -> Text) -> Maybe (ThunkPtr -> Text)
forall a. Bool -> (a -> Text) -> Maybe (a -> Text)
finalMsg Bool
noTrail ((ThunkPtr -> Text) -> Maybe (ThunkPtr -> Text))
-> (ThunkPtr -> Text) -> Maybe (ThunkPtr -> Text)
forall a b. (a -> b) -> a -> b
$ Text -> ThunkPtr -> Text
forall a b. a -> b -> a
const (Text -> ThunkPtr -> Text) -> Text -> ThunkPtr -> Text
forall a b. (a -> b) -> a -> b
$ Text
"Packed thunk " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
thunkDir) (m ThunkPtr -> m ThunkPtr) -> m ThunkPtr -> m ThunkPtr
forall a b. (a -> b) -> a -> b
$
    do
      let checkClean :: CheckClean
checkClean = if Bool
force then CheckClean
CheckClean_NoCheck else CheckClean
CheckClean_FullCheck
      (thunkPtr, isWorktree) <- (ThunkPtr -> ThunkPtr) -> (ThunkPtr, Bool) -> (ThunkPtr, Bool)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ThunkConfig -> ThunkPtr -> ThunkPtr
modifyThunkPtrByConfig ThunkConfig
thunkConfig)
        ((ThunkPtr, Bool) -> (ThunkPtr, Bool))
-> m (ThunkPtr, Bool) -> m (ThunkPtr, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckClean -> String -> Maybe Bool -> m (ThunkPtr, Bool)
forall (m :: * -> *).
MonadNixThunk m =>
CheckClean -> String -> Maybe Bool -> m (ThunkPtr, Bool)
getThunkPtr CheckClean
checkClean String
thunkDir (ThunkConfig -> Maybe Bool
_thunkConfig_private ThunkConfig
thunkConfig)
      if isWorktree
        then void $ do
          -- Remove the branch locally, and then remove the worktree
          case _gitSource_branch $ thunkSourceToGitSource $ _thunkPtr_source thunkPtr of
            Just Name Branch
branch -> do
              m Text -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Text -> m ()) -> m Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> m Text
forall (m :: * -> *).
MonadNixThunk m =>
String -> [String] -> m Text
readGitProcess String
thunkDir [String
"switch", String
"--detach"]
              m Text -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Text -> m ()) -> m Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> m Text
forall (m :: * -> *).
MonadNixThunk m =>
String -> [String] -> m Text
readGitProcess String
thunkDir [String
"branch", String
"-d", Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Name Branch -> Text
forall entity. Name entity -> Text
untagName Name Branch
branch]
            Maybe (Name Branch)
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Should never happen
          readGitProcess thunkDir ["worktree", "remove", "."]
        else liftIO $ removePathForcibly thunkDir
      createThunk thunkDir $ Right thunkPtr
      pure thunkPtr

modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
modifyThunkPtrByConfig (ThunkConfig Maybe Bool
markPrivate') ThunkPtr
ptr = case Maybe Bool
markPrivate' of
  Maybe Bool
Nothing -> ThunkPtr
ptr
  Just Bool
markPrivate -> ThunkPtr
ptr { _thunkPtr_source = case _thunkPtr_source ptr of
      ThunkSource_Git GitSource
s -> GitSource -> ThunkSource
ThunkSource_Git (GitSource -> ThunkSource) -> GitSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ GitSource
s { _gitSource_private = markPrivate }
      ThunkSource_GitHub GitHubSource
s -> GitHubSource -> ThunkSource
ThunkSource_GitHub (GitHubSource -> ThunkSource) -> GitHubSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ GitHubSource
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 :: forall (m :: * -> *).
MonadNixThunk m =>
CheckClean -> String -> Maybe Bool -> m (ThunkPtr, Bool)
getThunkPtr CheckClean
gitCheckClean String
dir Maybe Bool
mPrivate = do
  let repoLocations :: [(String, String)]
repoLocations = [(String, String)] -> [(String, String)]
forall a. Ord a => [a] -> [a]
nubOrd ([(String, String)] -> [(String, String)])
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ ((String, String) -> (String, String))
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS -> (String, String) -> (String, String)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ShowS
normalise)
        [(String
".git", String
"."), (String
unpackedDirName String -> ShowS
</> String
".git", String
unpackedDirName)]
  repoLocation' <- IO (Maybe (String, String)) -> m (Maybe (String, String))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (String, String)) -> m (Maybe (String, String)))
-> IO (Maybe (String, String)) -> m (Maybe (String, String))
forall a b. (a -> b) -> a -> b
$ (((String, String) -> IO Bool)
 -> [(String, String)] -> IO (Maybe (String, String)))
-> [(String, String)]
-> ((String, String) -> IO Bool)
-> IO (Maybe (String, String))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String, String) -> IO Bool)
-> [(String, String)] -> IO (Maybe (String, String))
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM [(String, String)]
repoLocations (((String, String) -> IO Bool) -> IO (Maybe (String, String)))
-> ((String, String) -> IO Bool) -> IO (Maybe (String, String))
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist (String -> IO Bool)
-> ((String, String) -> String) -> (String, String) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
dir String -> ShowS
</>) ShowS -> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst
  (thunkDir, isWorktree) <- case repoLocation' of
    Maybe (String, String)
Nothing -> do
      ff <- IO (Maybe (String, String)) -> m (Maybe (String, String))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (String, String)) -> m (Maybe (String, String)))
-> IO (Maybe (String, String)) -> m (Maybe (String, String))
forall a b. (a -> b) -> a -> b
$ (((String, String) -> IO Bool)
 -> [(String, String)] -> IO (Maybe (String, String)))
-> [(String, String)]
-> ((String, String) -> IO Bool)
-> IO (Maybe (String, String))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String, String) -> IO Bool)
-> [(String, String)] -> IO (Maybe (String, String))
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM [(String, String)]
repoLocations (((String, String) -> IO Bool) -> IO (Maybe (String, String)))
-> ((String, String) -> IO Bool) -> IO (Maybe (String, String))
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist (String -> IO Bool)
-> ((String, String) -> String) -> (String, String) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
dir String -> ShowS
</>) ShowS -> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst
      case ff of
        Maybe (String, String)
Nothing -> Text -> m (String, Bool)
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Can't find an unpacked thunk in ${dir}|]
        Just (String
gitPath, String
path) -> do
          Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Informational Text
"Couldn't find .git dir, looking for a worktree instead"
          fileContents <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile (String
dir String -> ShowS
</> String
gitPath)
          unless (T.isPrefixOf "gitdir: " fileContents) $ failWith [i|Can't find an unpacked thunk or worktree in ${dir}|]
          pure (normalise $ dir </> path, True)
    Just (String
_, String
path) -> (String, Bool) -> m (String, Bool)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
path, Bool
False)

  let (checkClean, checkIgnored) = case gitCheckClean of
        CheckClean
CheckClean_FullCheck -> (Bool
True, Bool
True)
        CheckClean
CheckClean_NotIgnored -> (Bool
True, Bool
False)
        CheckClean
CheckClean_NoCheck -> (Bool
False, Bool
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 Text
"HEAD") -> Text -> m (Maybe Text, Maybe Text)
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith (Text -> m (Maybe Text, Maybe Text))
-> Text -> m (Maybe Text, Maybe Text)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
        [ Text
"thunk pack: You are in 'detached HEAD' state."
        , Text
"If you want to pack at the current ref \
          \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
        ]
      Maybe Text
_ -> (Maybe Text, Maybe Text) -> m (Maybe Text, Maybe Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
b, Maybe Text
c)

  let refs = if Bool
isWorktree
        -- Get information on current branch only
        then String
"refs/heads/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" Text -> String
T.unpack Maybe Text
mCurrentBranch
        -- Get information on all branches and their (optional) designated
        -- upstream correspondents
        else String
"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 $ \Text
line -> do
      (branch : restOfLine) <- [Text] -> m [Text]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
line
      mUpstream <- case restOfLine of
        [] -> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, Text)
forall a. Maybe a
Nothing
        [Text
u, Text
r] -> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> m (Maybe (Text, Text)))
-> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
u, Text
r)
        (Text
_:[Text]
_) -> Text -> m (Maybe (Text, Text))
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith Text
"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
        Maybe (Text, Text)
Nothing -> () -> Either () (Text, Text)
forall a b. a -> Either a b
Left ()
        Just (Text, Text)
b -> (Text, Text) -> Either () (Text, Text)
forall a b. b -> Either a b
Right (Text, Text)
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 Text () -> [Text]
forall k a. Map k a -> [k]
Map.keys Map Text ()
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:"
      , ""
      ] ++
      ((\Text
branch -> Text
"git push -u origin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 $ \Text
branch (Text
upstream, Text
_remote) -> do
      (stat :: [Text]) <- Text -> [Text]
T.lines (Text -> [Text]) -> m Text -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> m Text
forall (m :: * -> *).
MonadNixThunk m =>
String -> [String] -> m Text
readGitProcess String
thunkDir
        [ String
"rev-list", String
"--left-right"
        , Text -> String
T.unpack Text
branch String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"..." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
upstream
        ]
      let ahead = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> [()] -> Int
forall a b. (a -> b) -> a -> b
$ [ () | Just (Char
'<', Text
_) <- Text -> Maybe (Char, Text)
T.uncons (Text -> Maybe (Char, Text)) -> [Text] -> [Maybe (Char, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
stat ]
          behind = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> [()] -> Int
forall a b. (a -> b) -> a -> b
$ [ () | Just (Char
'>', Text
_) <- Text -> Maybe (Char, Text)
T.uncons (Text -> Maybe (Char, Text)) -> [Text] -> [Maybe (Char, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
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 = ((Text, (Int, Int)) -> Bool)
-> Map Text (Text, (Int, Int)) -> Map Text (Text, (Int, Int))
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (Int -> Bool)
-> ((Text, (Int, Int)) -> Int) -> (Text, (Int, Int)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int)
-> ((Text, (Int, Int)) -> (Int, Int)) -> (Text, (Int, Int)) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd) Map Text (Text, (Int, Int))
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 = Text -> ((Text, Text) -> Text) -> Maybe (Text, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"origin" (Text, Text) -> Text
forall a b. (a, b) -> b
snd (Maybe (Text, Text) -> Text) -> Maybe (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Map Text (Text, Text) -> Maybe (Text, Text))
-> Map Text (Text, Text) -> Text -> Maybe (Text, Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Map Text (Text, Text) -> Maybe (Text, Text)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Text (Text, Text)
headUpstream (Text -> Maybe (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
mCurrentBranch

  [remoteUri'] <- T.lines <$> readGitProcess thunkDir
    [ "config"
    , "--get"
    , "remote." <> T.unpack remote <> ".url"
    ]

  remoteUri <- case parseGitUri remoteUri' of
    Maybe GitUri
Nothing -> Text -> m GitUri
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith (Text -> m GitUri) -> Text -> m GitUri
forall a b. (a -> b) -> a -> b
$ Text
"Could not identify git remote: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
remoteUri'
    Just GitUri
uri -> GitUri -> m GitUri
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GitUri
uri
  (, isWorktree) <$> uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit

-- | Get the latest revision available from the given source
getLatestRev :: MonadNixThunk m => ThunkSource -> m ThunkRev
getLatestRev :: forall (m :: * -> *). MonadNixThunk m => ThunkSource -> m ThunkRev
getLatestRev ThunkSource
os = do
  let gitS :: GitSource
gitS = ThunkSource -> GitSource
thunkSourceToGitSource ThunkSource
os
  (_, commit) <- GitUri -> Maybe Text -> m (Text, Text)
forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Text -> m (Text, Text)
gitGetCommitBranch (GitSource -> GitUri
_gitSource_url GitSource
gitS) (Name Branch -> Text
forall entity. Name entity -> Text
untagName (Name Branch -> Text) -> Maybe (Name Branch) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GitSource -> Maybe (Name Branch)
_gitSource_branch GitSource
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 :: forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
uriThunkPtr GitUri
uri Maybe Bool
mPrivate Maybe Text
mbranch Maybe Text
mcommit = do
  commit <- case Maybe Text
mcommit of
    Maybe Text
Nothing -> (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> m (Text, Text) -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GitUri -> Maybe Text -> m (Text, Text)
forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Text -> m (Text, Text)
gitGetCommitBranch GitUri
uri Maybe Text
mbranch
    (Just Text
c) -> Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
c
  (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
    ThunkSource_GitHub GitHubSource
s -> do
      rev <- ExceptT NixThunkError m ThunkRev
-> m (Either NixThunkError ThunkRev)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT NixThunkError m ThunkRev
 -> m (Either NixThunkError ThunkRev))
-> ExceptT NixThunkError m ThunkRev
-> m (Either NixThunkError ThunkRev)
forall a b. (a -> b) -> a -> b
$ GitHubSource -> Text -> ExceptT NixThunkError m ThunkRev
forall (m :: * -> *).
MonadNixThunk m =>
GitHubSource -> Text -> m ThunkRev
githubThunkRev GitHubSource
s Text
commit
      case rev of
        Right ThunkRev
r -> (ThunkSource, ThunkRev) -> m (ThunkSource, ThunkRev)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitHubSource -> ThunkSource
ThunkSource_GitHub GitHubSource
s, ThunkRev
r)
        Left NixThunkError
e -> do
          Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Warning Text
"\
\Failed to fetch archive from GitHub. This is probably a private repo. \
\Falling back on normal fetchgit. Original failure:"
          Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ NixThunkError -> Text
prettyNixThunkError NixThunkError
e
          let s' :: GitSource
s' = Bool -> GitHubSource -> GitSource
forgetGithub Bool
True GitHubSource
s
          (,) (GitSource -> ThunkSource
ThunkSource_Git GitSource
s') (ThunkRev -> (ThunkSource, ThunkRev))
-> m ThunkRev -> m (ThunkSource, ThunkRev)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GitSource -> Text -> m ThunkRev
forall (m :: * -> *).
MonadNixThunk m =>
GitSource -> Text -> m ThunkRev
gitThunkRev GitSource
s' Text
commit
    ThunkSource_Git GitSource
s -> (,) (GitSource -> ThunkSource
ThunkSource_Git GitSource
s) (ThunkRev -> (ThunkSource, ThunkRev))
-> m ThunkRev -> m (ThunkSource, ThunkRev)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GitSource -> Text -> m ThunkRev
forall (m :: * -> *).
MonadNixThunk m =>
GitSource -> Text -> m ThunkRev
gitThunkRev GitSource
s Text
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 :: forall (m :: * -> *).
MonadNixThunk m =>
ThunkCreateSource
-> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
thunkCreateSourcePtr ThunkCreateSource
source Maybe Bool
mPriv Maybe Text
mBranch Maybe Text
mCommit = do
  uri <- case ThunkCreateSource
source of
    ThunkCreateSource_Absolute GitUri
uri -> GitUri -> m GitUri
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GitUri
uri
    ThunkCreateSource_Relative String
dir -> do
      isdir <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
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 :: forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
uriToThunkSource (GitUri URI
u) Maybe Bool
mPrivate
  | Right Authority
uriAuth <- URI -> Either Bool Authority
URI.uriAuthority URI
u
  , Just Text
scheme <- RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
u
  , case Text
scheme of
      Text
"ssh" -> Authority
uriAuth Authority -> Authority -> Bool
forall a. Eq a => a -> a -> Bool
== URI.Authority
        { authUserInfo :: Maybe UserInfo
URI.authUserInfo = UserInfo -> Maybe UserInfo
forall a. a -> Maybe a
Just (UserInfo -> Maybe UserInfo) -> UserInfo -> Maybe UserInfo
forall a b. (a -> b) -> a -> b
$ RText 'Username -> Maybe (RText 'Password) -> UserInfo
URI.UserInfo (Either SomeException (RText 'Username) -> RText 'Username
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'Username) -> RText 'Username)
-> Either SomeException (RText 'Username) -> RText 'Username
forall a b. (a -> b) -> a -> b
$ Text -> Either SomeException (RText 'Username)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Username)
URI.mkUsername Text
"git") Maybe (RText 'Password)
forall a. Maybe a
Nothing
        , authHost :: RText 'Host
URI.authHost = Either SomeException (RText 'Host) -> RText 'Host
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'Host) -> RText 'Host)
-> Either SomeException (RText 'Host) -> RText 'Host
forall a b. (a -> b) -> a -> b
$ Text -> Either SomeException (RText 'Host)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Host)
URI.mkHost Text
"github.com"
        , authPort :: Maybe Word
URI.authPort = Maybe Word
forall a. Maybe a
Nothing
        }
      Text
s -> Text
s Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [ Text
"git", Text
"https", Text
"http" ] -- "http:" just redirects to "https:"
        Bool -> Bool -> Bool
&& RText 'Host -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (Authority -> RText 'Host
URI.authHost Authority
uriAuth) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"github.com"
  , Just (Bool
_, RText 'PathPiece
owner :| [RText 'PathPiece
repoish]) <- URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
u
  = \Maybe Text
mbranch -> do
      isPrivate <- m Bool
getIsPrivate
      pure $ ThunkSource_GitHub $ GitHubSource
        { _gitHubSource_owner = N $ URI.unRText owner
        , _gitHubSource_repo = N $ let
            repoish' = RText 'PathPiece -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText RText 'PathPiece
repoish
          in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
        , _gitHubSource_branch = N <$> mbranch
        , _gitHubSource_private = isPrivate
        }

  | Bool
otherwise = \Maybe Text
mbranch -> do
      isPrivate <- m Bool
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 :: m Bool
getIsPrivate = m Bool -> (Bool -> m Bool) -> Maybe Bool -> m Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GitUri -> m Bool
forall (m :: * -> *). MonadNixThunk m => GitUri -> m Bool
guessGitRepoIsPrivate (GitUri -> m Bool) -> GitUri -> m Bool
forall a b. (a -> b) -> a -> b
$ URI -> GitUri
GitUri URI
u) Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
mPrivate

guessGitRepoIsPrivate :: MonadNixThunk m => GitUri -> m Bool
guessGitRepoIsPrivate :: forall (m :: * -> *). MonadNixThunk m => GitUri -> m Bool
guessGitRepoIsPrivate GitUri
uri = ((([GitUri] -> m Bool) -> [GitUri] -> m Bool)
 -> [GitUri] -> m Bool)
-> [GitUri]
-> (([GitUri] -> m Bool) -> [GitUri] -> m Bool)
-> m Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([GitUri] -> m Bool) -> [GitUri] -> m Bool) -> [GitUri] -> m Bool
forall a. (a -> a) -> a
fix [GitUri]
urisToTry ((([GitUri] -> m Bool) -> [GitUri] -> m Bool) -> m Bool)
-> (([GitUri] -> m Bool) -> [GitUri] -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \[GitUri] -> m Bool
loop -> \case
  [] -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  GitUri
uriAttempt:[GitUri]
xs -> do
    result <- ProcessSpec -> m (ExitCode, String, String)
forall (m :: * -> *).
(MonadIO m, CliLog m) =>
ProcessSpec -> m (ExitCode, String, String)
readCreateProcessWithExitCode (ProcessSpec -> m (ExitCode, String, String))
-> ProcessSpec -> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$
      ProcessSpec -> ProcessSpec
isolateGitProc (ProcessSpec -> ProcessSpec) -> ProcessSpec -> ProcessSpec
forall a b. (a -> b) -> a -> b
$
        [String] -> ProcessSpec
gitProcNoRepo
          [ String
"ls-remote"
          , String
"--quiet"
          , String
"--exit-code"
          , String
"--symref"
          , Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ GitUri -> Text
gitUriToText GitUri
uriAttempt
          ]
    case result of
      (ExitCode
ExitSuccess, String
_, String
_) -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False -- Must be a public repo
      (ExitCode, String, String)
_ -> [GitUri] -> m Bool
loop [GitUri]
xs
  where
    urisToTry :: [GitUri]
urisToTry = [GitUri] -> [GitUri]
forall a. Ord a => [a] -> [a]
nubOrd ([GitUri] -> [GitUri]) -> [GitUri] -> [GitUri]
forall a b. (a -> b) -> a -> b
$
      -- Include the original URI if it isn't using SSH because SSH will certainly fail.
      [GitUri
uri | (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (URI -> Maybe (RText 'Scheme)
URI.uriScheme (GitUri -> URI
unGitUri GitUri
uri)) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ssh"] [GitUri] -> [GitUri] -> [GitUri]
forall a. Semigroup a => a -> a -> a
<>
      [Text -> GitUri -> GitUri
changeScheme Text
"https" GitUri
uri, Text -> GitUri -> GitUri
changeScheme Text
"http" GitUri
uri]
    changeScheme :: Text -> GitUri -> GitUri
changeScheme Text
scheme (GitUri URI
u) = URI -> GitUri
GitUri (URI -> GitUri) -> URI -> GitUri
forall a b. (a -> b) -> a -> b
$ URI
u
      { URI.uriScheme = URI.mkScheme scheme
      , URI.uriAuthority = (\Authority
x -> Authority
x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u
      }

getThunkRev
  :: forall m
  .  MonadNixThunk m
  => ThunkSource
  -> Text
  -> m ThunkRev
getThunkRev :: forall (m :: * -> *).
MonadNixThunk m =>
ThunkSource -> Text -> m ThunkRev
getThunkRev ThunkSource
os Text
commit = case ThunkSource
os of
  ThunkSource_GitHub GitHubSource
s -> GitHubSource -> Text -> m ThunkRev
forall (m :: * -> *).
MonadNixThunk m =>
GitHubSource -> Text -> m ThunkRev
githubThunkRev GitHubSource
s Text
commit
  ThunkSource_Git GitSource
s -> GitSource -> Text -> m ThunkRev
forall (m :: * -> *).
MonadNixThunk m =>
GitSource -> Text -> m ThunkRev
gitThunkRev GitSource
s Text
commit

-- Funny signature indicates no effects depend on the optional branch name.
githubThunkRev
  :: forall m
  .  MonadNixThunk m
  => GitHubSource
  -> Text
  -> m ThunkRev
githubThunkRev :: forall (m :: * -> *).
MonadNixThunk m =>
GitHubSource -> Text -> m ThunkRev
githubThunkRev GitHubSource
s Text
commit = do
  owner <- Name Owner -> m (RText 'PathPiece)
forall entity. Name entity -> m (RText 'PathPiece)
forcePP (Name Owner -> m (RText 'PathPiece))
-> Name Owner -> m (RText 'PathPiece)
forall a b. (a -> b) -> a -> b
$ GitHubSource -> Name Owner
_gitHubSource_owner GitHubSource
s
  repo <- forcePP $ _gitHubSource_repo s
  revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
  let archiveUri = URI -> GitUri
GitUri (URI -> GitUri) -> URI -> GitUri
forall a b. (a -> b) -> a -> b
$ URI.URI
        { uriScheme :: Maybe (RText 'Scheme)
URI.uriScheme = RText 'Scheme -> Maybe (RText 'Scheme)
forall a. a -> Maybe a
Just (RText 'Scheme -> Maybe (RText 'Scheme))
-> RText 'Scheme -> Maybe (RText 'Scheme)
forall a b. (a -> b) -> a -> b
$ Either SomeException (RText 'Scheme) -> RText 'Scheme
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'Scheme) -> RText 'Scheme)
-> Either SomeException (RText 'Scheme) -> RText 'Scheme
forall a b. (a -> b) -> a -> b
$ Text -> Either SomeException (RText 'Scheme)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Scheme)
URI.mkScheme Text
"https"
        , uriAuthority :: Either Bool Authority
URI.uriAuthority = Authority -> Either Bool Authority
forall a b. b -> Either a b
Right (Authority -> Either Bool Authority)
-> Authority -> Either Bool Authority
forall a b. (a -> b) -> a -> b
$ URI.Authority
          { authUserInfo :: Maybe UserInfo
URI.authUserInfo = Maybe UserInfo
forall a. Maybe a
Nothing
          , authHost :: RText 'Host
URI.authHost = Either SomeException (RText 'Host) -> RText 'Host
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'Host) -> RText 'Host)
-> Either SomeException (RText 'Host) -> RText 'Host
forall a b. (a -> b) -> a -> b
$ Text -> Either SomeException (RText 'Host)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Host)
URI.mkHost Text
"github.com"
          , authPort :: Maybe Word
URI.authPort = Maybe Word
forall a. Maybe a
Nothing
          }
        , uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath = (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. a -> Maybe a
Just ( Bool
False
                         , RText 'PathPiece
owner RText 'PathPiece
-> [RText 'PathPiece] -> NonEmpty (RText 'PathPiece)
forall a. a -> [a] -> NonEmpty a
:| [ RText 'PathPiece
repo, Either SomeException (RText 'PathPiece) -> RText 'PathPiece
forall a b. Either a b -> b
fromRight' (Either SomeException (RText 'PathPiece) -> RText 'PathPiece)
-> Either SomeException (RText 'PathPiece) -> RText 'PathPiece
forall a b. (a -> b) -> a -> b
$ Text -> Either SomeException (RText 'PathPiece)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'PathPiece)
URI.mkPathPiece Text
"archive", RText 'PathPiece
revTarball ]
                     )
    , uriQuery :: [QueryParam]
URI.uriQuery = []
    , uriFragment :: Maybe (RText 'Fragment)
URI.uriFragment = Maybe (RText 'Fragment)
forall a. Maybe a
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 :: forall entity. Name entity -> m (RText 'PathPiece)
forcePP = Text -> m (RText 'PathPiece)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'PathPiece)
URI.mkPathPiece (Text -> m (RText 'PathPiece))
-> (Name entity -> Text) -> Name entity -> m (RText 'PathPiece)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name entity -> Text
forall entity. Name entity -> Text
untagName

gitThunkRev
  :: MonadNixThunk m
  => GitSource
  -> Text
  -> m ThunkRev
gitThunkRev :: forall (m :: * -> *).
MonadNixThunk m =>
GitSource -> Text -> m ThunkRev
gitThunkRev GitSource
s Text
commit = do
  let u :: GitUri
u = GitSource -> GitUri
_gitSource_url GitSource
s
      protocols :: [Text]
protocols = [Text
"file", Text
"https", Text
"ssh", Text
"git"]
      scheme :: Text
scheme = Text -> (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"file" RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (Maybe (RText 'Scheme) -> Text) -> Maybe (RText 'Scheme) -> Text
forall a b. (a -> b) -> a -> b
$ URI -> Maybe (RText 'Scheme)
URI.uriScheme (URI -> Maybe (RText 'Scheme)) -> URI -> Maybe (RText 'Scheme)
forall a b. (a -> b) -> a -> b
$ (\(GitUri URI
x) -> URI
x) GitUri
u
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Text
T.toLower Text
scheme Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
protocols) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"obelisk currently only supports "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
protocols Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" protocols for plain Git remotes"
  hash <- GitUri -> Text -> Bool -> m Text
forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Text -> Bool -> m Text
nixPrefetchGit GitUri
u Text
commit (Bool -> m Text) -> Bool -> m Text
forall a b. (a -> b) -> a -> b
$ GitSource -> Bool
_gitSource_fetchSubmodules GitSource
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 :: forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Text -> m (Text, Text)
gitGetCommitBranch GitUri
uri Maybe Text
mbranch = Text -> m (Text, Text) -> m (Text, Text)
forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage (Text
"Failure for git remote " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uriMsg) (m (Text, Text) -> m (Text, Text))
-> m (Text, Text) -> m (Text, Text)
forall a b. (a -> b) -> a -> b
$ do
  (_, bothMaps) <- String
-> Maybe GitRef -> Maybe String -> m (ExitCode, GitLsRemoteMaps)
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
 MonadFail m, AsUnstructuredError e) =>
String
-> Maybe GitRef -> Maybe String -> m (ExitCode, GitLsRemoteMaps)
gitLsRemote
    (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ GitUri -> Text
gitUriToText GitUri
uri)
    (Text -> GitRef
GitRef_Branch (Text -> GitRef) -> Maybe Text -> Maybe GitRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbranch)
    Maybe String
forall a. Maybe a
Nothing
  branch <- case mbranch of
    Maybe Text
Nothing -> Text -> m Text -> m Text
forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage Text
"Failed to find default branch" (m Text -> m Text) -> m Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
      b <- Either Text Text -> m Text
forall {a}. Either Text a -> m a
rethrowE (Either Text Text -> m Text) -> Either Text Text -> m Text
forall a b. (a -> b) -> a -> b
$ GitLsRemoteMaps -> Either Text Text
gitLookupDefaultBranch GitLsRemoteMaps
bothMaps
      putLog Debug $ "Default branch for remote repo " <> uriMsg <> " is " <> b
      pure b
    Just Text
b -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
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 Text a -> m a
rethrowE = (Text -> m a) -> (a -> m a) -> Either Text a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> m a
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    uriMsg :: Text
uriMsg = GitUri -> Text
gitUriToText GitUri
uri

parseGitUri :: Text -> Maybe GitUri
parseGitUri :: Text -> Maybe GitUri
parseGitUri Text
x = URI -> GitUri
GitUri (URI -> GitUri) -> Maybe URI -> Maybe GitUri
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Maybe URI
parseFileURI Text
x Maybe URI -> Maybe URI -> Maybe URI
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe URI
parseAbsoluteURI Text
x Maybe URI -> Maybe URI -> Maybe URI
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe URI
parseSshShorthand Text
x)

parseFileURI :: Text -> Maybe URI.URI
parseFileURI :: Text -> Maybe URI
parseFileURI Text
uri = if Text
"/" Text -> Text -> Bool
`T.isPrefixOf` Text
uri then Text -> Maybe URI
parseAbsoluteURI (Text
"file://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uri) else Maybe URI
forall a. Maybe a
Nothing

parseAbsoluteURI :: Text -> Maybe URI.URI
parseAbsoluteURI :: Text -> Maybe URI
parseAbsoluteURI Text
uri = do
  parsedUri <- Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI Text
uri
  guard $ URI.isPathAbsolute parsedUri
  pure parsedUri

parseSshShorthand :: Text -> Maybe URI.URI
parseSshShorthand :: Text -> Maybe URI
parseSshShorthand Text
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
    (Text
authAndHostname, Text
colonAndPath) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
uri
    properUri :: Text
properUri = Text
"ssh://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
authAndHostname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop Int
1 Text
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
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing ((Char -> Bool) -> Text -> Maybe Int
T.findIndex (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') Text
authAndHostname)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null Text
colonAndPath)
  Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI Text
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 { forall hash. Ref hash -> Digest hash
unRef :: Digest hash }
  deriving (Ref hash -> Ref hash -> Bool
(Ref hash -> Ref hash -> Bool)
-> (Ref hash -> Ref hash -> Bool) -> Eq (Ref hash)
forall hash. Ref hash -> Ref hash -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall hash. Ref hash -> Ref hash -> Bool
== :: Ref hash -> Ref hash -> Bool
$c/= :: forall hash. Ref hash -> Ref hash -> Bool
/= :: Ref hash -> Ref hash -> Bool
Eq, Eq (Ref hash)
Eq (Ref hash) =>
(Ref hash -> Ref hash -> Ordering)
-> (Ref hash -> Ref hash -> Bool)
-> (Ref hash -> Ref hash -> Bool)
-> (Ref hash -> Ref hash -> Bool)
-> (Ref hash -> Ref hash -> Bool)
-> (Ref hash -> Ref hash -> Ref hash)
-> (Ref hash -> Ref hash -> Ref hash)
-> Ord (Ref hash)
Ref hash -> Ref hash -> Bool
Ref hash -> Ref hash -> Ordering
Ref hash -> Ref hash -> Ref hash
forall hash. Eq (Ref hash)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall hash. Ref hash -> Ref hash -> Bool
forall hash. Ref hash -> Ref hash -> Ordering
forall hash. Ref hash -> Ref hash -> Ref hash
$ccompare :: forall hash. Ref hash -> Ref hash -> Ordering
compare :: Ref hash -> Ref hash -> Ordering
$c< :: forall hash. Ref hash -> Ref hash -> Bool
< :: Ref hash -> Ref hash -> Bool
$c<= :: forall hash. Ref hash -> Ref hash -> Bool
<= :: Ref hash -> Ref hash -> Bool
$c> :: forall hash. Ref hash -> Ref hash -> Bool
> :: Ref hash -> Ref hash -> Bool
$c>= :: forall hash. Ref hash -> Ref hash -> Bool
>= :: Ref hash -> Ref hash -> Bool
$cmax :: forall hash. Ref hash -> Ref hash -> Ref hash
max :: Ref hash -> Ref hash -> Ref hash
$cmin :: forall hash. Ref hash -> Ref hash -> Ref hash
min :: Ref hash -> Ref hash -> Ref hash
Ord, Typeable)

-- | Invalid Reference exception raised when
-- using something that is not a ref as a ref.
newtype RefInvalid = RefInvalid { RefInvalid -> ByteString
unRefInvalid :: ByteString }
  deriving (Int -> RefInvalid -> ShowS
[RefInvalid] -> ShowS
RefInvalid -> String
(Int -> RefInvalid -> ShowS)
-> (RefInvalid -> String)
-> ([RefInvalid] -> ShowS)
-> Show RefInvalid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefInvalid -> ShowS
showsPrec :: Int -> RefInvalid -> ShowS
$cshow :: RefInvalid -> String
show :: RefInvalid -> String
$cshowList :: [RefInvalid] -> ShowS
showList :: [RefInvalid] -> ShowS
Show, RefInvalid -> RefInvalid -> Bool
(RefInvalid -> RefInvalid -> Bool)
-> (RefInvalid -> RefInvalid -> Bool) -> Eq RefInvalid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefInvalid -> RefInvalid -> Bool
== :: RefInvalid -> RefInvalid -> Bool
$c/= :: RefInvalid -> RefInvalid -> Bool
/= :: RefInvalid -> RefInvalid -> Bool
Eq, Typeable RefInvalid
Typeable RefInvalid =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> RefInvalid -> c RefInvalid)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c RefInvalid)
-> (RefInvalid -> Constr)
-> (RefInvalid -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c RefInvalid))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c RefInvalid))
-> ((forall b. Data b => b -> b) -> RefInvalid -> RefInvalid)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> RefInvalid -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> RefInvalid -> r)
-> (forall u. (forall d. Data d => d -> u) -> RefInvalid -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> RefInvalid -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid)
-> Data RefInvalid
RefInvalid -> Constr
RefInvalid -> DataType
(forall b. Data b => b -> b) -> RefInvalid -> RefInvalid
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> RefInvalid -> u
forall u. (forall d. Data d => d -> u) -> RefInvalid -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RefInvalid -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RefInvalid -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RefInvalid
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RefInvalid -> c RefInvalid
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RefInvalid)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c RefInvalid)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RefInvalid -> c RefInvalid
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RefInvalid -> c RefInvalid
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RefInvalid
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RefInvalid
$ctoConstr :: RefInvalid -> Constr
toConstr :: RefInvalid -> Constr
$cdataTypeOf :: RefInvalid -> DataType
dataTypeOf :: RefInvalid -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RefInvalid)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RefInvalid)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c RefInvalid)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c RefInvalid)
$cgmapT :: (forall b. Data b => b -> b) -> RefInvalid -> RefInvalid
gmapT :: (forall b. Data b => b -> b) -> RefInvalid -> RefInvalid
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RefInvalid -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RefInvalid -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RefInvalid -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> RefInvalid -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RefInvalid -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> RefInvalid -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RefInvalid -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RefInvalid -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
Data, Typeable)

instance Exception RefInvalid

refFromHexString :: HashAlgorithm hash => String -> Ref hash
refFromHexString :: forall hash. HashAlgorithm hash => String -> Ref hash
refFromHexString = ByteString -> Ref hash
forall hash. HashAlgorithm hash => ByteString -> Ref hash
refFromHex (ByteString -> Ref hash)
-> (String -> ByteString) -> String -> Ref hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BSC.pack

refFromHex :: HashAlgorithm hash => BSC.ByteString -> Ref hash
refFromHex :: forall hash. HashAlgorithm hash => ByteString -> Ref hash
refFromHex ByteString
s =
  case Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base16 ByteString
s :: Either String ByteString of
    Left String
_ -> RefInvalid -> Ref hash
forall a e. (HasCallStack, Exception e) => e -> a
throw (RefInvalid -> Ref hash) -> RefInvalid -> Ref hash
forall a b. (a -> b) -> a -> b
$ ByteString -> RefInvalid
RefInvalid ByteString
s
    Right ByteString
h -> case ByteString -> Maybe (Digest hash)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString ByteString
h of
      Maybe (Digest hash)
Nothing -> RefInvalid -> Ref hash
forall a e. (HasCallStack, Exception e) => e -> a
throw (RefInvalid -> Ref hash) -> RefInvalid -> Ref hash
forall a b. (a -> b) -> a -> b
$ ByteString -> RefInvalid
RefInvalid ByteString
s
      Just Digest hash
d -> Digest hash -> Ref hash
forall hash. Digest hash -> Ref hash
Ref Digest hash
d

-- | transform a ref into an hexadecimal string
refToHexString :: Ref hash -> String
refToHexString :: forall hash. Ref hash -> String
refToHexString (Ref Digest hash
d) = Digest hash -> String
forall a. Show a => a -> String
show Digest hash
d

instance Show (Ref hash) where
  show :: Ref hash -> String
show (Ref Digest hash
bs) = ByteString -> String
BSC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Base -> Digest hash -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 Digest hash
bs