{-# language AllowAmbiguousTypes #-}
{-# language CPP #-}
{-# language DefaultSignatures #-}
{-# language TypeFamilies #-}
{-# language DataKinds #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language UndecidableInstances #-}
{-# language PackageImports #-}
{-# language TypeOperators #-}
{-# options_ghc -Wno-orphans #-}
module Nix.Effects where
import Nix.Prelude hiding ( putStrLn
, print
)
import qualified Nix.Prelude as Prelude
import GHC.Exception ( ErrorCall(ErrorCall) )
import qualified Data.HashSet as HS
import qualified Data.Text as Text
import Network.HTTP.Client hiding ( path, Proxy )
import Network.HTTP.Client.TLS
import Network.HTTP.Types
import qualified "cryptonite" Crypto.Hash as Hash
import Nix.Utils.Fix1
import Nix.Expr.Types.Annotated
import Nix.Frames hiding ( Proxy )
import Nix.Parser
import Nix.Render
import Nix.Value
import qualified Paths_hnix
import System.Exit
import qualified System.Info
import System.Process
import qualified System.Nix.Store.Remote as Store.Remote
import qualified System.Nix.StorePath as Store
import qualified System.Nix.Nar as Store.Nar
newtype StorePath = StorePath Path
class
( MonadFile m
, MonadStore m
, MonadPutStr m
, MonadHttp m
, MonadEnv m
, MonadPaths m
, MonadInstantiate m
, MonadExec m
, MonadIntrospect m
)
=> MonadEffects t f m where
toAbsolutePath :: Path -> m Path
findEnvPath :: String -> m Path
findPath :: [NValue t f m] -> Path -> m Path
importPath :: Path -> m (NValue t f m)
pathToDefaultNix :: Path -> m Path
derivationStrict :: NValue t f m -> m (NValue t f m)
traceEffect :: String -> m ()
instance
( MonadFix1T t m
, MonadStore m
)
=> MonadStore (Fix1T t m)
where
addToStore :: StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> Fix1T t m (Either ErrorCall StorePath)
addToStore StorePathName
a NarContent
b RecursiveFlag
c RecursiveFlag
d = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadStore m =>
StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore StorePathName
a NarContent
b RecursiveFlag
c RecursiveFlag
d
addTextToStore' :: StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> Fix1T t m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadStore m =>
StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d
class
Monad m
=> MonadIntrospect m
where
recursiveSize :: a -> m Word
default recursiveSize :: (MonadTrans t, MonadIntrospect m', m ~ t m') => a -> m Word
recursiveSize = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIntrospect m => a -> m Word
recursiveSize
instance MonadIntrospect IO where
recursiveSize :: forall a. a -> IO Word
recursiveSize =
#ifdef MIN_VERSION_ghc_datasize
recursiveSize
#else
forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0
#endif
deriving
instance
MonadIntrospect (t (Fix1 t))
=> MonadIntrospect (Fix1 t)
deriving
instance
MonadIntrospect (t (Fix1T t m) m)
=> MonadIntrospect (Fix1T t m)
class
Monad m
=> MonadExec m where
exec' :: [Text] -> m (Either ErrorCall NExprLoc)
default exec' :: (MonadTrans t, MonadExec m', m ~ t m')
=> [Text] -> m (Either ErrorCall NExprLoc)
exec' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadExec m =>
[StorePathName] -> m (Either ErrorCall NExprLoc)
exec'
instance MonadExec IO where
exec' :: [StorePathName] -> IO (Either ErrorCall NExprLoc)
exec' = \case
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall FilePath
"exec: missing program"
(StorePathName
prog : [StorePathName]
args) -> do
(ExitCode
exitCode, FilePath
out, FilePath
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode (forall a. ToString a => a -> FilePath
toString StorePathName
prog) (forall a. ToString a => a -> FilePath
toString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StorePathName]
args) forall a. Monoid a => a
mempty
let
t :: StorePathName
t = StorePathName -> StorePathName
Text.strip forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString FilePath
out
emsg :: StorePathName
emsg = StorePathName
"program[" forall a. Semigroup a => a -> a -> a
<> StorePathName
prog forall a. Semigroup a => a -> a -> a
<> StorePathName
"] args=" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show [StorePathName]
args
case ExitCode
exitCode of
ExitCode
ExitSuccess ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
if StorePathName -> RecursiveFlag
Text.null StorePathName
t
then forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ forall a. ToString a => a -> FilePath
toString forall a b. (a -> b) -> a -> b
$ StorePathName
"exec has no output :" forall a. Semigroup a => a -> a -> a
<> StorePathName
emsg
else
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\ Doc Void
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ forall a. ToString a => a -> FilePath
toString forall a b. (a -> b) -> a -> b
$ StorePathName
"Error parsing output of exec: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Doc Void
err forall a. Semigroup a => a -> a -> a
<> StorePathName
" " forall a. Semigroup a => a -> a -> a
<> StorePathName
emsg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(StorePathName -> Result NExprLoc
parseNixTextLoc StorePathName
t)
ExitCode
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ forall a. ToString a => a -> FilePath
toString forall a b. (a -> b) -> a -> b
$ StorePathName
"exec failed: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show ExitCode
err forall a. Semigroup a => a -> a -> a
<> StorePathName
" " forall a. Semigroup a => a -> a -> a
<> StorePathName
emsg
deriving
instance
MonadExec (t (Fix1 t))
=> MonadExec (Fix1 t)
deriving
instance
MonadExec (t (Fix1T t m) m)
=> MonadExec (Fix1T t m)
class
Monad m
=> MonadInstantiate m where
instantiateExpr :: Text -> m (Either ErrorCall NExprLoc)
default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => Text -> m (Either ErrorCall NExprLoc)
instantiateExpr = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadInstantiate m =>
StorePathName -> m (Either ErrorCall NExprLoc)
instantiateExpr
instance MonadInstantiate IO where
instantiateExpr :: StorePathName -> IO (Either ErrorCall NExprLoc)
instantiateExpr StorePathName
expr =
do
forall (m :: * -> *). Monad m => FilePath -> m ()
traceM forall a b. (a -> b) -> a -> b
$
FilePath
"Executing: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show [StorePathName
"nix-instantiate", StorePathName
"--eval", StorePathName
"--expr ", StorePathName
expr]
(ExitCode
exitCode, FilePath
out, FilePath
err) <-
FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode
FilePath
"nix-instantiate"
[FilePath
"--eval", FilePath
"--expr", forall a. ToString a => a -> FilePath
toString StorePathName
expr]
forall a. Monoid a => a
mempty
pure $
case ExitCode
exitCode of
ExitCode
ExitSuccess ->
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\ Doc Void
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ FilePath
"Error parsing output of nix-instantiate: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Doc Void
e)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(StorePathName -> Result NExprLoc
parseNixTextLoc forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString FilePath
out)
ExitCode
status -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ FilePath
"nix-instantiate failed: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show ExitCode
status forall a. Semigroup a => a -> a -> a
<> FilePath
": " forall a. Semigroup a => a -> a -> a
<> FilePath
err
deriving
instance
MonadInstantiate (t (Fix1 t))
=> MonadInstantiate (Fix1 t)
deriving
instance
MonadInstantiate (t (Fix1T t m) m)
=> MonadInstantiate (Fix1T t m)
class
Monad m
=> MonadEnv m where
getEnvVar :: Text -> m (Maybe Text)
default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => Text -> m (Maybe Text)
getEnvVar = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadEnv m =>
StorePathName -> m (Maybe StorePathName)
getEnvVar
getCurrentSystemOS :: m Text
default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
getCurrentSystemOS = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadEnv m => m StorePathName
getCurrentSystemOS
getCurrentSystemArch :: m Text
default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
getCurrentSystemArch = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadEnv m => m StorePathName
getCurrentSystemArch
instance MonadEnv IO where
getEnvVar :: StorePathName -> IO (Maybe StorePathName)
getEnvVar = forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
(<<$>>) forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> FilePath
toString
getCurrentSystemOS :: IO StorePathName
getCurrentSystemOS = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString FilePath
System.Info.os
getCurrentSystemArch :: IO StorePathName
getCurrentSystemArch = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ case FilePath
System.Info.arch of
FilePath
"i386" -> FilePath
"i686"
FilePath
arch -> FilePath
arch
deriving
instance
MonadEnv (t (Fix1 t))
=> MonadEnv (Fix1 t)
deriving
instance
MonadEnv (t (Fix1T t m) m)
=> MonadEnv (Fix1T t m)
class
Monad m
=> MonadPaths m where
getDataDir :: m Path
default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m Path
getDataDir = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). MonadPaths m => m Path
getDataDir
instance MonadPaths IO where
getDataDir :: IO Path
getDataDir = coerce :: forall a b. Coercible a b => a -> b
coerce IO FilePath
Paths_hnix.getDataDir
deriving
instance
MonadPaths (t (Fix1 t))
=> MonadPaths (Fix1 t)
deriving
instance
MonadPaths (t (Fix1T t m) m)
=> MonadPaths (Fix1T t m)
class
Monad m
=> MonadHttp m where
getURL :: Text -> m (Either ErrorCall StorePath)
default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath)
getURL = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadHttp m =>
StorePathName -> m (Either ErrorCall StorePath)
getURL
baseNameOf :: Text -> Text
baseNameOf :: StorePathName -> StorePathName
baseNameOf StorePathName
a = (Char -> RecursiveFlag) -> StorePathName -> StorePathName
Text.takeWhileEnd (forall a. Eq a => a -> a -> RecursiveFlag
/=Char
'/') forall a b. (a -> b) -> a -> b
$ (Char -> RecursiveFlag) -> StorePathName -> StorePathName
Text.dropWhileEnd (forall a. Eq a => a -> a -> RecursiveFlag
==Char
'/') StorePathName
a
toStorePath :: Store.StorePath -> StorePath
toStorePath :: StorePath -> StorePath
toStorePath = Path -> StorePath
StorePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 @FilePath @ByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> ByteString
Store.storePathToRawFilePath
instance MonadHttp IO where
getURL :: StorePathName -> IO (Either ErrorCall StorePath)
getURL StorePathName
url =
do
let urlstr :: FilePath
urlstr = forall a. ToString a => a -> FilePath
toString StorePathName
url
forall (m :: * -> *). Monad m => FilePath -> m ()
traceM forall a b. (a -> b) -> a -> b
$ FilePath
"fetching HTTP URL: " forall a. Semigroup a => a -> a -> a
<> FilePath
urlstr
Request
req <- forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest FilePath
urlstr
Manager
manager <-
forall a. a -> a -> RecursiveFlag -> a
bool
(ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings)
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
(Request -> RecursiveFlag
secure Request
req)
Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs (Request
req { method :: ByteString
method = ByteString
"GET" }) Manager
manager
let status :: Int
status = Status -> Int
statusCode forall a b. (a -> b) -> a -> b
$ forall body. Response body -> Status
responseStatus Response ByteString
response
let body :: ByteString
body = forall body. Response body -> body
responseBody Response ByteString
response
let name :: StorePathName
name = StorePathName -> StorePathName
baseNameOf StorePathName
url
forall a. a -> a -> RecursiveFlag -> a
bool
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ FilePath
"fail, got " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Int
status forall a. Semigroup a => a -> a -> a
<> FilePath
" when fetching url = " forall a. Semigroup a => a -> a -> a
<> FilePath
urlstr)
(forall (m :: * -> *).
MonadStore m =>
StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore StorePathName
name (ByteString -> NarContent
NarText forall a b. (a -> b) -> a -> b
$ forall l s. LazyStrict l s => l -> s
toStrict ByteString
body) RecursiveFlag
False RecursiveFlag
False)
(Int
status forall a. Eq a => a -> a -> RecursiveFlag
== Int
200)
deriving
instance
MonadHttp (t (Fix1 t))
=> MonadHttp (Fix1 t)
deriving
instance
MonadHttp (t (Fix1T t m) m)
=> MonadHttp (Fix1T t m)
class
(Monad m, MonadIO m)
=> MonadPutStr m where
putStr :: String -> m ()
default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m ()
putStr = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => FilePath -> m ()
Prelude.putStr
instance MonadPutStr IO where
putStr :: FilePath -> IO ()
putStr = forall (m :: * -> *). MonadIO m => FilePath -> m ()
Prelude.putStr
deriving
instance
MonadPutStr (t (Fix1 t))
=> MonadPutStr (Fix1 t)
deriving
instance
MonadPutStr (t (Fix1T t m) m)
=> MonadPutStr (Fix1T t m)
putStrLn :: MonadPutStr m => String -> m ()
putStrLn :: forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
putStrLn = forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
Nix.Effects.putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> FilePath
"\n")
print :: (MonadPutStr m, Show a) => a -> m ()
print :: forall (m :: * -> *) a. (MonadPutStr m, Show a) => a -> m ()
print = forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show
type RecursiveFlag = Bool
type RepairFlag = Bool
type StorePathName = Text
type PathFilter m = Path -> m Bool
type StorePathSet = HS.HashSet StorePath
data NarContent = NarFile Path | NarText ByteString
toNarSource :: MonadIO m => NarContent -> Store.Nar.NarSource m
toNarSource :: forall (m :: * -> *). MonadIO m => NarContent -> NarSource m
toNarSource (NarFile Path
path) = forall (m :: * -> *). MonadIO m => FilePath -> NarSource m
Store.Nar.dumpPath forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Path
path
toNarSource (NarText ByteString
text) = forall (m :: * -> *). MonadIO m => ByteString -> NarSource m
Store.Nar.dumpString ByteString
text
class
Monad m
=> MonadStore m where
addToStore :: StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> NarContent -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
addToStore StorePathName
a NarContent
b RecursiveFlag
c RecursiveFlag
d = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadStore m =>
StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore StorePathName
a NarContent
b RecursiveFlag
c RecursiveFlag
d
addTextToStore' :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
default addTextToStore' :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadStore m =>
StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d
instance MonadStore IO where
addToStore :: StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> IO (Either ErrorCall StorePath)
addToStore StorePathName
name NarContent
content RecursiveFlag
recursive RecursiveFlag
repair =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\ FilePath
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ FilePath
"String '" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show StorePathName
name forall a. Semigroup a => a -> a -> a
<> FilePath
"' is not a valid path name: " forall a. Semigroup a => a -> a -> a
<> FilePath
err)
(\ StorePathName
pathName ->
do
(Either FilePath StorePath, [Logger])
res <- forall a. MonadStore a -> IO (Either FilePath a, [Logger])
Store.Remote.runStore forall a b. (a -> b) -> a -> b
$ forall a.
NamedAlgo a =>
StorePathName
-> NarSource MonadStore
-> RecursiveFlag
-> RecursiveFlag
-> MonadStore StorePath
Store.Remote.addToStore @Hash.SHA256 StorePathName
pathName (forall (m :: * -> *). MonadIO m => NarContent -> NarSource m
toNarSource NarContent
content) RecursiveFlag
recursive RecursiveFlag
repair
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
forall a b. a -> Either a b
Left
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> StorePath
toStorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Monad m =>
StorePathName
-> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult StorePathName
"addToStore" (Either FilePath StorePath, [Logger])
res
)
(StorePathName -> Either FilePath StorePathName
Store.makeStorePathName StorePathName
name)
addTextToStore' :: StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> IO (Either ErrorCall StorePath)
addTextToStore' StorePathName
name StorePathName
text StorePathSet
references RecursiveFlag
repair =
do
(Either FilePath StorePath, [Logger])
res <- forall a. MonadStore a -> IO (Either FilePath a, [Logger])
Store.Remote.runStore forall a b. (a -> b) -> a -> b
$ StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> MonadStore StorePath
Store.Remote.addTextToStore StorePathName
name StorePathName
text StorePathSet
references RecursiveFlag
repair
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
forall a b. a -> Either a b
Left
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> StorePath
toStorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Monad m =>
StorePathName
-> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult StorePathName
"addTextToStore" (Either FilePath StorePath, [Logger])
res
parseStoreResult :: Monad m => Text -> (Either String a, [Store.Remote.Logger]) -> m (Either ErrorCall a)
parseStoreResult :: forall (m :: * -> *) a.
Monad m =>
StorePathName
-> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult StorePathName
name (Either FilePath a
res, [Logger]
logs) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\ FilePath
msg -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to execute '" forall a. Semigroup a => a -> a -> a
<> forall a. ToString a => a -> FilePath
toString StorePathName
name forall a. Semigroup a => a -> a -> a
<> FilePath
"': " forall a. Semigroup a => a -> a -> a
<> FilePath
msg forall a. Semigroup a => a -> a -> a
<> FilePath
"\n" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show [Logger]
logs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Either FilePath a
res
addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
addTextToStore :: forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
StorePathName
-> StorePathName -> StorePathSet -> RecursiveFlag -> m StorePath
addTextToStore StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError
forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadStore m =>
StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addTextToStore' StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d
addPath :: (Framed e m, MonadStore m) => Path -> m StorePath
addPath :: forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Path -> m StorePath
addPath Path
p =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError
forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadStore m =>
StorePathName
-> NarContent
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Path -> Path
takeFileName Path
p) (Path -> NarContent
NarFile Path
p) RecursiveFlag
True RecursiveFlag
False
toFile_ :: (Framed e m, MonadStore m) => Path -> Text -> m StorePath
toFile_ :: forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Path -> StorePathName -> m StorePath
toFile_ Path
p StorePathName
contents = forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
StorePathName
-> StorePathName -> StorePathSet -> RecursiveFlag -> m StorePath
addTextToStore (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Path
p) StorePathName
contents forall a. Monoid a => a
mempty RecursiveFlag
False