{-# 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 TypeApplications #-}
module Nix.Thunk
( ThunkSource (..)
, GitHubSource (..)
, ThunkRev (..)
, getLatestRev
, gitCloneForThunkUnpack
, thunkSourceToGitSource
, ThunkPtr (..)
, ThunkData (..)
, readThunk
, CheckClean (..)
, getThunkPtr
, packThunk
, createThunk
, createThunk'
, ThunkPackConfig (..)
, ThunkConfig (..)
, updateThunkToLatest
, updateThunk
, ThunkUpdateConfig (..)
, unpackThunk
, ThunkSpec (..)
, ThunkFileSpec (..)
, NixThunkError
, nixBuildAttrWithCache
, attrCacheFileName
, prettyNixThunkError
, ThunkCreateConfig (..)
, parseGitUri
, GitUri (..)
, uriThunkPtr
, Ref(..)
, refFromHexString
) where
import Bindings.Cli.Coreutils (cp)
import Bindings.Cli.Git
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.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
import Language.Haskell.TH (Exp(LitE), Lit(StringL), runIO)
import qualified System.Process as P
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 p :: CmdSpec
p code :: Int
code) ->
"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
forall a. Semigroup a => a -> a -> a
<> CmdSpec -> Text
reconstructCommand CmdSpec
p
NixThunkError_Unstructured msg :: Text
msg -> Text
msg
makePrisms ''NixThunkError
instance AsUnstructuredError NixThunkError where
asUnstructuredError :: p Text (f Text) -> p NixThunkError (f NixThunkError)
asUnstructuredError = p Text (f Text) -> p NixThunkError (f NixThunkError)
Prism' NixThunkError Text
_NixThunkError_Unstructured
instance AsProcessFailure NixThunkError where
asProcessFailure :: p ProcessFailure (f ProcessFailure)
-> p NixThunkError (f NixThunkError)
asProcessFailure = p ProcessFailure (f ProcessFailure)
-> p NixThunkError (f NixThunkError)
Prism' NixThunkError ProcessFailure
_NixThunkError_ProcessFailure
data ThunkData
= ThunkData_Packed ThunkSpec ThunkPtr
| ThunkData_Checkout
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
showList :: [ThunkPtr] -> ShowS
$cshowList :: [ThunkPtr] -> ShowS
show :: ThunkPtr -> String
$cshow :: ThunkPtr -> String
showsPrec :: Int -> ThunkPtr -> ShowS
$cshowsPrec :: Int -> ThunkPtr -> ShowS
Show, ThunkPtr -> ThunkPtr -> Bool
(ThunkPtr -> ThunkPtr -> Bool)
-> (ThunkPtr -> ThunkPtr -> Bool) -> Eq ThunkPtr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThunkPtr -> ThunkPtr -> Bool
$c/= :: ThunkPtr -> ThunkPtr -> Bool
== :: ThunkPtr -> ThunkPtr -> Bool
$c== :: 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
min :: ThunkPtr -> ThunkPtr -> ThunkPtr
$cmin :: ThunkPtr -> ThunkPtr -> ThunkPtr
max :: ThunkPtr -> ThunkPtr -> ThunkPtr
$cmax :: ThunkPtr -> ThunkPtr -> ThunkPtr
>= :: ThunkPtr -> ThunkPtr -> Bool
$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
compare :: ThunkPtr -> ThunkPtr -> Ordering
$ccompare :: ThunkPtr -> ThunkPtr -> Ordering
$cp1Ord :: Eq ThunkPtr
Ord)
type NixSha256 = Text
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
showList :: [ThunkRev] -> ShowS
$cshowList :: [ThunkRev] -> ShowS
show :: ThunkRev -> String
$cshow :: ThunkRev -> String
showsPrec :: Int -> ThunkRev -> ShowS
$cshowsPrec :: Int -> ThunkRev -> ShowS
Show, ThunkRev -> ThunkRev -> Bool
(ThunkRev -> ThunkRev -> Bool)
-> (ThunkRev -> ThunkRev -> Bool) -> Eq ThunkRev
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThunkRev -> ThunkRev -> Bool
$c/= :: ThunkRev -> ThunkRev -> Bool
== :: ThunkRev -> ThunkRev -> Bool
$c== :: 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
min :: ThunkRev -> ThunkRev -> ThunkRev
$cmin :: ThunkRev -> ThunkRev -> ThunkRev
max :: ThunkRev -> ThunkRev -> ThunkRev
$cmax :: ThunkRev -> ThunkRev -> ThunkRev
>= :: ThunkRev -> ThunkRev -> Bool
$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
compare :: ThunkRev -> ThunkRev -> Ordering
$ccompare :: ThunkRev -> ThunkRev -> Ordering
$cp1Ord :: Eq ThunkRev
Ord)
data ThunkSource
= ThunkSource_GitHub GitHubSource
| 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
showList :: [ThunkSource] -> ShowS
$cshowList :: [ThunkSource] -> ShowS
show :: ThunkSource -> String
$cshow :: ThunkSource -> String
showsPrec :: Int -> ThunkSource -> ShowS
$cshowsPrec :: Int -> ThunkSource -> ShowS
Show, ThunkSource -> ThunkSource -> Bool
(ThunkSource -> ThunkSource -> Bool)
-> (ThunkSource -> ThunkSource -> Bool) -> Eq ThunkSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThunkSource -> ThunkSource -> Bool
$c/= :: ThunkSource -> ThunkSource -> Bool
== :: ThunkSource -> ThunkSource -> Bool
$c== :: 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
min :: ThunkSource -> ThunkSource -> ThunkSource
$cmin :: ThunkSource -> ThunkSource -> ThunkSource
max :: ThunkSource -> ThunkSource -> ThunkSource
$cmax :: ThunkSource -> ThunkSource -> ThunkSource
>= :: ThunkSource -> ThunkSource -> Bool
$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
compare :: ThunkSource -> ThunkSource -> Ordering
$ccompare :: ThunkSource -> ThunkSource -> Ordering
$cp1Ord :: Eq ThunkSource
Ord)
thunkSourceToGitSource :: ThunkSource -> GitSource
thunkSourceToGitSource :: ThunkSource -> GitSource
thunkSourceToGitSource = \case
ThunkSource_GitHub s :: GitHubSource
s -> Bool -> GitHubSource -> GitSource
forgetGithub Bool
False GitHubSource
s
ThunkSource_Git s :: GitSource
s -> GitSource
s
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
showList :: [GitHubSource] -> ShowS
$cshowList :: [GitHubSource] -> ShowS
show :: GitHubSource -> String
$cshow :: GitHubSource -> String
showsPrec :: Int -> GitHubSource -> ShowS
$cshowsPrec :: Int -> GitHubSource -> ShowS
Show, GitHubSource -> GitHubSource -> Bool
(GitHubSource -> GitHubSource -> Bool)
-> (GitHubSource -> GitHubSource -> Bool) -> Eq GitHubSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitHubSource -> GitHubSource -> Bool
$c/= :: GitHubSource -> GitHubSource -> Bool
== :: GitHubSource -> GitHubSource -> Bool
$c== :: 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
min :: GitHubSource -> GitHubSource -> GitHubSource
$cmin :: GitHubSource -> GitHubSource -> GitHubSource
max :: GitHubSource -> GitHubSource -> GitHubSource
$cmax :: GitHubSource -> GitHubSource -> GitHubSource
>= :: GitHubSource -> GitHubSource -> Bool
$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
compare :: GitHubSource -> GitHubSource -> Ordering
$ccompare :: GitHubSource -> GitHubSource -> Ordering
$cp1Ord :: Eq 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
/= :: GitUri -> GitUri -> Bool
$c/= :: GitUri -> GitUri -> Bool
== :: GitUri -> GitUri -> Bool
$c== :: 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
min :: GitUri -> GitUri -> GitUri
$cmin :: GitUri -> GitUri -> GitUri
max :: GitUri -> GitUri -> GitUri
$cmax :: GitUri -> GitUri -> GitUri
>= :: GitUri -> GitUri -> Bool
$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
compare :: GitUri -> GitUri -> Ordering
$ccompare :: GitUri -> GitUri -> Ordering
$cp1Ord :: Eq 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
showList :: [GitUri] -> ShowS
$cshowList :: [GitUri] -> ShowS
show :: GitUri -> String
$cshow :: GitUri -> String
showsPrec :: Int -> GitUri -> ShowS
$cshowsPrec :: Int -> GitUri -> ShowS
Show)
gitUriToText :: GitUri -> Text
gitUriToText :: GitUri -> Text
gitUriToText (GitUri uri :: 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 "file"
, Just (_, path :: NonEmpty (RText 'PathPiece)
path) <- URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
uri
= "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate "/" ((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
showList :: [GitSource] -> ShowS
$cshowList :: [GitSource] -> ShowS
show :: GitSource -> String
$cshow :: GitSource -> String
showsPrec :: Int -> GitSource -> ShowS
$cshowsPrec :: Int -> GitSource -> ShowS
Show, GitSource -> GitSource -> Bool
(GitSource -> GitSource -> Bool)
-> (GitSource -> GitSource -> Bool) -> Eq GitSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitSource -> GitSource -> Bool
$c/= :: GitSource -> GitSource -> Bool
== :: GitSource -> GitSource -> Bool
$c== :: 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
min :: GitSource -> GitSource -> GitSource
$cmin :: GitSource -> GitSource -> GitSource
max :: GitSource -> GitSource -> GitSource
$cmax :: GitSource -> GitSource -> GitSource
>= :: GitSource -> GitSource -> Bool
$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
compare :: GitSource -> GitSource -> Ordering
$ccompare :: GitSource -> GitSource -> Ordering
$cp1Ord :: Eq 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
showList :: [ThunkConfig] -> ShowS
$cshowList :: [ThunkConfig] -> ShowS
show :: ThunkConfig -> String
$cshow :: ThunkConfig -> String
showsPrec :: Int -> ThunkConfig -> ShowS
$cshowsPrec :: Int -> ThunkConfig -> ShowS
Show
data ThunkUpdateConfig = ThunkUpdateConfig
{ ThunkUpdateConfig -> Maybe String
_thunkUpdateConfig_branch :: Maybe String
, ThunkUpdateConfig -> ThunkConfig
_thunkUpdateConfig_config :: 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
showList :: [ThunkUpdateConfig] -> ShowS
$cshowList :: [ThunkUpdateConfig] -> ShowS
show :: ThunkUpdateConfig -> String
$cshow :: ThunkUpdateConfig -> String
showsPrec :: Int -> ThunkUpdateConfig -> ShowS
$cshowsPrec :: Int -> 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
showList :: [ThunkPackConfig] -> ShowS
$cshowList :: [ThunkPackConfig] -> ShowS
show :: ThunkPackConfig -> String
$cshow :: ThunkPackConfig -> String
showsPrec :: Int -> ThunkPackConfig -> ShowS
$cshowsPrec :: Int -> ThunkPackConfig -> ShowS
Show
data ThunkCreateConfig = ThunkCreateConfig
{ ThunkCreateConfig -> GitUri
_thunkCreateConfig_uri :: GitUri
, 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
showList :: [ThunkCreateConfig] -> ShowS
$cshowList :: [ThunkCreateConfig] -> ShowS
show :: ThunkCreateConfig -> String
$cshow :: ThunkCreateConfig -> String
showsPrec :: Int -> ThunkCreateConfig -> ShowS
$cshowsPrec :: Int -> ThunkCreateConfig -> ShowS
Show
forgetGithub :: Bool -> GitHubSource -> GitSource
forgetGithub :: Bool -> GitHubSource -> GitSource
forgetGithub useSsh :: Bool
useSsh s :: GitHubSource
s = GitSource :: GitUri -> Maybe (Name Branch) -> Bool -> Bool -> GitSource
GitSource
{ _gitSource_url :: GitUri
_gitSource_url = URI -> GitUri
GitUri (URI -> GitUri) -> URI -> GitUri
forall a b. (a -> b) -> a -> b
$ URI :: Maybe (RText 'Scheme)
-> Either Bool Authority
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> [QueryParam]
-> Maybe (RText 'Fragment)
-> URI
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 "ssh" else "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
$ Authority :: Maybe UserInfo -> RText 'Host -> Maybe Word -> Authority
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 "git") Maybe (RText 'Password)
forall a. Maybe a
Nothing
UserInfo -> Maybe () -> Maybe UserInfo
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 "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
<> ".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 c :: 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
getNixSha256ForUriUnpacked
:: MonadNixThunk m
=> GitUri
-> m NixSha256
getNixSha256ForUriUnpacked :: GitUri -> m Text
getNixSha256ForUriUnpacked uri :: GitUri
uri =
Text -> m Text -> m Text
forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage ("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
hash] <- (Text -> [Text]) -> m Text -> m [Text]
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 "nix-prefetch-url" ["--unpack", "--type", "sha256", Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ GitUri -> Text
gitUriToText GitUri
uri]
Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
hash
nixPrefetchGit :: MonadNixThunk m => GitUri -> Text -> Bool -> m NixSha256
nixPrefetchGit :: GitUri -> Text -> Bool -> m Text
nixPrefetchGit uri :: GitUri
uri rev :: Text
rev fetchSubmodules :: Bool
fetchSubmodules =
Text -> m Text -> m Text
forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage ("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
<> " 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
Text
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
$
String -> [String] -> ProcessSpec
proc "nix-prefetch-git" ([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
/="")
[ "--url", Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ GitUri -> Text
gitUriToText GitUri
uri
, "--rev", Text -> String
T.unpack Text
rev
, if Bool
fetchSubmodules then "--fetch-submodules" else ""
, "--quiet"
]
case (Object -> Parser Text) -> Object -> Maybe Text
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe (Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: "sha256") (Object -> Maybe Text) -> Maybe Object -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> Maybe Object
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict (Text -> ByteString
encodeUtf8 Text
out) of
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
$ "nix-prefetch-git: unrecognized output " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
out
Just x :: Text
x -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
data ReadThunkError
= ReadThunkError_UnrecognizedThunk
| ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
| ReadThunkError_MissingPaths (NonEmpty FilePath)
| ReadThunkError_UnparseablePtr FilePath String
| ReadThunkError_FileError IOError
| ReadThunkError_FileDoesNotMatch FilePath Text
| ReadThunkError_UnrecognizedState String
| ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
deriving (Int -> ReadThunkError -> ShowS
[ReadThunkError] -> ShowS
ReadThunkError -> String
(Int -> ReadThunkError -> ShowS)
-> (ReadThunkError -> String)
-> ([ReadThunkError] -> ShowS)
-> Show ReadThunkError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadThunkError] -> ShowS
$cshowList :: [ReadThunkError] -> ShowS
show :: ReadThunkError -> String
$cshow :: ReadThunkError -> String
showsPrec :: Int -> ReadThunkError -> ShowS
$cshowsPrec :: Int -> ReadThunkError -> ShowS
Show)
unpackedDirName :: FilePath
unpackedDirName :: String
unpackedDirName = "."
attrCacheFileName :: FilePath
attrCacheFileName :: String
attrCacheFileName = ".attr-cache"
pinnedNixpkgsPath :: FilePath
pinnedNixpkgsPath :: String
pinnedNixpkgsPath =
$(do
p <- fmap init . runIO $ P.readCreateProcess (P.shell "print-nixpkgs-path") ""
pure $ LitE $ StringL $ p
)
data ThunkFileSpec
= ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr)
| ThunkFileSpec_FileMatches Text
| ThunkFileSpec_CheckoutIndicator
| ThunkFileSpec_AttrCache
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]
matchThunkSpecToDir
:: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
=> ThunkSpec
-> FilePath
-> Set FilePath
-> m ThunkData
matchThunkSpecToDir :: ThunkSpec -> String -> Set String -> m ThunkData
matchThunkSpecToDir thunkSpec :: ThunkSpec
thunkSpec dir :: String
dir dirFiles :: Set String
dirFiles = do
Bool
isCheckout <- (Map String Bool -> Bool) -> m (Map String Bool) -> m Bool
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
$ \expectedPath :: String
expectedPath -> \case
ThunkFileSpec_CheckoutIndicator -> IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
doesDirectoryExist (String
dir String -> ShowS
</> String
expectedPath))
_ -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
case Bool
isCheckout of
True -> ThunkData -> m ThunkData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThunkData
ThunkData_Checkout
False -> do
Maybe (NonEmpty String) -> (NonEmpty String -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Set String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ Set String
dirFiles Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
expectedPaths)) ((NonEmpty String -> m Any) -> m ())
-> (NonEmpty String -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \fs :: NonEmpty String
fs ->
ReadThunkError -> m Any
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m Any) -> ReadThunkError -> m Any
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> ReadThunkError
ReadThunkError_UnrecognizedPaths (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
Maybe (NonEmpty String) -> (NonEmpty String -> m Any) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Set String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ Set String
requiredPaths Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
dirFiles)) ((NonEmpty String -> m Any) -> m ())
-> (NonEmpty String -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \fs :: NonEmpty String
fs ->
ReadThunkError -> m Any
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m Any) -> ReadThunkError -> m Any
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
[(ThunkSpec, ThunkPtr)]
datas <- (Map String (ThunkSpec, ThunkPtr) -> [(ThunkSpec, ThunkPtr)])
-> m (Map String (ThunkSpec, ThunkPtr))
-> m [(ThunkSpec, ThunkPtr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map String (ThunkSpec, ThunkPtr) -> [(ThunkSpec, ThunkPtr)]
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
$ \expectedPath :: String
expectedPath -> \case
ThunkFileSpec_AttrCache -> Maybe (ThunkSpec, ThunkPtr)
forall a. Maybe a
Nothing Maybe (ThunkSpec, ThunkPtr)
-> m () -> m (Maybe (ThunkSpec, ThunkPtr))
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_CheckoutIndicator -> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ThunkSpec, ThunkPtr)
forall a. Maybe a
Nothing
ThunkFileSpec_FileMatches expectedContents :: Text
expectedContents -> (IOError -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Maybe (ThunkSpec, ThunkPtr))
-> m (Maybe (ThunkSpec, ThunkPtr))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOError
e :: IOError) -> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
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
$ IOError -> ReadThunkError
ReadThunkError_FileError 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
Text
actualContents <- IO Text -> m Text
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 Text -> Text
T.strip Text
expectedContents Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
T.strip Text
actualContents of
True -> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ThunkSpec, ThunkPtr)
forall a. Maybe a
Nothing
False -> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
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 parser :: ByteString -> Either String ThunkPtr
parser -> (IOError -> m (Maybe (ThunkSpec, ThunkPtr)))
-> m (Maybe (ThunkSpec, ThunkPtr))
-> m (Maybe (ThunkSpec, ThunkPtr))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOError
e :: IOError) -> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
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
$ IOError -> ReadThunkError
ReadThunkError_FileError 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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
False -> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ThunkSpec, ThunkPtr)
forall a. Maybe a
Nothing
True -> do
ByteString
actualContents <- IO ByteString -> m ByteString
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 ByteString -> Either String ThunkPtr
parser ByteString
actualContents of
Right v :: ThunkPtr
v -> Maybe (ThunkSpec, ThunkPtr) -> m (Maybe (ThunkSpec, ThunkPtr))
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 e :: String
e -> ReadThunkError -> m (Maybe (ThunkSpec, ThunkPtr))
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
(ThunkSpec -> ThunkPtr -> ThunkData)
-> (ThunkSpec, ThunkPtr) -> ThunkData
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ThunkSpec -> ThunkPtr -> ThunkData
ThunkData_Packed ((ThunkSpec, ThunkPtr) -> ThunkData)
-> m (ThunkSpec, ThunkPtr) -> m ThunkData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case [(ThunkSpec, ThunkPtr)] -> Maybe (NonEmpty (ThunkSpec, ThunkPtr))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(ThunkSpec, ThunkPtr)]
datas of
Nothing -> ReadThunkError -> m (ThunkSpec, ThunkPtr)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ReadThunkError
ReadThunkError_UnrecognizedThunk
Just xs :: 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@(_, ptrA :: ThunkPtr
ptrA) (_, ptrB :: ThunkPtr
ptrB) ->
if ThunkPtr
ptrA ThunkPtr -> ThunkPtr -> Bool
forall a. Eq a => a -> a -> Bool
== ThunkPtr
ptrB then (ThunkSpec, ThunkPtr) -> m (ThunkSpec, ThunkPtr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThunkSpec, ThunkPtr)
a else ReadThunkError -> m (ThunkSpec, ThunkPtr)
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
$ ThunkPtr -> ThunkPtr -> ReadThunkError
ReadThunkError_AmbiguousPackedState ThunkPtr
ptrA ThunkPtr
ptrB
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 (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 _ -> Bool
True
_ -> Bool
False
dirMayExist :: String -> m ()
dirMayExist expectedPath :: String
expectedPath = IO Bool -> m Bool
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
True -> ReadThunkError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ReadThunkError -> m ()) -> ReadThunkError -> m ()
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> ReadThunkError
ReadThunkError_UnrecognizedPaths (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
:| []
False -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
fold1WithM :: NonEmpty a -> (a -> a -> m a) -> m a
fold1WithM (x :: a
x :| xs :: [a]
xs) f :: 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 :: NonEmpty (NonEmpty ThunkSpec)
-> String -> m (Either ReadThunkError ThunkData)
readThunkWith specTypes :: NonEmpty (NonEmpty ThunkSpec)
specTypes dir :: String
dir = do
Set String
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO [String]
listDirectory String
dir)
let specs :: [ThunkSpec]
specs = (NonEmpty ThunkSpec -> [ThunkSpec])
-> [NonEmpty ThunkSpec] -> [ThunkSpec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty ThunkSpec -> [ThunkSpec]
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 (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
((([ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> [ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> [ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> [ThunkSpec]
-> (([ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> [ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> m (Either ReadThunkError ThunkData)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> [ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> [ThunkSpec] -> m (Either ReadThunkError ThunkData)
forall a. (a -> a) -> a
fix [ThunkSpec]
specs ((([ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> [ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> m (Either ReadThunkError ThunkData))
-> (([ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> [ThunkSpec] -> m (Either ReadThunkError ThunkData))
-> m (Either ReadThunkError ThunkData)
forall a b. (a -> b) -> a -> b
$ \loop :: [ThunkSpec] -> m (Either ReadThunkError ThunkData)
loop -> \case
[] -> Either ReadThunkError ThunkData
-> m (Either ReadThunkError ThunkData)
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
spec :: ThunkSpec
spec:rest :: [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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left e :: ReadThunkError
e -> Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] m ()
-> m (Either ReadThunkError ThunkData)
-> m (Either ReadThunkError ThunkData)
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 _) -> Either ReadThunkError ThunkData
x Either ReadThunkError ThunkData
-> m () -> m (Either ReadThunkError ThunkData)
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}|]
readThunk :: (MonadNixThunk m) => FilePath -> m (Either ReadThunkError ThunkData)
readThunk :: 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 parseSrc :: Object -> Parser ThunkSource
parseSrc v :: Object
v = do
String
rev <- Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: "rev"
Text
sha256 <- Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: "sha256"
ThunkSource
src <- Object -> Parser ThunkSource
parseSrc Object
v
ThunkPtr -> Parser ThunkPtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThunkPtr -> Parser ThunkPtr) -> ThunkPtr -> Parser ThunkPtr
forall a b. (a -> b) -> a -> b
$ ThunkPtr :: ThunkRev -> ThunkSource -> ThunkPtr
ThunkPtr
{ _thunkPtr_rev :: ThunkRev
_thunkPtr_rev = ThunkRev :: Ref SHA1 -> Text -> ThunkRev
ThunkRev
{ _thunkRev_commit :: Ref SHA1
_thunkRev_commit = String -> Ref SHA1
forall hash. HashAlgorithm hash => String -> Ref hash
refFromHexString String
rev
, _thunkRev_nixSha256 :: Text
_thunkRev_nixSha256 = Text
sha256
}
, _thunkPtr_source :: ThunkSource
_thunkPtr_source = ThunkSource
src
}
parseGitHubSource :: Aeson.Object -> Aeson.Parser GitHubSource
parseGitHubSource :: Object -> Parser GitHubSource
parseGitHubSource v :: Object
v = do
Name Owner
owner <- Object
v Object -> Text -> Parser (Name Owner)
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: "owner"
Name Repo
repo <- Object
v Object -> Text -> Parser (Name Repo)
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: "repo"
Maybe (Name Branch)
branch <- Object
v Object -> Text -> Parser (Maybe (Name Branch))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:! "branch"
Maybe Bool
private <- Object
v Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:? "private"
GitHubSource -> Parser GitHubSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitHubSource -> Parser GitHubSource)
-> GitHubSource -> Parser GitHubSource
forall a b. (a -> b) -> a -> b
$ GitHubSource :: Name Owner
-> Name Repo -> Maybe (Name Branch) -> Bool -> GitHubSource
GitHubSource
{ _gitHubSource_owner :: Name Owner
_gitHubSource_owner = Name Owner
owner
, _gitHubSource_repo :: Name Repo
_gitHubSource_repo = Name Repo
repo
, _gitHubSource_branch :: Maybe (Name Branch)
_gitHubSource_branch = Maybe (Name Branch)
branch
, _gitHubSource_private :: Bool
_gitHubSource_private = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
private
}
parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
parseGitSource :: Object -> Parser GitSource
parseGitSource v :: Object
v = do
Just url :: GitUri
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 -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: "url"
Maybe (Name Branch)
branch <- Object
v Object -> Text -> Parser (Maybe (Name Branch))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:! "branch"
Maybe Bool
fetchSubmodules <- Object
v Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:! "fetchSubmodules"
Maybe Bool
private <- Object
v Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:? "private"
GitSource -> Parser GitSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitSource -> Parser GitSource) -> GitSource -> Parser GitSource
forall a b. (a -> b) -> a -> b
$ GitSource :: GitUri -> Maybe (Name Branch) -> Bool -> Bool -> GitSource
GitSource
{ _gitSource_url :: GitUri
_gitSource_url = GitUri
url
, _gitSource_branch :: Maybe (Name Branch)
_gitSource_branch = Maybe (Name Branch)
branch
, _gitSource_fetchSubmodules :: Bool
_gitSource_fetchSubmodules = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
fetchSubmodules
, _gitSource_private :: Bool
_gitSource_private = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
private
}
overwriteThunk :: MonadNixThunk m => FilePath -> ThunkPtr -> m ()
overwriteThunk :: String -> ThunkPtr -> m ()
overwriteThunk target :: String
target thunk :: ThunkPtr
thunk = do
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left e :: ReadThunkError
e -> Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Invalid thunk at ${target}: ${e}|]
Right _ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
IO () -> m ()
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 thunk :: ThunkPtr
thunk = case ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
thunk of
ThunkSource_GitHub _ -> NonEmpty ThunkSpec -> ThunkSpec
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty ThunkSpec
gitHubThunkSpecs
ThunkSource_Git _ -> NonEmpty ThunkSpec -> ThunkSpec
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty ThunkSpec
gitThunkSpecs
encodeThunkPtrData :: ThunkPtr -> LBS.ByteString
encodeThunkPtrData :: ThunkPtr -> ByteString
encodeThunkPtrData (ThunkPtr rev :: ThunkRev
rev src :: ThunkSource
src) = case ThunkSource
src of
ThunkSource_GitHub s :: 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
$ "owner" Text -> Name Owner -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
$ "repo" Text -> Name Repo -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= GitHubSource -> Name Repo
_gitHubSource_repo GitHubSource
s
, ("branch" Text -> Name Branch -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
$ "rev" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
$ "sha256" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
$ "private" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= GitHubSource -> Bool
_gitHubSource_private GitHubSource
s
]
ThunkSource_Git s :: 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
$ "url" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
$ "rev" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Ref SHA1 -> String
forall hash. Ref hash -> String
refToHexString (ThunkRev -> Ref SHA1
_thunkRev_commit ThunkRev
rev)
, ("branch" Text -> Name Branch -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
$ "sha256" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
$ "fetchSubmodules" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
$ "private" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= GitSource -> Bool
_gitSource_private GitSource
s
]
where
githubCfg :: Config
githubCfg = Config
defConfig
{ confIndent :: Indent
confIndent = Int -> Indent
Spaces 2
, confCompare :: Text -> Text -> Ordering
confCompare = [Text] -> Text -> Text -> Ordering
keyOrder
[ "owner"
, "repo"
, "branch"
, "private"
, "rev"
, "sha256"
] (Text -> Text -> Ordering)
-> (Text -> Text -> Ordering) -> Text -> Text -> Ordering
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
, confTrailingNewline :: Bool
confTrailingNewline = Bool
True
}
plainGitCfg :: Config
plainGitCfg = Config
defConfig
{ confIndent :: Indent
confIndent = Int -> Indent
Spaces 2
, confCompare :: Text -> Text -> Ordering
confCompare = [Text] -> Text -> Text -> Ordering
keyOrder
[ "url"
, "rev"
, "sha256"
, "private"
, "fetchSubmodules"
] (Text -> Text -> Ordering)
-> (Text -> Text -> Ordering) -> Text -> Text -> Ordering
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
, confTrailingNewline :: Bool
confTrailingNewline = Bool
True
}
createThunk' :: MonadNixThunk m => ThunkCreateConfig -> m ()
createThunk' :: ThunkCreateConfig -> m ()
createThunk' config :: ThunkCreateConfig
config = do
ThunkPtr
newThunkPtr <- GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
uriThunkPtr
(ThunkCreateConfig -> GitUri
_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
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
/= '/') 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
=='/') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse
dropDotGit :: FilePath -> FilePath
dropDotGit :: ShowS
dropDotGit origName :: 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 "git" String
origName
defaultDestinationForGitUri :: GitUri -> FilePath
defaultDestinationForGitUri :: GitUri -> String
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 :: String
destination = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (GitUri -> String
defaultDestinationForGitUri (GitUri -> String) -> GitUri -> String
forall a b. (a -> b) -> a -> b
$ ThunkCreateConfig -> GitUri
_thunkCreateConfig_uri ThunkCreateConfig
config) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ThunkCreateConfig -> Maybe String
_thunkCreateConfig_destination ThunkCreateConfig
config
String -> Either ThunkSpec ThunkPtr -> m ()
forall (m :: * -> *).
MonadNixThunk m =>
String -> Either ThunkSpec ThunkPtr -> m ()
createThunk String
destination (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
newThunkPtr
createThunk :: MonadNixThunk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
createThunk :: String -> Either ThunkSpec ThunkPtr -> m ()
createThunk target :: String
target ptrInfo :: Either ThunkSpec ThunkPtr
ptrInfo =
Map String ThunkFileSpec
-> (String -> ThunkFileSpec -> m ()) -> m ()
forall i (t :: * -> *) (f :: * -> *) a b.
(FoldableWithIndex i t, Applicative f) =>
t a -> (i -> a -> f b) -> f ()
ifor_ (ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files ThunkSpec
spec) ((String -> ThunkFileSpec -> m ()) -> m ())
-> (String -> ThunkFileSpec -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \path :: String
path -> \case
ThunkFileSpec_FileMatches content :: Text
content -> String -> (String -> m ()) -> m ()
forall (m :: * -> *) b.
(MonadLog Output 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
$ \p :: String
p -> IO () -> m ()
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 _ -> case Either ThunkSpec ThunkPtr
ptrInfo of
Left _ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Right ptr :: ThunkPtr
ptr -> String -> (String -> m ()) -> m ()
forall (m :: * -> *) b.
(MonadLog Output 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
$ \p :: String
p -> IO () -> m ()
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)
_ -> () -> m ()
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 path :: String
path f :: 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
$ "Writing thunk file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
fullPath
IO () -> m ()
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 :: ThunkUpdateConfig -> String -> m ()
updateThunkToLatest (ThunkUpdateConfig mBranch :: Maybe String
mBranch thunkConfig :: ThunkConfig
thunkConfig) target :: 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' ("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
<> " to latest") ((() -> Text) -> Maybe (() -> Text)
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
$ "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
<> " 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
case Maybe String
mBranch of
Nothing -> do
(overwrite :: String
overwrite, ptr :: ThunkPtr
ptr) <- 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 (String, ThunkPtr))
-> m (String, ThunkPtr)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left err :: ReadThunkError
err -> Text -> m (String, ThunkPtr)
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Thunk update: ${err}|]
Right c :: ThunkData
c -> case ThunkData
c of
ThunkData_Packed _ t :: ThunkPtr
t -> (String, ThunkPtr) -> m (String, ThunkPtr)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
target, ThunkPtr
t)
ThunkData_Checkout -> Text -> m (String, ThunkPtr)
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith "cannot update an unpacked thunk"
let src :: ThunkSource
src = ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
ptr
ThunkRev
rev <- ThunkSource -> m ThunkRev
forall (m :: * -> *). MonadNixThunk m => ThunkSource -> m ThunkRev
getLatestRev ThunkSource
src
String -> ThunkPtr -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> ThunkPtr -> m ()
overwriteThunk String
overwrite (ThunkPtr -> m ()) -> ThunkPtr -> m ()
forall a b. (a -> b) -> a -> b
$ ThunkConfig -> ThunkPtr -> ThunkPtr
modifyThunkPtrByConfig ThunkConfig
thunkConfig (ThunkPtr -> ThunkPtr) -> ThunkPtr -> ThunkPtr
forall a b. (a -> b) -> a -> b
$ ThunkPtr :: ThunkRev -> ThunkSource -> ThunkPtr
ThunkPtr
{ _thunkPtr_source :: ThunkSource
_thunkPtr_source = ThunkSource
src
, _thunkPtr_rev :: ThunkRev
_thunkPtr_rev = ThunkRev
rev
}
Just branch :: String
branch -> 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left err :: ReadThunkError
err -> Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Thunk update: ${err}|]
Right c :: ThunkData
c -> case ThunkData
c of
ThunkData_Packed _ t :: ThunkPtr
t -> ThunkConfig -> String -> GitSource -> String -> m ()
forall (m :: * -> *).
MonadNixThunk m =>
ThunkConfig -> String -> GitSource -> String -> m ()
setThunk ThunkConfig
thunkConfig String
target (ThunkSource -> GitSource
thunkSourceToGitSource (ThunkSource -> GitSource) -> ThunkSource -> GitSource
forall a b. (a -> b) -> a -> b
$ ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
t) String
branch
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.|]
setThunk :: MonadNixThunk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
setThunk :: ThunkConfig -> String -> GitSource -> String -> m ()
setThunk thunkConfig :: ThunkConfig
thunkConfig target :: String
target gs :: GitSource
gs branch :: String
branch = do
ThunkPtr
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
gs) (ThunkConfig -> Maybe Bool
_thunkConfig_private ThunkConfig
thunkConfig) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
branch) Maybe Text
forall a. Maybe a
Nothing
String -> ThunkPtr -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> ThunkPtr -> m ()
overwriteThunk String
target ThunkPtr
newThunkPtr
ThunkUpdateConfig -> String -> m ()
forall (m :: * -> *).
MonadNixThunk m =>
ThunkUpdateConfig -> String -> m ()
updateThunkToLatest (Maybe String -> ThunkConfig -> ThunkUpdateConfig
ThunkUpdateConfig Maybe String
forall a. Maybe a
Nothing ThunkConfig
thunkConfig) String
target
gitHubThunkSpecs :: NonEmpty ThunkSpec
gitHubThunkSpecs :: NonEmpty ThunkSpec
gitHubThunkSpecs =
ThunkSpec
gitHubThunkSpecV7 ThunkSpec -> [ThunkSpec] -> NonEmpty ThunkSpec
forall a. a -> [a] -> NonEmpty a
:|
[ ThunkSpec
gitHubThunkSpecV6
, ThunkSpec
gitHubThunkSpecV5
, ThunkSpec
gitHubThunkSpecV4
, ThunkSpec
gitHubThunkSpecV3
, ThunkSpec
gitHubThunkSpecV2
, ThunkSpec
gitHubThunkSpecV1
]
gitHubThunkSpecV1 :: ThunkSpec
gitHubThunkSpecV1 :: ThunkSpec
gitHubThunkSpecV1 = Text -> Text -> ThunkSpec
legacyGitHubThunkSpec "github-v1"
"import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
gitHubThunkSpecV2 :: ThunkSpec
gitHubThunkSpecV2 :: ThunkSpec
gitHubThunkSpecV2 = Text -> Text -> ThunkSpec
legacyGitHubThunkSpec "github-v2" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ "# DO NOT HAND-EDIT THIS FILE"
, "import ((import <nixpkgs> {}).fetchFromGitHub ("
, " let json = builtins.fromJSON (builtins.readFile ./github.json);"
, " in { inherit (json) owner repo rev sha256;"
, " private = json.private or false;"
, " }"
, "))"
]
gitHubThunkSpecV3 :: ThunkSpec
gitHubThunkSpecV3 :: ThunkSpec
gitHubThunkSpecV3 = Text -> Text -> ThunkSpec
legacyGitHubThunkSpec "github-v3" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ "# DO NOT HAND-EDIT THIS FILE"
, "let"
, " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
, " then fetchFromGitHubPrivate args"
, " else (import <nixpkgs> {}).fetchFromGitHub (builtins.removeAttrs args [\"branch\"]);"
, " fetchFromGitHubPrivate ="
, " { owner, repo, rev, branch ? null, name ? null, sha256 ? null, private ? false"
, " , fetchSubmodules ? false, githubBase ? \"github.com\", ..."
, " }: assert !fetchSubmodules;"
, " builtins.fetchGit ({"
, " url = \"ssh://git@${githubBase}/${owner}/${repo}.git\";"
, " inherit rev;"
, " }"
, " // (if branch == null then {} else { ref = branch; })"
, " // (if name == null then {} else { inherit name; }));"
, "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
]
gitHubThunkSpecV4 :: ThunkSpec
gitHubThunkSpecV4 :: ThunkSpec
gitHubThunkSpecV4 = Text -> Text -> ThunkSpec
legacyGitHubThunkSpec "github-v4" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ "# DO NOT HAND-EDIT THIS FILE"
, "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
, " if !fetchSubmodules && !private then builtins.fetchTarball {"
, " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
, " } else (import <nixpkgs> {}).fetchFromGitHub {"
, " inherit owner repo rev sha256 fetchSubmodules private;"
, " };"
, "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
]
legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
legacyGitHubThunkSpec name :: Text
name loader :: 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
[ ("default.nix", Text -> ThunkFileSpec
ThunkFileSpec_FileMatches (Text -> ThunkFileSpec) -> Text -> ThunkFileSpec
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
loader)
, ("github.json" , (ByteString -> Either String ThunkPtr) -> ThunkFileSpec
ThunkFileSpec_Ptr ByteString -> Either String ThunkPtr
parseGitHubJsonBytes)
, (String
attrCacheFileName, ThunkFileSpec
ThunkFileSpec_AttrCache)
, (".git", ThunkFileSpec
ThunkFileSpec_CheckoutIndicator)
]
gitHubThunkSpecV5 :: ThunkSpec
gitHubThunkSpecV5 :: ThunkSpec
gitHubThunkSpecV5 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "github-v5" "github.json" ByteString -> Either String ThunkPtr
parseGitHubJsonBytes [here|
# DO NOT HAND-EDIT THIS FILE
let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
if !fetchSubmodules && !private then builtins.fetchTarball {
url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
} else (import <nixpkgs> {}).fetchFromGitHub {
inherit owner repo rev sha256 fetchSubmodules private;
};
json = builtins.fromJSON (builtins.readFile ./github.json);
in fetch json
|]
gitHubThunkSpecV6 :: ThunkSpec
gitHubThunkSpecV6 :: ThunkSpec
gitHubThunkSpecV6 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "github-v6" "github.json" ByteString -> Either String ThunkPtr
parseGitHubJsonBytes [here|
# DO NOT HAND-EDIT THIS FILE
let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
if !fetchSubmodules && !private then builtins.fetchTarball {
url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
} else (builtins.fetchTarball {
url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
}).fetchFromGitHub {
inherit owner repo rev sha256 fetchSubmodules private;
};
json = builtins.fromJSON (builtins.readFile ./github.json);
in fetch json
|]
gitHubThunkSpecV7 :: ThunkSpec
gitHubThunkSpecV7 :: ThunkSpec
gitHubThunkSpecV7 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "github-v7" "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|]
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
$ \v :: 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 (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
gitThunkSpecV7 ThunkSpec -> [ThunkSpec] -> NonEmpty ThunkSpec
forall a. a -> [a] -> NonEmpty a
:|
[ ThunkSpec
gitThunkSpecV6
, ThunkSpec
gitThunkSpecV5
, ThunkSpec
gitThunkSpecV4
, ThunkSpec
gitThunkSpecV3
, ThunkSpec
gitThunkSpecV2
, ThunkSpec
gitThunkSpecV1
]
gitThunkSpecV1 :: ThunkSpec
gitThunkSpecV1 :: ThunkSpec
gitThunkSpecV1 = Text -> Text -> ThunkSpec
legacyGitThunkSpec "git-v1" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ "# DO NOT HAND-EDIT THIS FILE"
, "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
, " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
, "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
]
gitThunkSpecV2 :: ThunkSpec
gitThunkSpecV2 :: ThunkSpec
gitThunkSpecV2 = Text -> Text -> ThunkSpec
legacyGitThunkSpec "git-v2" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ "# DO NOT HAND-EDIT THIS FILE"
, "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
, " if builtins.hasAttr \"fetchGit\" builtins"
, " then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"
, " else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"
, "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
]
gitThunkSpecV3 :: ThunkSpec
gitThunkSpecV3 :: ThunkSpec
gitThunkSpecV3 = Text -> Text -> ThunkSpec
legacyGitThunkSpec "git-v3" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ "# DO NOT HAND-EDIT THIS FILE"
, "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
, " let realUrl = let firstChar = builtins.substring 0 1 url; in"
, " if firstChar == \"/\" then /. + url"
, " else if firstChar == \".\" then ./. + url"
, " else url;"
, " in if !fetchSubmodules && private then builtins.fetchGit {"
, " url = realUrl; inherit rev;"
, " } else (import <nixpkgs> {}).fetchgit {"
, " url = realUrl; inherit rev sha256;"
, " };"
, "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
]
gitThunkSpecV4 :: ThunkSpec
gitThunkSpecV4 :: ThunkSpec
gitThunkSpecV4 = Text -> Text -> ThunkSpec
legacyGitThunkSpec "git-v4" (Text -> ThunkSpec) -> Text -> ThunkSpec
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ "# DO NOT HAND-EDIT THIS FILE"
, "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
, " let realUrl = let firstChar = builtins.substring 0 1 url; in"
, " if firstChar == \"/\" then /. + url"
, " else if firstChar == \".\" then ./. + url"
, " else url;"
, " in if !fetchSubmodules && private then builtins.fetchGit {"
, " url = realUrl; inherit rev;"
, " ${if branch == null then null else \"ref\"} = branch;"
, " } else (import <nixpkgs> {}).fetchgit {"
, " url = realUrl; inherit rev sha256;"
, " };"
, "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
]
legacyGitThunkSpec :: Text -> Text -> ThunkSpec
legacyGitThunkSpec :: Text -> Text -> ThunkSpec
legacyGitThunkSpec name :: Text
name loader :: 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
[ ("default.nix", Text -> ThunkFileSpec
ThunkFileSpec_FileMatches (Text -> ThunkFileSpec) -> Text -> ThunkFileSpec
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
loader)
, ("git.json" , (ByteString -> Either String ThunkPtr) -> ThunkFileSpec
ThunkFileSpec_Ptr ByteString -> Either String ThunkPtr
parseGitJsonBytes)
, (String
attrCacheFileName, ThunkFileSpec
ThunkFileSpec_AttrCache)
, (".git", ThunkFileSpec
ThunkFileSpec_CheckoutIndicator)
]
gitThunkSpecV5 :: ThunkSpec
gitThunkSpecV5 :: ThunkSpec
gitThunkSpecV5 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "git-v5" "git.json" ByteString -> Either String ThunkPtr
parseGitJsonBytes [here|
# DO NOT HAND-EDIT THIS FILE
let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
let realUrl = let firstChar = builtins.substring 0 1 url; in
if firstChar == "/" then /. + url
else if firstChar == "." then ./. + url
else url;
in if !fetchSubmodules && private then builtins.fetchGit {
url = realUrl; inherit rev;
${if branch == null then null else "ref"} = branch;
} else (import <nixpkgs> {}).fetchgit {
url = realUrl; inherit rev sha256;
};
json = builtins.fromJSON (builtins.readFile ./git.json);
in fetch json
|]
gitThunkSpecV6 :: ThunkSpec
gitThunkSpecV6 :: ThunkSpec
gitThunkSpecV6 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "git-v6" "git.json" ByteString -> Either String ThunkPtr
parseGitJsonBytes [here|
# DO NOT HAND-EDIT THIS FILE
let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
let realUrl = let firstChar = builtins.substring 0 1 url; in
if firstChar == "/" then /. + url
else if firstChar == "." then ./. + url
else url;
in if !fetchSubmodules && private then builtins.fetchGit {
url = realUrl; inherit rev;
${if branch == null then null else "ref"} = branch;
} else (builtins.fetchTarball {
url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
}).fetchgit {
url = realUrl; inherit rev sha256;
};
json = builtins.fromJSON (builtins.readFile ./git.json);
in fetch json
|]
gitThunkSpecV7 :: ThunkSpec
gitThunkSpecV7 :: ThunkSpec
gitThunkSpecV7 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "git-v7" "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|]
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 (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 name :: Text
name jsonFileName :: String
jsonFileName parser :: ByteString -> Either String ThunkPtr
parser srcNix :: 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
[ ("default.nix", Text -> ThunkFileSpec
ThunkFileSpec_FileMatches Text
defaultNixViaSrc)
, ("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
</> ".git", ThunkFileSpec
ThunkFileSpec_CheckoutIndicator)
]
where
defaultNixViaSrc :: Text
defaultNixViaSrc = [here|
# DO NOT HAND-EDIT THIS FILE
import (import ./thunk.nix)
|]
parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
parseJsonObject :: (Object -> Parser a) -> ByteString -> Either String a
parseJsonObject p :: Object -> Parser a
p bytes :: 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
nixBuildThunkAttrWithCache
:: ( MonadIO m
, MonadLog Output m
, HasCliConfig NixThunkError m
, MonadMask m
, MonadError NixThunkError m
, MonadFail m
)
=> ThunkSpec
-> FilePath
-> String
-> m (Maybe FilePath)
nixBuildThunkAttrWithCache :: ThunkSpec -> String -> String -> m (Maybe String)
nixBuildThunkAttrWithCache thunkSpec :: ThunkSpec
thunkSpec thunkDir :: String
thunkDir attr :: String
attr = do
UTCTime
latestChange <- IO UTCTime -> m UTCTime
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 (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 a. Exception IOError => IO a -> IO (Either IOError a)
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 = 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 (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)
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' :: Maybe (NonEmpty String)
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_AttrCache -> Bool
True; _ -> 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
Maybe (NonEmpty String)
-> (NonEmpty String -> m String) -> m (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (NonEmpty String)
cachePaths' ((NonEmpty String -> m String) -> m (Maybe String))
-> (NonEmpty String -> m String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ \cachePaths :: NonEmpty String
cachePaths ->
(NonEmpty String -> String) -> m (NonEmpty String) -> m String
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
$ \cacheDir :: String
cacheDir -> do
let
cachePath :: String
cachePath = String
thunkDir String -> ShowS
</> String
cacheDir String -> ShowS
</> String
attr String -> ShowS
<.> "out"
cacheErrHandler :: IOError -> f (Maybe a)
cacheErrHandler e :: IOError
e
| IOError -> Bool
isDoesNotExistError IOError
e = Maybe a -> f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe a
forall a. Maybe a
Nothing Maybe a -> f () -> f (Maybe 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)
Maybe String
cacheHit <- (IOError -> m (Maybe String))
-> m (Maybe String) -> m (Maybe String)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOError -> m (Maybe String)
forall (f :: * -> *) a. MonadLog Output 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
UTCTime
cacheTime <- IO UTCTime -> m UTCTime
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
Maybe String -> m (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> m (Maybe String))
-> Maybe String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ if UTCTime
latestChange UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
cacheTime
then String -> Maybe String
forall a. a -> Maybe a
Just String
cachePath
else Maybe String
forall a. Maybe a
Nothing
case Maybe String
cacheHit of
Just c :: String
c -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
c
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
attr, " not cached, building ..."]
IO () -> m ()
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 (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
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 :: Maybe String -> Maybe String -> Maybe String -> Target
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
}
nixBuildAttrWithCache
:: ( MonadLog Output m
, HasCliConfig NixThunkError m
, MonadIO m
, MonadMask m
, MonadError NixThunkError m
, MonadFail m
)
=> FilePath
-> String
-> m FilePath
nixBuildAttrWithCache :: String -> String -> m String
nixBuildAttrWithCache exprPath :: String
exprPath attr :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right (ThunkData_Packed spec :: ThunkSpec
spec _) ->
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 (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
_ -> 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
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 :: Maybe String -> Maybe String -> Maybe String -> Target
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
}
updateThunk :: MonadNixThunk m => FilePath -> (FilePath -> m a) -> m a
updateThunk :: String -> (String -> m a) -> m a
updateThunk p :: String
p f :: String -> m a
f = String -> (String -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory "obelisk-thunkptr-" ((String -> m a) -> m a) -> (String -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \tmpDir :: String
tmpDir -> do
String
p' <- String -> String -> m String
forall (m :: * -> *).
(MonadError NixThunkError m, MonadFail m, MonadMask m, MonadIO m,
HasCliConfig NixThunkError m, MonadLog Output m) =>
String -> String -> m String
copyThunkToTmp String
tmpDir String
p
Bool -> String -> m ()
forall (m :: * -> *). MonadNixThunk m => Bool -> String -> m ()
unpackThunk' Bool
True String
p'
a
result <- String -> m a
f String
p'
String -> m ()
forall (m :: * -> *).
(MonadError NixThunkError m, MonadFail m, MonadMask m, MonadIO m,
HasCliConfig NixThunkError m, MonadLog Output m) =>
String -> m ()
updateThunkFromTmp String
p'
a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
where
copyThunkToTmp :: String -> String -> m String
copyThunkToTmp tmpDir :: String
tmpDir thunkDir :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left err :: ReadThunkError
err -> Text -> m String
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith (Text -> m String) -> Text -> m String
forall a b. (a -> b) -> a -> b
$ "withThunkUnpacked: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ReadThunkError -> String
forall a. Show a => a -> String
show ReadThunkError
err)
Right ThunkData_Packed{} -> do
let tmpThunk :: String
tmpThunk = String
tmpDir String -> ShowS
</> "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 ["-r", "-T", String
thunkDir, String
tmpThunk]
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tmpThunk
Right _ -> Text -> m String
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith "Thunk is not packed"
updateThunkFromTmp :: String -> m ()
updateThunkFromTmp p' :: String
p' = do
ThunkPtr
_ <- 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'
(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 ["-r", "-T", String
p', String
p]
finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
finalMsg noTrail :: Bool
noTrail s :: 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
checkThunkDirectory :: MonadNixThunk m => FilePath -> m ()
checkThunkDirectory :: String -> m ()
checkThunkDirectory thunkDir :: String
thunkDir = do
String
currentDir <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
String
thunkDir' <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
thunkDir
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
thunkDir' String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` String
currentDir) (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 [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ShowS
takeFileName String
thunkDir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
unpackedDirName) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk (ShowS
takeDirectory String
thunkDir) m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right _ -> 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 _ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
unpackThunk :: MonadNixThunk m => FilePath -> m ()
unpackThunk :: String -> m ()
unpackThunk = Bool -> String -> m ()
forall (m :: * -> *). MonadNixThunk m => Bool -> String -> m ()
unpackThunk' Bool
False
unpackThunk' :: MonadNixThunk m => Bool -> FilePath -> m ()
unpackThunk' :: Bool -> String -> m ()
unpackThunk' noTrail :: Bool
noTrail thunkDir :: String
thunkDir = String -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> m ()
checkThunkDirectory String
thunkDir m ()
-> m (Either ReadThunkError ThunkData)
-> m (Either ReadThunkError ThunkData)
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left err :: ReadThunkError
err -> Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
Right 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 _ tptr :: ThunkPtr
tptr) -> do
let (thunkParent :: String
thunkParent, thunkName :: 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
$ \tmpThunk :: 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 _ -> NonEmpty ThunkSpec -> ThunkSpec
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty ThunkSpec
gitHubThunkSpecs
ThunkSource_Git _ -> 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' ("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
$ "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
$
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 (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
-> Ref hash
-> FilePath
-> m ()
gitCloneForThunkUnpack :: GitSource -> Ref hash -> String -> m ()
gitCloneForThunkUnpack gitSrc :: GitSource
gitSrc commit :: Ref hash
commit dir :: String
dir = do
let git :: [String] -> m ()
git = (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
Notice) (ProcessSpec -> m ())
-> ([String] -> ProcessSpec) -> [String] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> ProcessSpec
gitProc String
dir
[String] -> m ()
git ([String] -> m ()) -> [String] -> m ()
forall a b. (a -> b) -> a -> b
$ [ "clone" ]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["--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 Name Branch
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", 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 ]
[String] -> m ()
git ["reset", "--hard", Ref hash -> String
forall hash. Ref hash -> String
refToHexString Ref hash
commit]
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GitSource -> Bool
_gitSource_fetchSubmodules GitSource
gitSrc) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
[String] -> m ()
git ["submodule", "update", "--recursive", "--init"]
packThunk :: MonadNixThunk m => ThunkPackConfig -> FilePath -> m ThunkPtr
packThunk :: 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' :: Bool -> ThunkPackConfig -> String -> m ThunkPtr
packThunk' noTrail :: Bool
noTrail (ThunkPackConfig force :: Bool
force thunkConfig :: ThunkConfig
thunkConfig) thunkDir :: String
thunkDir = String -> m ()
forall (m :: * -> *). MonadNixThunk m => String -> m ()
checkThunkDirectory String
thunkDir m ()
-> m (Either ReadThunkError ThunkData)
-> m (Either ReadThunkError ThunkData)
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 (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|]
_ -> 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'
("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
$ "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
thunkPtr <- ThunkConfig -> ThunkPtr -> ThunkPtr
modifyThunkPtrByConfig ThunkConfig
thunkConfig (ThunkPtr -> ThunkPtr) -> m ThunkPtr -> m ThunkPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckClean -> String -> Maybe Bool -> m ThunkPtr
forall (m :: * -> *).
MonadNixThunk m =>
CheckClean -> String -> Maybe Bool -> m ThunkPtr
getThunkPtr CheckClean
checkClean String
thunkDir (ThunkConfig -> Maybe Bool
_thunkConfig_private ThunkConfig
thunkConfig)
IO () -> m ()
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
thunkDir
String -> Either ThunkSpec ThunkPtr -> m ()
forall (m :: * -> *).
MonadNixThunk m =>
String -> Either ThunkSpec ThunkPtr -> m ()
createThunk String
thunkDir (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
thunkPtr
ThunkPtr -> m ThunkPtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThunkPtr
thunkPtr
modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
modifyThunkPtrByConfig (ThunkConfig markPrivate' :: Maybe Bool
markPrivate') ptr :: ThunkPtr
ptr = case Maybe Bool
markPrivate' of
Nothing -> ThunkPtr
ptr
Just markPrivate :: Bool
markPrivate -> ThunkPtr
ptr { _thunkPtr_source :: ThunkSource
_thunkPtr_source = case ThunkPtr -> ThunkSource
_thunkPtr_source ThunkPtr
ptr of
ThunkSource_Git s :: GitSource
s -> GitSource -> ThunkSource
ThunkSource_Git (GitSource -> ThunkSource) -> GitSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ GitSource
s { _gitSource_private :: Bool
_gitSource_private = Bool
markPrivate }
ThunkSource_GitHub s :: GitHubSource
s -> GitHubSource -> ThunkSource
ThunkSource_GitHub (GitHubSource -> ThunkSource) -> GitHubSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ GitHubSource
s { _gitHubSource_private :: Bool
_gitHubSource_private = Bool
markPrivate }
}
data CheckClean
= CheckClean_FullCheck
| CheckClean_NotIgnored
| CheckClean_NoCheck
getThunkPtr :: forall m. MonadNixThunk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
getThunkPtr :: CheckClean -> String -> Maybe Bool -> m ThunkPtr
getThunkPtr gitCheckClean :: CheckClean
gitCheckClean dir :: String
dir mPrivate :: 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 (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ShowS
normalise)
[(".git", "."), (String
unpackedDirName String -> ShowS
</> ".git", String
unpackedDirName)]
Maybe (String, String)
repoLocation' <- IO (Maybe (String, String)) -> m (Maybe (String, String))
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
String
thunkDir <- case Maybe (String, String)
repoLocation' of
Nothing -> Text -> m String
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith [i|Can't find an unpacked thunk in ${dir}|]
Just (_, path :: String
path) -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
path
let (checkClean :: Bool
checkClean, checkIgnored :: Bool
checkIgnored) = case CheckClean
gitCheckClean of
CheckClean_FullCheck -> (Bool
True, Bool
True)
CheckClean_NotIgnored -> (Bool
True, Bool
False)
CheckClean_NoCheck -> (Bool
False, Bool
False)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkClean (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Text -> m ()
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m, AsUnstructuredError e, HasCliConfig e m,
MonadMask m) =>
String -> Bool -> Text -> m ()
ensureCleanGitRepo String
thunkDir Bool
checkIgnored
"thunk pack: thunk checkout contains unsaved modifications"
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkClean (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Text
stashOutput <- String -> [String] -> m Text
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m, MonadMask m) =>
String -> [String] -> m Text
readGitProcess String
thunkDir ["stash", "list"]
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
stashOutput) (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] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
[ "thunk pack: thunk checkout has stashes"
, "git stash list:"
] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Text]
T.lines Text
stashOutput
(mCurrentBranch :: Maybe Text
mCurrentBranch, mCurrentCommit :: Maybe Text
mCurrentCommit) <- do
Maybe Text
b <- [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> (Text -> [Text]) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> Maybe Text) -> m Text -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> m Text
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m, MonadMask m) =>
String -> [String] -> m Text
readGitProcess String
thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
Maybe Text
c <- [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> (Text -> [Text]) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> Maybe Text) -> m Text -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> m Text
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m, MonadMask m) =>
String -> [String] -> m Text
readGitProcess String
thunkDir ["rev-parse", "HEAD"]
case Maybe Text
b of
(Just "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
[ "thunk pack: You are in 'detached HEAD' state."
, "If you want to pack at the current ref \
\then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
]
_ -> (Maybe Text, Maybe Text) -> m (Maybe Text, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
b, Maybe Text
c)
[Text]
headDump :: [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 :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m, MonadMask m) =>
String -> [String] -> m Text
readGitProcess String
thunkDir
[ "for-each-ref"
, "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
, "refs/heads/"
]
(Map Text (Maybe (Text, Text))
headInfo :: Map Text (Maybe (Text, Text)))
<- ([(Text, Maybe (Text, Text))] -> Map Text (Maybe (Text, Text)))
-> m [(Text, Maybe (Text, Text))]
-> m (Map Text (Maybe (Text, Text)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, Maybe (Text, Text))] -> Map Text (Maybe (Text, Text))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(Text, Maybe (Text, Text))]
-> m (Map Text (Maybe (Text, Text))))
-> m [(Text, Maybe (Text, Text))]
-> m (Map Text (Maybe (Text, Text)))
forall a b. (a -> b) -> a -> b
$ [Text]
-> (Text -> m (Text, Maybe (Text, Text)))
-> m [(Text, Maybe (Text, Text))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
headDump ((Text -> m (Text, Maybe (Text, Text)))
-> m [(Text, Maybe (Text, Text))])
-> (Text -> m (Text, Maybe (Text, Text)))
-> m [(Text, Maybe (Text, Text))]
forall a b. (a -> b) -> a -> b
$ \line :: Text
line -> do
(branch :: Text
branch : restOfLine :: [Text]
restOfLine) <- [Text] -> m [Text]
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
Maybe (Text, Text)
mUpstream <- case [Text]
restOfLine of
[] -> Maybe (Text, Text) -> m (Maybe (Text, Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, Text)
forall a. Maybe a
Nothing
[u :: Text
u, r :: Text
r] -> Maybe (Text, Text) -> m (Maybe (Text, Text))
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 -> m (Maybe (Text, Text))
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith "git for-each-ref invalid output"
(Text, Maybe (Text, Text)) -> m (Text, Maybe (Text, Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
branch, Maybe (Text, Text)
mUpstream)
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "branches: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Map Text (Maybe (Text, Text)) -> String
forall a. Show a => a -> String
show Map Text (Maybe (Text, Text))
headInfo)
let errorMap :: Map Text ()
headUpstream :: Map Text (Text, Text)
(errorMap :: Map Text ()
errorMap, headUpstream :: Map Text (Text, Text)
headUpstream) = ((Maybe (Text, Text) -> Either () (Text, Text))
-> Map Text (Maybe (Text, Text))
-> (Map Text (), Map Text (Text, Text)))
-> Map Text (Maybe (Text, Text))
-> (Maybe (Text, Text) -> Either () (Text, Text))
-> (Map Text (), Map Text (Text, Text))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (Text, Text) -> Either () (Text, Text))
-> Map Text (Maybe (Text, Text))
-> (Map Text (), Map Text (Text, Text))
forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
Map.mapEither Map Text (Maybe (Text, Text))
headInfo ((Maybe (Text, Text) -> Either () (Text, Text))
-> (Map Text (), Map Text (Text, Text)))
-> (Maybe (Text, Text) -> Either () (Text, Text))
-> (Map Text (), Map Text (Text, Text))
forall a b. (a -> b) -> a -> b
$ \case
Nothing -> () -> Either () (Text, Text)
forall a b. a -> Either a b
Left ()
Just b :: (Text, Text)
b -> (Text, Text) -> Either () (Text, Text)
forall a b. b -> Either a b
Right (Text, Text)
b
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "branches with upstream branch set: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Map Text (Text, Text) -> String
forall a. Show a => a -> String
show Map Text (Text, Text)
headUpstream)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkClean (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let untrackedBranches :: [Text]
untrackedBranches = Map Text () -> [Text]
forall k a. Map k a -> [k]
Map.keys Map Text ()
errorMap
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Text]
untrackedBranches) (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] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
[ "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:"
, ""
, [Text] -> Text
T.unwords [Text]
untrackedBranches
, ""
, "To fix this, you probably want to do:"
, ""
] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
((\branch :: Text
branch -> "git push -u origin " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch) (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
untrackedBranches) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
[ ""
, "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."
]
Map Text (Text, (Int, Int))
stats <- Map Text (Text, Text)
-> (Text -> (Text, Text) -> m (Text, (Int, Int)))
-> m (Map Text (Text, (Int, Int)))
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
t a -> (i -> a -> f b) -> f (t b)
ifor Map Text (Text, Text)
headUpstream ((Text -> (Text, Text) -> m (Text, (Int, Int)))
-> m (Map Text (Text, (Int, Int))))
-> (Text -> (Text, Text) -> m (Text, (Int, Int)))
-> m (Map Text (Text, (Int, Int)))
forall a b. (a -> b) -> a -> b
$ \branch :: Text
branch (upstream :: Text
upstream, _remote :: Text
_remote) -> do
([Text]
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 :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m, MonadMask m) =>
String -> [String] -> m Text
readGitProcess String
thunkDir
[ "rev-list", "--left-right"
, Text -> String
T.unpack Text
branch String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "..." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
upstream
]
let ahead :: Int
ahead = [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> [()] -> Int
forall a b. (a -> b) -> a -> b
$ [ () | Just ('<', _) <- 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
behind = [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> [()] -> Int
forall a b. (a -> b) -> a -> b
$ [ () | Just ('>', _) <- 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 ]
(Text, (Int, Int)) -> m (Text, (Int, Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
upstream, (Int
ahead, Int
behind))
let nonGood :: Map Text (Text, (Int, Int))
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
/= 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
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map Text (Text, (Int, Int)) -> Bool
forall k a. Map k a -> Bool
Map.null Map Text (Text, (Int, Int))
nonGood) (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] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
[ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
, ""
] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
(((Text, (Text, (Int, Int))) -> Text)
-> [(Text, (Text, (Int, Int)))] -> [Text])
-> [(Text, (Text, (Int, Int)))]
-> ((Text, (Text, (Int, Int))) -> Text)
-> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, (Text, (Int, Int))) -> Text)
-> [(Text, (Text, (Int, Int)))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Map Text (Text, (Int, Int)) -> [(Text, (Text, (Int, Int)))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Text, (Int, Int))
nonGood) (\(branch :: Text
branch, (upstream :: Text
upstream, (ahead :: Int
ahead, behind :: Int
behind))) -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[" ", Text
branch, " ahead: ", String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
ahead), " behind: ", String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
behind), " remote branch ", Text
upstream]) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
[ ""
, "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.)"
]
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checkClean (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Informational "All changes safe in git remotes. OK to pack thunk."
let remote :: Text
remote = Text -> ((Text, Text) -> Text) -> Maybe (Text, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "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' :: Text
remoteUri'] <- (Text -> [Text]) -> m Text -> m [Text]
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
$ String -> [String] -> m Text
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m, MonadMask m) =>
String -> [String] -> m Text
readGitProcess String
thunkDir
[ "config"
, "--get"
, "remote." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
remote String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".url"
]
GitUri
remoteUri <- case Text -> Maybe GitUri
parseGitUri Text
remoteUri' of
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
$ "Could not identify git remote: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
remoteUri'
Just uri :: GitUri
uri -> GitUri -> m GitUri
forall (f :: * -> *) a. Applicative f => a -> f a
pure GitUri
uri
GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
uriThunkPtr GitUri
remoteUri Maybe Bool
mPrivate Maybe Text
mCurrentBranch Maybe Text
mCurrentCommit
getLatestRev :: MonadNixThunk m => ThunkSource -> m ThunkRev
getLatestRev :: ThunkSource -> m ThunkRev
getLatestRev os :: ThunkSource
os = do
let gitS :: GitSource
gitS = ThunkSource -> GitSource
thunkSourceToGitSource ThunkSource
os
(_, commit :: Text
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)
case ThunkSource
os of
ThunkSource_GitHub s :: GitHubSource
s -> GitHubSource -> Text -> m ThunkRev
forall (m :: * -> *).
MonadNixThunk m =>
GitHubSource -> Text -> m ThunkRev
githubThunkRev GitHubSource
s Text
commit
ThunkSource_Git s :: GitSource
s -> GitSource -> Text -> m ThunkRev
forall (m :: * -> *).
MonadNixThunk m =>
GitSource -> Text -> m ThunkRev
gitThunkRev GitSource
s Text
commit
uriThunkPtr :: MonadNixThunk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
uriThunkPtr :: GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
uriThunkPtr uri :: GitUri
uri mPrivate :: Maybe Bool
mPrivate mbranch :: Maybe Text
mbranch mcommit :: Maybe Text
mcommit = do
Text
commit <- case Maybe Text
mcommit of
Nothing -> GitUri -> Maybe Text -> m (Text, Text)
forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Text -> m (Text, Text)
gitGetCommitBranch GitUri
uri Maybe Text
mbranch m (Text, Text) -> ((Text, Text) -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text)
-> ((Text, Text) -> Text) -> (Text, Text) -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> b
snd
(Just c :: Text
c) -> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
c
(src :: ThunkSource
src, rev :: ThunkRev
rev) <- GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
forall (m :: * -> *).
MonadNixThunk m =>
GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
uriToThunkSource GitUri
uri Maybe Bool
mPrivate Maybe Text
mbranch m ThunkSource
-> (ThunkSource -> m (ThunkSource, ThunkRev))
-> m (ThunkSource, ThunkRev)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ThunkSource_GitHub s :: GitHubSource
s -> do
Either NixThunkError ThunkRev
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 Either NixThunkError ThunkRev
rev of
Right r :: ThunkRev
r -> (ThunkSource, ThunkRev) -> m (ThunkSource, ThunkRev)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitHubSource -> ThunkSource
ThunkSource_GitHub GitHubSource
s, ThunkRev
r)
Left e :: NixThunkError
e -> do
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Warning "\
\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 s :: 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
ThunkPtr -> m ThunkPtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThunkPtr -> m ThunkPtr) -> ThunkPtr -> m ThunkPtr
forall a b. (a -> b) -> a -> b
$ ThunkPtr :: ThunkRev -> ThunkSource -> ThunkPtr
ThunkPtr
{ _thunkPtr_rev :: ThunkRev
_thunkPtr_rev = ThunkRev
rev
, _thunkPtr_source :: ThunkSource
_thunkPtr_source = ThunkSource
src
}
uriToThunkSource :: MonadNixThunk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
uriToThunkSource :: GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
uriToThunkSource (GitUri u :: URI
u) mPrivate :: Maybe Bool
mPrivate
| Right uriAuth :: Authority
uriAuth <- URI -> Either Bool Authority
URI.uriAuthority URI
u
, Just scheme :: 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
"ssh" -> Authority
uriAuth Authority -> Authority -> Bool
forall a. Eq a => a -> a -> Bool
== Authority :: Maybe UserInfo -> RText 'Host -> Maybe Word -> Authority
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 "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 "github.com"
, authPort :: Maybe Word
URI.authPort = Maybe Word
forall a. Maybe a
Nothing
}
s :: Text
s -> Text
s Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [ "git", "https", "http" ]
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
== "github.com"
, Just (_, owner :: RText 'PathPiece
owner :| [repoish :: RText 'PathPiece
repoish]) <- URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
u
= \mbranch :: Maybe Text
mbranch -> do
Bool
isPrivate <- m Bool
getIsPrivate
ThunkSource -> m ThunkSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThunkSource -> m ThunkSource) -> ThunkSource -> m ThunkSource
forall a b. (a -> b) -> a -> b
$ GitHubSource -> ThunkSource
ThunkSource_GitHub (GitHubSource -> ThunkSource) -> GitHubSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ GitHubSource :: Name Owner
-> Name Repo -> Maybe (Name Branch) -> Bool -> GitHubSource
GitHubSource
{ _gitHubSource_owner :: Name Owner
_gitHubSource_owner = Text -> Name Owner
forall entity. Text -> Name entity
N (Text -> Name Owner) -> Text -> Name Owner
forall a b. (a -> b) -> a -> b
$ RText 'PathPiece -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText RText 'PathPiece
owner
, _gitHubSource_repo :: Name Repo
_gitHubSource_repo = Text -> Name Repo
forall entity. Text -> Name entity
N (Text -> Name Repo) -> Text -> Name Repo
forall a b. (a -> b) -> a -> b
$ let
repoish' :: Text
repoish' = RText 'PathPiece -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText RText 'PathPiece
repoish
in Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
repoish' (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix ".git" Text
repoish'
, _gitHubSource_branch :: Maybe (Name Branch)
_gitHubSource_branch = Text -> Name Branch
forall entity. Text -> Name entity
N (Text -> Name Branch) -> Maybe Text -> Maybe (Name Branch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbranch
, _gitHubSource_private :: Bool
_gitHubSource_private = Bool
isPrivate
}
| Bool
otherwise = \mbranch :: Maybe Text
mbranch -> do
Bool
isPrivate <- m Bool
getIsPrivate
ThunkSource -> m ThunkSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThunkSource -> m ThunkSource) -> ThunkSource -> m ThunkSource
forall a b. (a -> b) -> a -> b
$ GitSource -> ThunkSource
ThunkSource_Git (GitSource -> ThunkSource) -> GitSource -> ThunkSource
forall a b. (a -> b) -> a -> b
$ GitSource :: GitUri -> Maybe (Name Branch) -> Bool -> Bool -> GitSource
GitSource
{ _gitSource_url :: GitUri
_gitSource_url = URI -> GitUri
GitUri URI
u
, _gitSource_branch :: Maybe (Name Branch)
_gitSource_branch = Text -> Name Branch
forall entity. Text -> Name entity
N (Text -> Name Branch) -> Maybe Text -> Maybe (Name Branch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbranch
, _gitSource_fetchSubmodules :: Bool
_gitSource_fetchSubmodules = Bool
False
, _gitSource_private :: Bool
_gitSource_private = Bool
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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
mPrivate
guessGitRepoIsPrivate :: MonadNixThunk m => GitUri -> m Bool
guessGitRepoIsPrivate :: GitUri -> m Bool
guessGitRepoIsPrivate uri :: 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
$ \loop :: [GitUri] -> m Bool
loop -> \case
[] -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
uriAttempt :: GitUri
uriAttempt:xs :: [GitUri]
xs -> do
(ExitCode, String, String)
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
[ "ls-remote"
, "--quiet"
, "--exit-code"
, "--symref"
, Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ GitUri -> Text
gitUriToText GitUri
uriAttempt
]
case (ExitCode, String, String)
result of
(ExitSuccess, _, _) -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
_ -> [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
$
[GitUri
uri | (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Maybe Text
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 "ssh"] [GitUri] -> [GitUri] -> [GitUri]
forall a. Semigroup a => a -> a -> a
<>
[Text -> GitUri -> GitUri
changeScheme "https" GitUri
uri, Text -> GitUri -> GitUri
changeScheme "http" GitUri
uri]
changeScheme :: Text -> GitUri -> GitUri
changeScheme scheme :: Text
scheme (GitUri u :: URI
u) = URI -> GitUri
GitUri (URI -> GitUri) -> URI -> GitUri
forall a b. (a -> b) -> a -> b
$ URI
u
{ uriScheme :: Maybe (RText 'Scheme)
URI.uriScheme = Text -> Maybe (RText 'Scheme)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'Scheme)
URI.mkScheme Text
scheme
, uriAuthority :: Either Bool Authority
URI.uriAuthority = (\x :: Authority
x -> Authority
x { authUserInfo :: Maybe UserInfo
URI.authUserInfo = Maybe UserInfo
forall a. Maybe a
Nothing }) (Authority -> Authority)
-> Either Bool Authority -> Either Bool Authority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> Either Bool Authority
URI.uriAuthority URI
u
}
githubThunkRev
:: forall m
. MonadNixThunk m
=> GitHubSource
-> Text
-> m ThunkRev
githubThunkRev :: GitHubSource -> Text -> m ThunkRev
githubThunkRev s :: GitHubSource
s commit :: Text
commit = do
RText 'PathPiece
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
RText 'PathPiece
repo <- Name Repo -> m (RText 'PathPiece)
forall entity. Name entity -> m (RText 'PathPiece)
forcePP (Name Repo -> m (RText 'PathPiece))
-> Name Repo -> m (RText 'PathPiece)
forall a b. (a -> b) -> a -> b
$ GitHubSource -> Name Repo
_gitHubSource_repo GitHubSource
s
RText 'PathPiece
revTarball <- Text -> m (RText 'PathPiece)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'PathPiece)
URI.mkPathPiece (Text -> m (RText 'PathPiece)) -> Text -> m (RText 'PathPiece)
forall a b. (a -> b) -> a -> b
$ Text
commit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".tar.gz"
let archiveUri :: GitUri
archiveUri = URI -> GitUri
GitUri (URI -> GitUri) -> URI -> GitUri
forall a b. (a -> b) -> a -> b
$ URI :: Maybe (RText 'Scheme)
-> Either Bool Authority
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> [QueryParam]
-> Maybe (RText 'Fragment)
-> URI
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 "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
$ Authority :: Maybe UserInfo -> RText 'Host -> Maybe Word -> Authority
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 "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 "archive", RText 'PathPiece
revTarball ]
)
, uriQuery :: [QueryParam]
URI.uriQuery = []
, uriFragment :: Maybe (RText 'Fragment)
URI.uriFragment = Maybe (RText 'Fragment)
forall a. Maybe a
Nothing
}
Text
hash <- GitUri -> m Text
forall (m :: * -> *). MonadNixThunk m => GitUri -> m Text
getNixSha256ForUriUnpacked GitUri
archiveUri
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Nix sha256 is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash
ThunkRev -> m ThunkRev
forall (m :: * -> *) a. Monad m => a -> m a
return (ThunkRev -> m ThunkRev) -> ThunkRev -> m ThunkRev
forall a b. (a -> b) -> a -> b
$ ThunkRev :: Ref SHA1 -> Text -> ThunkRev
ThunkRev
{ _thunkRev_commit :: Ref SHA1
_thunkRev_commit = Name Commit -> Ref SHA1
commitNameToRef (Name Commit -> Ref SHA1) -> Name Commit -> Ref SHA1
forall a b. (a -> b) -> a -> b
$ Text -> Name Commit
forall entity. Text -> Name entity
N Text
commit
, _thunkRev_nixSha256 :: Text
_thunkRev_nixSha256 = Text
hash
}
where
forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
forcePP :: 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 :: GitSource -> Text -> m ThunkRev
gitThunkRev s :: GitSource
s commit :: Text
commit = do
let u :: GitUri
u = GitSource -> GitUri
_gitSource_url GitSource
s
protocols :: [Text]
protocols = ["file", "https", "ssh", "git"]
scheme :: Text
scheme = Text -> (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "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 x :: 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 (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
$ "obelisk currently only supports "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate ", " [Text]
protocols Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " protocols for plain Git remotes"
Text
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
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Informational (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Nix sha256 is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash
ThunkRev -> m ThunkRev
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ThunkRev -> m ThunkRev) -> ThunkRev -> m ThunkRev
forall a b. (a -> b) -> a -> b
$ ThunkRev :: Ref SHA1 -> Text -> ThunkRev
ThunkRev
{ _thunkRev_commit :: Ref SHA1
_thunkRev_commit = Name Commit -> Ref SHA1
commitNameToRef (Text -> Name Commit
forall entity. Text -> Name entity
N Text
commit)
, _thunkRev_nixSha256 :: Text
_thunkRev_nixSha256 = Text
hash
}
gitGetCommitBranch
:: MonadNixThunk m => GitUri -> Maybe Text -> m (Text, CommitId)
gitGetCommitBranch :: GitUri -> Maybe Text -> m (Text, Text)
gitGetCommitBranch uri :: GitUri
uri mbranch :: Maybe Text
mbranch = Text -> m (Text, Text) -> m (Text, Text)
forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage ("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 :: GitLsRemoteMaps
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
Text
branch <- case Maybe Text
mbranch of
Nothing -> Text -> m Text -> m Text
forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage "Failed to find default branch" (m Text -> m Text) -> m Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
Text
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
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Default branch for remote repo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uriMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b
Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
b
Just b :: Text
b -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
b
Text
commit <- 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 -> GitRef -> Either Text Text
gitLookupCommitForRef GitLsRemoteMaps
bothMaps (Text -> GitRef
GitRef_Branch Text
branch)
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Informational (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Latest commit in branch " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " from remote repo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uriMsg
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit
(Text, Text) -> m (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
branch, Text
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 (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 x :: 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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe URI
parseAbsoluteURI Text
x Maybe URI -> Maybe URI -> Maybe URI
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 uri :: Text
uri = if "/" Text -> Text -> Bool
`T.isPrefixOf` Text
uri then Text -> Maybe URI
parseAbsoluteURI ("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 uri :: Text
uri = do
URI
parsedUri <- Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI Text
uri
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ URI -> Bool
URI.isPathAbsolute URI
parsedUri
URI -> Maybe URI
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
parsedUri
parseSshShorthand :: Text -> Maybe URI.URI
parseSshShorthand :: Text -> Maybe URI
parseSshShorthand uri :: Text
uri = do
let
(authAndHostname :: Text
authAndHostname, colonAndPath :: Text
colonAndPath) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':') Text
uri
properUri :: Text
properUri = "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
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop 1 Text
colonAndPath
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
=='/') 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
newtype Ref hash = Ref { 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
/= :: 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
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
min :: Ref hash -> Ref hash -> Ref hash
$cmin :: forall hash. Ref hash -> Ref hash -> Ref hash
max :: Ref hash -> Ref hash -> Ref hash
$cmax :: forall hash. Ref hash -> Ref hash -> Ref hash
>= :: 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
$c< :: forall hash. Ref hash -> Ref hash -> Bool
compare :: Ref hash -> Ref hash -> Ordering
$ccompare :: forall hash. Ref hash -> Ref hash -> Ordering
$cp1Ord :: forall hash. Eq (Ref hash)
Ord, Typeable)
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
showList :: [RefInvalid] -> ShowS
$cshowList :: [RefInvalid] -> ShowS
show :: RefInvalid -> String
$cshow :: RefInvalid -> String
showsPrec :: Int -> RefInvalid -> ShowS
$cshowsPrec :: Int -> RefInvalid -> ShowS
Show, RefInvalid -> RefInvalid -> Bool
(RefInvalid -> RefInvalid -> Bool)
-> (RefInvalid -> RefInvalid -> Bool) -> Eq RefInvalid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RefInvalid -> RefInvalid -> Bool
$c/= :: RefInvalid -> RefInvalid -> Bool
== :: RefInvalid -> RefInvalid -> Bool
$c== :: RefInvalid -> RefInvalid -> Bool
Eq, Typeable RefInvalid
DataType
Constr
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 -> DataType
RefInvalid -> Constr
(forall b. Data b => b -> b) -> RefInvalid -> RefInvalid
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RefInvalid -> c RefInvalid
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cRefInvalid :: Constr
$tRefInvalid :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> RefInvalid -> m RefInvalid
gmapQi :: Int -> (forall d. Data d => d -> u) -> RefInvalid -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> RefInvalid -> u
gmapQ :: (forall d. Data d => d -> u) -> RefInvalid -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> RefInvalid -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RefInvalid -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> RefInvalid -> r
gmapT :: (forall b. Data b => b -> b) -> RefInvalid -> RefInvalid
$cgmapT :: (forall b. Data b => b -> b) -> RefInvalid -> RefInvalid
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c RefInvalid)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c RefInvalid)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c RefInvalid)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c RefInvalid)
dataTypeOf :: RefInvalid -> DataType
$cdataTypeOf :: RefInvalid -> DataType
toConstr :: RefInvalid -> Constr
$ctoConstr :: RefInvalid -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RefInvalid
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c RefInvalid
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RefInvalid -> c RefInvalid
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> RefInvalid -> c RefInvalid
$cp1Data :: Typeable RefInvalid
Data, Typeable)
instance Exception RefInvalid
refFromHexString :: HashAlgorithm hash => String -> Ref hash
refFromHexString :: 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 :: ByteString -> Ref hash
refFromHex s :: 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 _ -> RefInvalid -> Ref hash
forall a e. Exception e => e -> a
throw (RefInvalid -> Ref hash) -> RefInvalid -> Ref hash
forall a b. (a -> b) -> a -> b
$ ByteString -> RefInvalid
RefInvalid ByteString
s
Right h :: ByteString
h -> case ByteString -> Maybe (Digest hash)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString ByteString
h of
Nothing -> RefInvalid -> Ref hash
forall a e. Exception e => e -> a
throw (RefInvalid -> Ref hash) -> RefInvalid -> Ref hash
forall a b. (a -> b) -> a -> b
$ ByteString -> RefInvalid
RefInvalid ByteString
s
Just d :: Digest hash
d -> Digest hash -> Ref hash
forall hash. Digest hash -> Ref hash
Ref Digest hash
d
refToHexString :: Ref hash -> String
refToHexString :: Ref hash -> String
refToHexString (Ref d :: 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 bs :: 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