{-# 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

--------------------------------------------------------------------------------
-- Hacks
--------------------------------------------------------------------------------

type MonadInfallibleNixThunk m =
  ( CliLog m
  , HasCliConfig NixThunkError m
  , MonadIO m
  , MonadMask m
  )

type MonadNixThunk m =
  ( MonadInfallibleNixThunk m
  , CliThrow NixThunkError m
  , MonadFail m
  )

data NixThunkError
   = NixThunkError_ProcessFailure ProcessFailure
   | NixThunkError_Unstructured Text

prettyNixThunkError :: NixThunkError -> Text
prettyNixThunkError :: NixThunkError -> Text
prettyNixThunkError = \case
  NixThunkError_ProcessFailure (ProcessFailure 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

--------------------------------------------------------------------------------
-- End hacks
--------------------------------------------------------------------------------

--TODO: Support symlinked thunk data
data ThunkData
   = ThunkData_Packed ThunkSpec ThunkPtr
   -- ^ Packed thunk
   | ThunkData_Checkout
   -- ^ Checked out thunk that was unpacked from this pointer

-- | A reference to the exact data that a thunk should translate into
data ThunkPtr = ThunkPtr
  { ThunkPtr -> ThunkRev
_thunkPtr_rev :: ThunkRev
  , ThunkPtr -> ThunkSource
_thunkPtr_source :: ThunkSource
  }
  deriving (Int -> ThunkPtr -> ShowS
[ThunkPtr] -> ShowS
ThunkPtr -> String
(Int -> ThunkPtr -> ShowS)
-> (ThunkPtr -> String) -> ([ThunkPtr] -> ShowS) -> Show ThunkPtr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
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 --TODO: Use a smart constructor and make this actually verify itself

-- | A specific revision of data; it may be available from multiple sources
data ThunkRev = ThunkRev
  { ThunkRev -> Ref SHA1
_thunkRev_commit :: Ref SHA1
  , ThunkRev -> Text
_thunkRev_nixSha256 :: NixSha256
  }
  deriving (Int -> ThunkRev -> ShowS
[ThunkRev] -> ShowS
ThunkRev -> String
(Int -> ThunkRev -> ShowS)
-> (ThunkRev -> String) -> ([ThunkRev] -> ShowS) -> Show ThunkRev
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
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)

-- | A location from which a thunk's data can be retrieved
data ThunkSource
   -- | A source specialized for GitHub
   = ThunkSource_GitHub GitHubSource
   -- | A plain repo source
   | ThunkSource_Git GitSource
   deriving (Int -> ThunkSource -> ShowS
[ThunkSource] -> ShowS
ThunkSource -> String
(Int -> ThunkSource -> ShowS)
-> (ThunkSource -> String)
-> ([ThunkSource] -> ShowS)
-> Show ThunkSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
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

-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
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

-- TODO: Use spinner here.
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

--TODO: Pretty print these
data ReadThunkError
  = ReadThunkError_UnrecognizedThunk
  | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
  | ReadThunkError_MissingPaths (NonEmpty FilePath)
  | ReadThunkError_UnparseablePtr FilePath String
  | ReadThunkError_FileError IOError
  | ReadThunkError_FileDoesNotMatch FilePath Text
  | ReadThunkError_UnrecognizedState String
  | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
  deriving (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"

-- | A path from which our known-good nixpkgs can be fetched.
-- @print-nixpkgs-path@ is a shell script whose only purpose is to print
-- that path. It is generated and included in the build dependencies of
-- nix-thunk by our default.nix.
pinnedNixpkgsPath :: FilePath
pinnedNixpkgsPath :: String
pinnedNixpkgsPath =
  $(do
    p <- fmap init . runIO $ P.readCreateProcess (P.shell "print-nixpkgs-path") ""
    pure $ LitE $ StringL $ p
  )

-- | Specification for how a file in a thunk version works.
data ThunkFileSpec
  = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
  | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
  | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
  | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache

-- | Specification for how a set of files in a thunk version work.
data ThunkSpec = ThunkSpec
  { ThunkSpec -> Text
_thunkSpec_name :: !Text
  , ThunkSpec -> Map String ThunkFileSpec
_thunkSpec_files :: !(Map FilePath ThunkFileSpec)
  }

thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
thunkSpecTypes = NonEmpty ThunkSpec
gitThunkSpecs NonEmpty ThunkSpec
-> [NonEmpty ThunkSpec] -> NonEmpty (NonEmpty ThunkSpec)
forall a. a -> [a] -> NonEmpty a
:| [NonEmpty ThunkSpec
gitHubThunkSpecs]

-- | Attempts to match a 'ThunkSpec' to a given directory.
matchThunkSpecToDir
  :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
  => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
  -> FilePath -- ^ Path to directory
  -> Set FilePath -- ^ Set of file paths relative to the given directory
  -> m ThunkData
matchThunkSpecToDir :: 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 -- Handled above
        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 -- Interleave spec types so we try each one in a "fair" ordering
  ((([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}|]

-- | Read a packed or unpacked thunk based on predefined thunk specifications.
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
  -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
  String -> m (Either ReadThunkError ThunkData)
forall (m :: * -> *).
MonadNixThunk m =>
String -> m (Either ReadThunkError ThunkData)
readThunk String
target m (Either ReadThunkError ThunkData)
-> (Either ReadThunkError ThunkData -> m ()) -> m ()
forall (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 ()

  --TODO: Is there a safer way to do this overwriting?
  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

-- It's important that formatting be very consistent here, because
-- otherwise when people update thunks, their patches will be messy
encodeThunkPtrData :: ThunkPtr -> LBS.ByteString
encodeThunkPtrData :: ThunkPtr -> ByteString
encodeThunkPtrData (ThunkPtr 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 () -- We can't write the ptr without it
      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
    -- check to see if thunk should be updated to a specific branch or just update it's current branch
    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

-- | All recognized github standalone loaders, ordered from newest to oldest.
-- This tool will only ever produce the newest one when it writes a thunk.
gitHubThunkSpecs :: NonEmpty ThunkSpec
gitHubThunkSpecs :: NonEmpty ThunkSpec
gitHubThunkSpecs =
  ThunkSpec
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" --TODO: Add something about how to get more info on NixThunk, etc.
  , "import ((import <nixpkgs> {}).fetchFromGitHub ("
  , "  let json = builtins.fromJSON (builtins.readFile ./github.json);"
  , "  in { inherit (json) owner repo rev sha256;"
  , "       private = json.private or false;"
  , "     }"
  , "))"
  ]

gitHubThunkSpecV3 :: ThunkSpec
gitHubThunkSpecV3 :: 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
|]

-- | See 'gitHubThunkSpecV7'.
--
-- __NOTE__: v6 spec thunks are broken! They import the pinned nixpkgs
-- in an incorrect way. GitHub thunks for public repositories with no
-- submodules will still work, but update as soon as possible.
gitHubThunkSpecV6 :: ThunkSpec
gitHubThunkSpecV6 :: ThunkSpec
gitHubThunkSpecV6 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "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
|]

-- | Specification for GitHub thunks which use a specific, pinned
-- version of nixpkgs for fetching, rather than using @<nixpkgs>@ from
-- @NIX_PATH@. The "v7" specs ensure that thunks can be fetched even
-- when @NIX_PATH@ is unset.
gitHubThunkSpecV7 :: ThunkSpec
gitHubThunkSpecV7 :: ThunkSpec
gitHubThunkSpecV7 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "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)))"
  ]

-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
-- and will fail to find commits without this because it does shallow clones.
gitThunkSpecV3 :: ThunkSpec
gitThunkSpecV3 :: ThunkSpec
gitThunkSpecV3 = Text -> Text -> ThunkSpec
legacyGitThunkSpec "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
|]

-- | See 'gitThunkSpecV7'.
-- __NOTE__: v6 spec thunks are broken! They import the pinned nixpkgs
-- in an incorrect way. GitHub thunks for public repositories with no
-- submodules will still work, but update as soon as possible.
gitThunkSpecV6 :: ThunkSpec
gitThunkSpecV6 :: ThunkSpec
gitThunkSpecV6 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "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
|]

-- | Specification for Git thunks which use a specific, pinned version
-- of nixpkgs for fetching, rather than using @<nixpkgs>@ from
-- @NIX_PATH@. The "v7" specs ensure that thunks can be fetched even
-- when @NIX_PATH@ is unset.
gitThunkSpecV7 :: ThunkSpec
gitThunkSpecV7 :: ThunkSpec
gitThunkSpecV7 = Text
-> String
-> (ByteString -> Either String ThunkPtr)
-> Text
-> ThunkSpec
mkThunkSpec "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

-- | Checks a cache directory to see if there is a fresh symlink
-- to the result of building an attribute of a thunk.
-- If no cache hit is found, nix-build is called to build the attribute
-- and the result is symlinked into the cache.
nixBuildThunkAttrWithCache
  :: ( MonadIO m
     , MonadLog Output m
     , HasCliConfig NixThunkError m
     , MonadMask m
     , MonadError NixThunkError m
     , MonadFail m
     )
  => ThunkSpec
  -> FilePath
  -- ^ Path to directory containing Thunk
  -> String
  -- ^ Attribute to build
  -> m (Maybe FilePath)
  -- ^ Symlink to cached or built nix output
-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
-- the caching mechanism will fail as it merely measures the modification
-- time of the cache link and the expression to build.
nixBuildThunkAttrWithCache :: ThunkSpec -> 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 -- expected from a cache miss
          | 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
              }

-- | Build a nix attribute, and cache the result if possible
nixBuildAttrWithCache
  :: ( MonadLog Output m
     , HasCliConfig NixThunkError m
     , MonadIO m
     , MonadMask m
     , MonadError NixThunkError m
     , MonadFail m
     )
  => FilePath
  -- ^ Path to directory containing Thunk
  -> String
  -- ^ Attribute to build
  -> m FilePath
  -- ^ Symlink to cached or built nix output
nixBuildAttrWithCache :: 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
  -- Only packed thunks are cached. In particular, checkouts are not.
  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
        }

-- | Safely update thunk using a custom action
--
-- A temporary working space is used to do any update. When the custom
-- action successfully completes, the resulting (packed) thunk is copied
-- back to the original location.
updateThunk :: MonadNixThunk m => FilePath -> (FilePath -> m a) -> m a
updateThunk :: 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

-- | Check that we are not somewhere inside the thunk directory
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}|]

  -- Don't let thunk commands work when directly given an unpacked repo
  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}|]
  --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
  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
$ -- Only write meta data if the checkout is not inplace
          String -> Either ThunkSpec ThunkPtr -> m ()
forall (m :: * -> *).
MonadNixThunk m =>
String -> Either ThunkSpec ThunkPtr -> m ()
createThunk String
tmpThunk (Either ThunkSpec ThunkPtr -> m ())
-> Either ThunkSpec ThunkPtr -> m ()
forall a b. (a -> b) -> a -> b
$ ThunkSpec -> Either ThunkSpec ThunkPtr
forall a b. a -> Either a b
Left ThunkSpec
newSpec

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

gitCloneForThunkUnpack
  :: MonadNixThunk m
  => GitSource -- ^ Git source to use
  -> Ref hash -- ^ Commit hash to reset to
  -> FilePath -- ^ Directory to clone into
  -> m ()
gitCloneForThunkUnpack :: 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"]

--TODO: add a rollback mode to pack to the original thunk
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
  -- ^ Check that the repo is clean, including .gitignored files
  | CheckClean_NotIgnored
  -- ^ Check that the repo is clean, not including .gitignored files
  | CheckClean_NoCheck
  -- ^ Don't check that the repo is clean

getThunkPtr :: forall m. MonadNixThunk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
getThunkPtr :: 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"

  -- Check whether there are any stashes
  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

  -- Get current branch
  (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)

  -- Get information on all branches and their (optional) designated upstream
  -- correspondents
  [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)

  -- Check that every branch has a remote equivalent
  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."
      ]

    -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
    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))

    -- Those branches which have commits ahead of, i.e. not on, the upstream
    -- branch. Purely being behind is fine.
    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
    -- We assume it's safe to pack the thunk at this point
    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

-- | Get the latest revision available from the given source
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

-- | Convert a URI to a thunk
--
-- If the URL is a github URL, we try to just download an archive for
-- performance. If that doesn't work (e.g. authentication issue), we fall back
-- on just doing things the normal way for git repos in general, and save it as
-- a regular git thunk.
uriThunkPtr :: MonadNixThunk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
uriThunkPtr :: 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
    }

-- | N.B. Cannot infer all fields.
--
-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
-- should be employed, and so we respect that.
uriToThunkSource :: MonadNixThunk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
uriToThunkSource :: GitUri -> 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" ] -- "http:" just redirects to "https:"
        Bool -> Bool -> Bool
&& RText 'Host -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (Authority -> RText 'Host
URI.authHost Authority
uriAuth) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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 -- TODO: How do we determine if this should be true?
        , _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 -- Must be a public repo
      _ -> [GitUri] -> m Bool
loop [GitUri]
xs
  where
    urisToTry :: [GitUri]
urisToTry = [GitUri] -> [GitUri]
forall a. Ord a => [a] -> [a]
nubOrd ([GitUri] -> [GitUri]) -> [GitUri] -> [GitUri]
forall a b. (a -> b) -> a -> b
$
      -- Include the original URI if it isn't using SSH because SSH will certainly fail.
      [GitUri
uri | (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Maybe Text
forall (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
      }

-- Funny signature indicates no effects depend on the optional branch name.
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
    }

-- | Given the URI to a git remote, and an optional branch name, return the name
-- of the branch along with the hash of the commit at tip of that branch.
--
-- If the branch name is passed in, it is returned exactly as-is. If it is not
-- passed it, the default branch of the repo is used instead.

gitGetCommitBranch
  :: MonadNixThunk m => GitUri -> Maybe Text -> m (Text, CommitId)
gitGetCommitBranch :: 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
  -- This is what git does to check that the remote
  -- is not a local file path when parsing shorthand.
  -- Last referenced from here:
  -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
  let
    (authAndHostname :: 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
  -- Shorthand is valid iff a colon is present and it occurs before the first slash
  -- This check is used to disambiguate a filepath containing a colon from shorthand
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing ((Char -> Bool) -> Text -> Maybe Int
T.findIndex (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='/') Text
authAndHostname)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null Text
colonAndPath)
  Text -> Maybe URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI Text
properUri

-- The following code has been adapted from the 'Data.Git.Ref',
-- which is apparently no longer maintained

-- | Represent a git reference (SHA1)
newtype Ref hash = Ref { 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)

-- | Invalid Reference exception raised when
-- using something that is not a ref as a ref.
newtype RefInvalid = RefInvalid { RefInvalid -> ByteString
unRefInvalid :: ByteString }
  deriving (Int -> RefInvalid -> ShowS
[RefInvalid] -> ShowS
RefInvalid -> String
(Int -> RefInvalid -> ShowS)
-> (RefInvalid -> String)
-> ([RefInvalid] -> ShowS)
-> Show RefInvalid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
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

-- | transform a ref into an hexadecimal string
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