{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, ApplicativeDo #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Foreign.Nix.Shellout.Prefetch
(
url, UrlOptions(..), defaultUrlOptions
, git, GitOptions(..), defaultGitOptions, GitOutput(..)
, PrefetchError(..)
, Url(..), Sha256(..)
, runNixAction, NixAction(..), NixActionError(..)
) where
import Control.Error hiding (bool, err)
import qualified Data.Text as T
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as AesonT
import Foreign.Nix.Shellout.Types
import qualified Foreign.Nix.Shellout.Helpers as Helpers
import Data.Text (Text)
import Data.String (IsString)
import GHC.IO.Exception (ExitCode(ExitFailure, ExitSuccess))
import qualified Data.Text as Text
import Data.Bool (bool)
import Data.Bifunctor (first)
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Encoding as Text.Lazy.Encoding
import qualified Data.List as List
data PrefetchError
= PrefetchOutputMalformed Text
| ExpectedHashError
| UnknownPrefetchError
deriving (PrefetchError -> PrefetchError -> Bool
(PrefetchError -> PrefetchError -> Bool)
-> (PrefetchError -> PrefetchError -> Bool) -> Eq PrefetchError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrefetchError -> PrefetchError -> Bool
$c/= :: PrefetchError -> PrefetchError -> Bool
== :: PrefetchError -> PrefetchError -> Bool
$c== :: PrefetchError -> PrefetchError -> Bool
Eq, Int -> PrefetchError -> ShowS
[PrefetchError] -> ShowS
PrefetchError -> String
(Int -> PrefetchError -> ShowS)
-> (PrefetchError -> String)
-> ([PrefetchError] -> ShowS)
-> Show PrefetchError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrefetchError] -> ShowS
$cshowList :: [PrefetchError] -> ShowS
show :: PrefetchError -> String
$cshow :: PrefetchError -> String
showsPrec :: Int -> PrefetchError -> ShowS
$cshowsPrec :: Int -> PrefetchError -> ShowS
Show)
newtype Url = Url { Url -> Text
unUrl :: Text } deriving (Int -> Url -> ShowS
[Url] -> ShowS
Url -> String
(Int -> Url -> ShowS)
-> (Url -> String) -> ([Url] -> ShowS) -> Show Url
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Url] -> ShowS
$cshowList :: [Url] -> ShowS
show :: Url -> String
$cshow :: Url -> String
showsPrec :: Int -> Url -> ShowS
$cshowsPrec :: Int -> Url -> ShowS
Show, Url -> Url -> Bool
(Url -> Url -> Bool) -> (Url -> Url -> Bool) -> Eq Url
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Url -> Url -> Bool
$c/= :: Url -> Url -> Bool
== :: Url -> Url -> Bool
$c== :: Url -> Url -> Bool
Eq, String -> Url
(String -> Url) -> IsString Url
forall a. (String -> a) -> IsString a
fromString :: String -> Url
$cfromString :: String -> Url
IsString)
newtype Sha256 = Sha256 { Sha256 -> Text
unSha256 :: Text } deriving (Int -> Sha256 -> ShowS
[Sha256] -> ShowS
Sha256 -> String
(Int -> Sha256 -> ShowS)
-> (Sha256 -> String) -> ([Sha256] -> ShowS) -> Show Sha256
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sha256] -> ShowS
$cshowList :: [Sha256] -> ShowS
show :: Sha256 -> String
$cshow :: Sha256 -> String
showsPrec :: Int -> Sha256 -> ShowS
$cshowsPrec :: Int -> Sha256 -> ShowS
Show, Sha256 -> Sha256 -> Bool
(Sha256 -> Sha256 -> Bool)
-> (Sha256 -> Sha256 -> Bool) -> Eq Sha256
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sha256 -> Sha256 -> Bool
$c/= :: Sha256 -> Sha256 -> Bool
== :: Sha256 -> Sha256 -> Bool
$c== :: Sha256 -> Sha256 -> Bool
Eq, String -> Sha256
(String -> Sha256) -> IsString Sha256
forall a. (String -> a) -> IsString a
fromString :: String -> Sha256
$cfromString :: String -> Sha256
IsString)
data UrlOptions = UrlOptions
{ UrlOptions -> Url
urlUrl :: Url
, UrlOptions -> Bool
urlUnpack :: Bool
, UrlOptions -> Maybe Text
urlName :: Maybe Text
, UrlOptions -> Maybe Sha256
urlExpectedHash :: Maybe Sha256
}
defaultUrlOptions :: Url -> UrlOptions
defaultUrlOptions :: Url -> UrlOptions
defaultUrlOptions Url
u = UrlOptions :: Url -> Bool -> Maybe Text -> Maybe Sha256 -> UrlOptions
UrlOptions
{ urlUrl :: Url
urlUrl = Url
u
, urlUnpack :: Bool
urlUnpack = Bool
False
, urlName :: Maybe Text
urlName = Maybe Text
forall a. Maybe a
Nothing
, urlExpectedHash :: Maybe Sha256
urlExpectedHash = Maybe Sha256
forall a. Maybe a
Nothing }
url :: UrlOptions -> NixAction PrefetchError (Sha256, StorePath Realized)
url :: UrlOptions -> NixAction PrefetchError (Sha256, StorePath Realized)
url UrlOptions{Bool
Maybe Text
Maybe Sha256
Url
urlExpectedHash :: Maybe Sha256
urlName :: Maybe Text
urlUnpack :: Bool
urlUrl :: Url
urlExpectedHash :: UrlOptions -> Maybe Sha256
urlName :: UrlOptions -> Maybe Text
urlUnpack :: UrlOptions -> Bool
urlUrl :: UrlOptions -> Url
..} = ((Text, Text)
-> ExitCode
-> ExceptT PrefetchError IO (Sha256, StorePath Realized))
-> Text
-> [Text]
-> NixAction PrefetchError (Sha256, StorePath Realized)
forall e a.
((Text, Text) -> ExitCode -> ExceptT e IO a)
-> Text -> [Text] -> NixAction e a
Helpers.readProcess (Text, Text)
-> ExitCode
-> ExceptT PrefetchError IO (Sha256, StorePath Realized)
forall (m :: * -> *) a.
Monad m =>
(Text, Text)
-> ExitCode -> ExceptT PrefetchError m (Sha256, StorePath a)
handler Text
exec [Text]
args
where
exec :: Text
exec = Text
"nix-prefetch-url"
args :: [Text]
args = if Bool
urlUnpack then [Text
"--unpack"] else []
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
n -> [Text
"--name", Text
n]) Maybe Text
urlName
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"--type", Text
"sha256"
, Text
"--print-path"
, Url -> Text
unUrl Url
urlUrl ]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> (Sha256 -> [Text]) -> Maybe Sha256 -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure(Text -> [Text]) -> (Sha256 -> Text) -> Sha256 -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Sha256 -> Text
unSha256) Maybe Sha256
urlExpectedHash
handler :: (Text, Text)
-> ExitCode -> ExceptT PrefetchError m (Sha256, StorePath a)
handler (Text
out, Text
err) = \case
ExitCode
ExitSuccess -> (Text -> PrefetchError)
-> ExceptT Text m (Sha256, StorePath a)
-> ExceptT PrefetchError m (Sha256, StorePath a)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Text -> PrefetchError
PrefetchOutputMalformed (ExceptT Text m (Sha256, StorePath a)
-> ExceptT PrefetchError m (Sha256, StorePath a))
-> ExceptT Text m (Sha256, StorePath a)
-> ExceptT PrefetchError m (Sha256, StorePath a)
forall a b. (a -> b) -> a -> b
$ do
let ls :: [Text]
ls = Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.stripEnd Text
out
Text
path <- Text -> [Text] -> ExceptT Text m Text
forall (m :: * -> *) e a. Monad m => e -> [a] -> ExceptT e m a
tryLast (Text
exec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" didn’t output a store path") [Text]
ls
Text
sha <- let errS :: Text
errS = (Text
exec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" didn’t output a hash")
in Text -> [Text] -> ExceptT Text m [Text]
forall (m :: * -> *) e a. Monad m => e -> [a] -> ExceptT e m [a]
tryInit Text
errS [Text]
ls ExceptT Text m [Text]
-> ([Text] -> ExceptT Text m Text) -> ExceptT Text m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> [Text] -> ExceptT Text m Text
forall (m :: * -> *) e a. Monad m => e -> [a] -> ExceptT e m a
tryLast Text
errS
pure (Text -> Sha256
Sha256 Text
sha, String -> StorePath a
forall a. String -> StorePath a
StorePath (String -> StorePath a) -> String -> StorePath a
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
path)
ExitFailure Int
_ -> PrefetchError -> ExceptT PrefetchError m (Sha256, StorePath a)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (PrefetchError -> ExceptT PrefetchError m (Sha256, StorePath a))
-> PrefetchError -> ExceptT PrefetchError m (Sha256, StorePath a)
forall a b. (a -> b) -> a -> b
$
if Text
"error: hash mismatch" Text -> Text -> Bool
`T.isPrefixOf` Text
err
then PrefetchError
ExpectedHashError
else PrefetchError
UnknownPrefetchError
data GitOptions = GitOptions
{ GitOptions -> Url
gitUrl :: Url
, GitOptions -> Maybe Text
gitRev :: Maybe Text
, GitOptions -> Maybe Sha256
gitExpectedHash :: Maybe Sha256
, GitOptions -> Bool
gitDeepClone :: Bool
, GitOptions -> Bool
gitLeaveDotGit :: Bool
, GitOptions -> Bool
gitFetchSubmodules :: Bool
}
defaultGitOptions :: Url -> GitOptions
defaultGitOptions :: Url -> GitOptions
defaultGitOptions Url
u = GitOptions :: Url
-> Maybe Text -> Maybe Sha256 -> Bool -> Bool -> Bool -> GitOptions
GitOptions
{ gitUrl :: Url
gitUrl = Url
u
, gitRev :: Maybe Text
gitRev = Maybe Text
forall a. Maybe a
Nothing
, gitExpectedHash :: Maybe Sha256
gitExpectedHash = Maybe Sha256
forall a. Maybe a
Nothing
, gitDeepClone :: Bool
gitDeepClone = Bool
False
, gitLeaveDotGit :: Bool
gitLeaveDotGit = Bool
False
, gitFetchSubmodules :: Bool
gitFetchSubmodules = Bool
True }
data GitOutput = GitOutput
{ GitOutput -> Text
gitOutputRev :: Text
, GitOutput -> Sha256
gitOutputSha256 :: Sha256
, GitOutput -> StorePath Realized
gitOuputPath :: StorePath Realized
} deriving (Int -> GitOutput -> ShowS
[GitOutput] -> ShowS
GitOutput -> String
(Int -> GitOutput -> ShowS)
-> (GitOutput -> String)
-> ([GitOutput] -> ShowS)
-> Show GitOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitOutput] -> ShowS
$cshowList :: [GitOutput] -> ShowS
show :: GitOutput -> String
$cshow :: GitOutput -> String
showsPrec :: Int -> GitOutput -> ShowS
$cshowsPrec :: Int -> GitOutput -> ShowS
Show, GitOutput -> GitOutput -> Bool
(GitOutput -> GitOutput -> Bool)
-> (GitOutput -> GitOutput -> Bool) -> Eq GitOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitOutput -> GitOutput -> Bool
$c/= :: GitOutput -> GitOutput -> Bool
== :: GitOutput -> GitOutput -> Bool
$c== :: GitOutput -> GitOutput -> Bool
Eq)
git :: GitOptions -> NixAction PrefetchError GitOutput
git :: GitOptions -> NixAction PrefetchError GitOutput
git GitOptions{Bool
Maybe Text
Maybe Sha256
Url
gitFetchSubmodules :: Bool
gitLeaveDotGit :: Bool
gitDeepClone :: Bool
gitExpectedHash :: Maybe Sha256
gitRev :: Maybe Text
gitUrl :: Url
gitFetchSubmodules :: GitOptions -> Bool
gitLeaveDotGit :: GitOptions -> Bool
gitDeepClone :: GitOptions -> Bool
gitExpectedHash :: GitOptions -> Maybe Sha256
gitRev :: GitOptions -> Maybe Text
gitUrl :: GitOptions -> Url
..} = ((Text, Text) -> ExitCode -> ExceptT PrefetchError IO GitOutput)
-> Text -> [Text] -> NixAction PrefetchError GitOutput
forall e a.
((Text, Text) -> ExitCode -> ExceptT e IO a)
-> Text -> [Text] -> NixAction e a
Helpers.readProcess (Text, Text) -> ExitCode -> ExceptT PrefetchError IO GitOutput
forall (m :: * -> *).
Monad m =>
(Text, Text) -> ExitCode -> ExceptT PrefetchError m GitOutput
handler Text
exec [Text]
args
where
exec :: Text
exec = Text
"nix-prefetch-git"
args :: [Text]
args = [Text] -> [Text] -> Bool -> [Text]
forall a. a -> a -> Bool -> a
bool [Text
"--no-deepClone"] [Text
"--deepClone"] Bool
gitDeepClone
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> [Text] -> Bool -> [Text]
forall a. a -> a -> Bool -> a
bool [] [Text
"--leave-dotGit"] Bool
gitLeaveDotGit
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> [Text] -> Bool -> [Text]
forall a. a -> a -> Bool -> a
bool [] [Text
"--fetch-submodules"] Bool
gitFetchSubmodules
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"--hash", Text
"sha256"
, Url -> Text
unUrl Url
gitUrl
, Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
gitRev ]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> (Sha256 -> [Text]) -> Maybe Sha256 -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(Sha256 Text
h) -> [Text
h]) Maybe Sha256
gitExpectedHash
handler :: (Text, Text) -> ExitCode -> ExceptT PrefetchError m GitOutput
handler (Text
out, Text
err) = \case
ExitCode
ExitSuccess -> (Text -> PrefetchError)
-> ExceptT Text m GitOutput -> ExceptT PrefetchError m GitOutput
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Text -> PrefetchError
PrefetchOutputMalformed (ExceptT Text m GitOutput -> ExceptT PrefetchError m GitOutput)
-> ExceptT Text m GitOutput -> ExceptT PrefetchError m GitOutput
forall a b. (a -> b) -> a -> b
$ do
let error' :: Text -> Text
error' Text
msg = Text
exec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
jsonError :: [Char] -> Text
jsonError :: String -> Text
jsonError = \String
msg -> Text -> Text
error' (Text -> [Text] -> Text
T.intercalate Text
"\n"
[ Text
"parsing json output failed:"
, String -> Text
Text.pack String
msg
, Text
"The output was:"
, Text
out ])
(Text
gitOutputRev, Sha256
gitOutputSha256)
<- m (Either Text (Text, Sha256)) -> ExceptT Text m (Text, Sha256)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either Text (Text, Sha256)) -> ExceptT Text m (Text, Sha256))
-> (Either String (Text, Sha256) -> m (Either Text (Text, Sha256)))
-> Either String (Text, Sha256)
-> ExceptT Text m (Text, Sha256)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (Text, Sha256) -> m (Either Text (Text, Sha256))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (Text, Sha256) -> m (Either Text (Text, Sha256)))
-> (Either String (Text, Sha256) -> Either Text (Text, Sha256))
-> Either String (Text, Sha256)
-> m (Either Text (Text, Sha256))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text)
-> Either String (Text, Sha256) -> Either Text (Text, Sha256)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
jsonError (Either String (Text, Sha256) -> ExceptT Text m (Text, Sha256))
-> Either String (Text, Sha256) -> ExceptT Text m (Text, Sha256)
forall a b. (a -> b) -> a -> b
$ do
Value
val <- ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' (Text -> ByteString
Text.Lazy.Encoding.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.Lazy.fromStrict Text
out)
((Value -> Parser (Text, Sha256))
-> Value -> Either String (Text, Sha256))
-> Value
-> (Value -> Parser (Text, Sha256))
-> Either String (Text, Sha256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Value -> Parser (Text, Sha256))
-> Value -> Either String (Text, Sha256)
forall a b. (a -> Parser b) -> a -> Either String b
AesonT.parseEither Value
val
((Value -> Parser (Text, Sha256)) -> Either String (Text, Sha256))
-> (Value -> Parser (Text, Sha256)) -> Either String (Text, Sha256)
forall a b. (a -> b) -> a -> b
$ String
-> (Object -> Parser (Text, Sha256))
-> Value
-> Parser (Text, Sha256)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"GitPrefetchOutput" ((Object -> Parser (Text, Sha256))
-> Value -> Parser (Text, Sha256))
-> (Object -> Parser (Text, Sha256))
-> Value
-> Parser (Text, Sha256)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
(,) (Text -> Sha256 -> (Text, Sha256))
-> Parser Text -> Parser (Sha256 -> (Text, Sha256))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"rev"
Parser (Sha256 -> (Text, Sha256))
-> Parser Sha256 -> Parser (Text, Sha256)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Sha256) -> Parser Text -> Parser Sha256
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Sha256
Sha256 (Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"sha256")
StorePath Realized
gitOuputPath <- case
(Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Text
"path is /nix/store" Text -> Text -> Bool
`T.isPrefixOf`) (Text -> [Text]
T.lines Text
err)
Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Maybe Text
T.stripPrefix Text
"path is " of
Maybe Text
Nothing -> Text -> ExceptT Text m (StorePath Realized)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
(Text -> ExceptT Text m (StorePath Realized))
-> Text -> ExceptT Text m (StorePath Realized)
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. HasCallStack => String -> a
error String
"could not find nix store output path on stderr"
Just Text
path -> StorePath Realized -> ExceptT Text m (StorePath Realized)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePath Realized -> ExceptT Text m (StorePath Realized))
-> StorePath Realized -> ExceptT Text m (StorePath Realized)
forall a b. (a -> b) -> a -> b
$ String -> StorePath Realized
forall a. String -> StorePath a
StorePath (String -> StorePath Realized) -> String -> StorePath Realized
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
path
pure GitOutput :: Text -> Sha256 -> StorePath Realized -> GitOutput
GitOutput{Text
StorePath Realized
Sha256
gitOuputPath :: StorePath Realized
gitOutputSha256 :: Sha256
gitOutputRev :: Text
gitOuputPath :: StorePath Realized
gitOutputSha256 :: Sha256
gitOutputRev :: Text
..}
ExitFailure Int
_ -> PrefetchError -> ExceptT PrefetchError m GitOutput
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (PrefetchError -> ExceptT PrefetchError m GitOutput)
-> PrefetchError -> ExceptT PrefetchError m GitOutput
forall a b. (a -> b) -> a -> b
$
if (Text
"hash mismatch for URL" Text -> Text -> Bool
`T.isInfixOf` Text
err)
then PrefetchError
ExpectedHashError
else PrefetchError
UnknownPrefetchError