{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Nix.Effects where
import Prelude hiding ( traceM
, putStr
, putStrLn
, print
)
import qualified Prelude
import Nix.Utils
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
import Nix.Frames hiding ( Proxy )
import Nix.Parser
import Nix.Render
import Nix.Value
import qualified Paths_hnix
import System.Exit
import qualified System.Environment as Env
import System.FilePath ( takeFileName )
import qualified System.Info
import System.Process
import qualified System.Nix.Store.Remote as Store.Remote
import qualified System.Nix.StorePath as Store
newtype StorePath = StorePath { StorePath -> FilePath
unStorePath :: FilePath }
class
( MonadFile m
, MonadStore m
, MonadPutStr m
, MonadHttp m
, MonadEnv m
, MonadPaths m
, MonadInstantiate m
, MonadExec m
, MonadIntrospect m
)
=> MonadEffects t f m where
makeAbsolutePath :: FilePath -> m FilePath
findEnvPath :: String -> m FilePath
findPath :: [NValue t f m] -> FilePath -> m FilePath
importPath :: FilePath -> m (NValue t f m)
pathToDefaultNix :: FilePath -> m FilePath
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
-> FilePath
-> RecursiveFlag
-> RecursiveFlag
-> Fix1T t m (Either ErrorCall StorePath)
addToStore StorePathName
a FilePath
b RecursiveFlag
c RecursiveFlag
d = m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath))
-> m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePathName
-> FilePath
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> FilePath
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore StorePathName
a FilePath
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 = m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath))
-> m (Either ErrorCall StorePath)
-> Fix1T t m (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
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 = m' Word -> t m' Word
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' Word -> t m' Word) -> (a -> m' Word) -> a -> t m' Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m' Word
forall (m :: * -> *) a. MonadIntrospect m => a -> m Word
recursiveSize
instance MonadIntrospect IO where
recursiveSize :: a -> IO Word
recursiveSize =
#ifdef MIN_VERSION_ghc_datasize
recursiveSize
#else
\a
_ -> Word -> IO Word
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' = m' (Either ErrorCall NExprLoc) -> t m' (Either ErrorCall NExprLoc)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall NExprLoc)
-> t m' (Either ErrorCall NExprLoc))
-> ([StorePathName] -> m' (Either ErrorCall NExprLoc))
-> [StorePathName]
-> t m' (Either ErrorCall NExprLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StorePathName] -> m' (Either ErrorCall NExprLoc)
forall (m :: * -> *).
MonadExec m =>
[StorePathName] -> m (Either ErrorCall NExprLoc)
exec'
instance MonadExec IO where
exec' :: [StorePathName] -> IO (Either ErrorCall NExprLoc)
exec' = \case
[] -> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc))
-> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a b. (a -> b) -> a -> b
$ ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall FilePath
"exec: missing program"
(StorePathName
prog : [StorePathName]
args) -> do
(ExitCode
exitCode, FilePath
out, FilePath
_) <- IO (ExitCode, FilePath, FilePath)
-> IO (ExitCode, FilePath, FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, FilePath, FilePath)
-> IO (ExitCode, FilePath, FilePath))
-> IO (ExitCode, FilePath, FilePath)
-> IO (ExitCode, FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode (StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString StorePathName
prog) (StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString (StorePathName -> FilePath) -> [StorePathName] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StorePathName]
args) FilePath
""
let
t :: StorePathName
t = StorePathName -> StorePathName
Text.strip (StorePathName -> StorePathName) -> StorePathName -> StorePathName
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePathName
forall a. ToText a => a -> StorePathName
toText FilePath
out
emsg :: StorePathName
emsg = StorePathName
"program[" StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
prog StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
"] args=" StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> [StorePathName] -> StorePathName
forall b a. (Show a, IsString b) => a -> b
show [StorePathName]
args
case ExitCode
exitCode of
ExitCode
ExitSuccess ->
Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc))
-> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a b. (a -> b) -> a -> b
$
if StorePathName -> RecursiveFlag
Text.null StorePathName
t
then ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString (StorePathName -> FilePath) -> StorePathName -> FilePath
forall a b. (a -> b) -> a -> b
$ StorePathName
"exec has no output :" StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
emsg
else
(Doc Void -> Either ErrorCall NExprLoc)
-> (NExprLoc -> Either ErrorCall NExprLoc)
-> Either (Doc Void) NExprLoc
-> Either ErrorCall NExprLoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\ Doc Void
err -> ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString (StorePathName -> FilePath) -> StorePathName -> FilePath
forall a b. (a -> b) -> a -> b
$ StorePathName
"Error parsing output of exec: " StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> Doc Void -> StorePathName
forall b a. (Show a, IsString b) => a -> b
show Doc Void
err StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
" " StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
emsg)
NExprLoc -> Either ErrorCall NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(StorePathName -> Either (Doc Void) NExprLoc
parseNixTextLoc StorePathName
t)
ExitCode
err -> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc))
-> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall a b. (a -> b) -> a -> b
$ ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString (StorePathName -> FilePath) -> StorePathName -> FilePath
forall a b. (a -> b) -> a -> b
$ StorePathName
"exec failed: " StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> ExitCode -> StorePathName
forall b a. (Show a, IsString b) => a -> b
show ExitCode
err StorePathName -> StorePathName -> StorePathName
forall a. Semigroup a => a -> a -> a
<> StorePathName
" " StorePathName -> StorePathName -> 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 = m' (Either ErrorCall NExprLoc) -> t m' (Either ErrorCall NExprLoc)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall NExprLoc)
-> t m' (Either ErrorCall NExprLoc))
-> (StorePathName -> m' (Either ErrorCall NExprLoc))
-> StorePathName
-> t m' (Either ErrorCall NExprLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePathName -> m' (Either ErrorCall NExprLoc)
forall (m :: * -> *).
MonadInstantiate m =>
StorePathName -> m (Either ErrorCall NExprLoc)
instantiateExpr
instance MonadInstantiate IO where
instantiateExpr :: StorePathName -> IO (Either ErrorCall NExprLoc)
instantiateExpr StorePathName
expr =
do
FilePath -> IO ()
forall (m :: * -> *). Monad m => FilePath -> m ()
traceM (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath
"Executing: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [StorePathName] -> FilePath
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", StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString StorePathName
expr]
FilePath
""
pure $
case ExitCode
exitCode of
ExitCode
ExitSuccess ->
(Doc Void -> Either ErrorCall NExprLoc)
-> (NExprLoc -> Either ErrorCall NExprLoc)
-> Either (Doc Void) NExprLoc
-> Either ErrorCall NExprLoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\ Doc Void
e -> ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"Error parsing output of nix-instantiate: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Doc Void -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Doc Void
e)
NExprLoc -> Either ErrorCall NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(StorePathName -> Either (Doc Void) NExprLoc
parseNixTextLoc (StorePathName -> Either (Doc Void) NExprLoc)
-> StorePathName -> Either (Doc Void) NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePathName
forall a. ToText a => a -> StorePathName
toText FilePath
out)
ExitCode
status -> ErrorCall -> Either ErrorCall NExprLoc
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall NExprLoc)
-> ErrorCall -> Either ErrorCall NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"nix-instantiate failed: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ExitCode -> FilePath
forall b a. (Show a, IsString b) => a -> b
show ExitCode
status FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
": " FilePath -> FilePath -> 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 = m' (Maybe StorePathName) -> t m' (Maybe StorePathName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Maybe StorePathName) -> t m' (Maybe StorePathName))
-> (StorePathName -> m' (Maybe StorePathName))
-> StorePathName
-> t m' (Maybe StorePathName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePathName -> m' (Maybe StorePathName)
forall (m :: * -> *).
MonadEnv m =>
StorePathName -> m (Maybe StorePathName)
getEnvVar
getCurrentSystemOS :: m Text
default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
getCurrentSystemOS = m' StorePathName -> t m' StorePathName
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' StorePathName
forall (m :: * -> *). MonadEnv m => m StorePathName
getCurrentSystemOS
getCurrentSystemArch :: m Text
default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
getCurrentSystemArch = m' StorePathName -> t m' StorePathName
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' StorePathName
forall (m :: * -> *). MonadEnv m => m StorePathName
getCurrentSystemArch
instance MonadEnv IO where
getEnvVar :: StorePathName -> IO (Maybe StorePathName)
getEnvVar = (FilePath -> StorePathName)
-> IO (Maybe FilePath) -> IO (Maybe StorePathName)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
(<<$>>) FilePath -> StorePathName
forall a. ToText a => a -> StorePathName
toText (IO (Maybe FilePath) -> IO (Maybe StorePathName))
-> (StorePathName -> IO (Maybe FilePath))
-> StorePathName
-> IO (Maybe StorePathName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Maybe FilePath)
Env.lookupEnv (FilePath -> IO (Maybe FilePath))
-> (StorePathName -> FilePath)
-> StorePathName
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString
getCurrentSystemOS :: IO StorePathName
getCurrentSystemOS = StorePathName -> IO StorePathName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePathName -> IO StorePathName)
-> StorePathName -> IO StorePathName
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePathName
forall a. ToText a => a -> StorePathName
toText FilePath
System.Info.os
getCurrentSystemArch :: IO StorePathName
getCurrentSystemArch = StorePathName -> IO StorePathName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePathName -> IO StorePathName)
-> StorePathName -> IO StorePathName
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePathName
forall a. ToText a => a -> StorePathName
toText (FilePath -> StorePathName) -> FilePath -> StorePathName
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 FilePath
default getDataDir :: (MonadTrans t, MonadPaths m', m ~ t m') => m FilePath
getDataDir = m' FilePath -> t m' FilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' FilePath
forall (m :: * -> *). MonadPaths m => m FilePath
getDataDir
instance MonadPaths IO where
getDataDir :: IO FilePath
getDataDir = 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 = m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath))
-> (StorePathName -> m' (Either ErrorCall StorePath))
-> StorePathName
-> t m' (Either ErrorCall StorePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePathName -> m' (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadHttp m =>
StorePathName -> m (Either ErrorCall StorePath)
getURL
instance MonadHttp IO where
getURL :: StorePathName -> IO (Either ErrorCall StorePath)
getURL StorePathName
url = do
let urlstr :: FilePath
urlstr = StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString StorePathName
url
FilePath -> IO ()
forall (m :: * -> *). Monad m => FilePath -> m ()
traceM (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"fetching HTTP URL: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
urlstr
Request
req <- FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest FilePath
urlstr
Manager
manager <-
if Request -> RecursiveFlag
secure Request
req
then IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
else ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs (Request
req { method :: Method
method = Method
"GET" }) Manager
manager
let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response
pure $ ErrorCall -> Either ErrorCall StorePath
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall StorePath)
-> ErrorCall -> Either ErrorCall StorePath
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ if Int
status Int -> Int -> RecursiveFlag
forall a. Eq a => a -> a -> RecursiveFlag
/= Int
200
then
FilePath
"fail, got " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
status FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" when fetching url:" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
urlstr
else
FilePath
"success in downloading but hnix-store is not yet ready; url = " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
urlstr
deriving
instance
MonadHttp (t (Fix1 t))
=> MonadHttp (Fix1 t)
deriving
instance
MonadHttp (t (Fix1T t m) m)
=> MonadHttp (Fix1T t m)
class
Monad m
=> MonadPutStr m where
putStr :: String -> m ()
default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m ()
putStr = m' () -> t m' ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' () -> t m' ()) -> (FilePath -> m' ()) -> FilePath -> t m' ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' ()
forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
putStr
instance MonadPutStr IO where
putStr :: FilePath -> IO ()
putStr = FilePath -> IO ()
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 :: FilePath -> m ()
putStrLn = FilePath -> m ()
forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
putStr (FilePath -> m ()) -> (FilePath -> FilePath) -> FilePath -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n")
print :: (MonadPutStr m, Show a) => a -> m ()
print :: a -> m ()
print = FilePath -> m ()
forall (m :: * -> *). MonadPutStr m => FilePath -> m ()
putStrLn (FilePath -> m ()) -> (a -> FilePath) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall b a. (Show a, IsString b) => a -> b
show
type RecursiveFlag = Bool
type RepairFlag = Bool
type StorePathName = Text
type FilePathFilter m = FilePath -> m Bool
type StorePathSet = HS.HashSet StorePath
class
Monad m
=> MonadStore m where
addToStore :: StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
default addToStore :: (MonadTrans t, MonadStore m', m ~ t m') => StorePathName -> FilePath -> RecursiveFlag -> RepairFlag -> m (Either ErrorCall StorePath)
addToStore StorePathName
a FilePath
b RecursiveFlag
c RecursiveFlag
d = m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath))
-> m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePathName
-> FilePath
-> RecursiveFlag
-> RecursiveFlag
-> m' (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> FilePath
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore StorePathName
a FilePath
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 = m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath))
-> m' (Either ErrorCall StorePath)
-> t m' (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m' (Either ErrorCall StorePath)
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
-> FilePath
-> RecursiveFlag
-> RecursiveFlag
-> IO (Either ErrorCall StorePath)
addToStore StorePathName
name FilePath
path RecursiveFlag
recursive RecursiveFlag
repair =
(FilePath -> IO (Either ErrorCall StorePath))
-> (StorePathName -> IO (Either ErrorCall StorePath))
-> Either FilePath StorePathName
-> IO (Either ErrorCall StorePath)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\ FilePath
err -> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall StorePath -> IO (Either ErrorCall StorePath))
-> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ ErrorCall -> Either ErrorCall StorePath
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall StorePath)
-> ErrorCall -> Either ErrorCall StorePath
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"String '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> StorePathName -> FilePath
forall b a. (Show a, IsString b) => a -> b
show StorePathName
name FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' is not a valid path name: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err)
(\ StorePathName
pathName ->
do
(Either FilePath StorePath, [Logger])
res <- MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a. MonadStore a -> IO (Either FilePath a, [Logger])
Store.Remote.runStore (MonadStore StorePath -> IO (Either FilePath StorePath, [Logger]))
-> MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a b. (a -> b) -> a -> b
$ StorePathName
-> FilePath
-> RecursiveFlag
-> (FilePath -> RecursiveFlag)
-> RecursiveFlag
-> MonadStore StorePath
forall a.
NamedAlgo a =>
StorePathName
-> FilePath
-> RecursiveFlag
-> (FilePath -> RecursiveFlag)
-> RecursiveFlag
-> MonadStore StorePath
Store.Remote.addToStore @Hash.SHA256 StorePathName
pathName FilePath
path RecursiveFlag
recursive (RecursiveFlag -> FilePath -> RecursiveFlag
forall a b. a -> b -> a
const RecursiveFlag
False) RecursiveFlag
repair
(ErrorCall -> Either ErrorCall StorePath)
-> (StorePath -> Either ErrorCall StorePath)
-> Either ErrorCall StorePath
-> Either ErrorCall StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
ErrorCall -> Either ErrorCall StorePath
forall a b. a -> Either a b
Left
(StorePath -> Either ErrorCall StorePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePath -> Either ErrorCall StorePath)
-> (StorePath -> StorePath)
-> StorePath
-> Either ErrorCall StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> StorePath
StorePath (FilePath -> StorePath)
-> (StorePath -> FilePath) -> StorePath -> StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> FilePath
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Method -> FilePath)
-> (StorePath -> Method) -> StorePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> Method
Store.storePathToRawFilePath)
(Either ErrorCall StorePath -> Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StorePathName
-> (Either FilePath StorePath, [Logger])
-> IO (Either ErrorCall StorePath)
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 <- MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a. MonadStore a -> IO (Either FilePath a, [Logger])
Store.Remote.runStore (MonadStore StorePath -> IO (Either FilePath StorePath, [Logger]))
-> MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a b. (a -> b) -> a -> b
$ StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> MonadStore StorePath
Store.Remote.addTextToStore StorePathName
name StorePathName
text StorePathSet
references RecursiveFlag
repair
(ErrorCall -> Either ErrorCall StorePath)
-> (StorePath -> Either ErrorCall StorePath)
-> Either ErrorCall StorePath
-> Either ErrorCall StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
ErrorCall -> Either ErrorCall StorePath
forall a b. a -> Either a b
Left
(StorePath -> Either ErrorCall StorePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorePath -> Either ErrorCall StorePath)
-> (StorePath -> StorePath)
-> StorePath
-> Either ErrorCall StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> StorePath
StorePath (FilePath -> StorePath)
-> (StorePath -> FilePath) -> StorePath -> StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> FilePath
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Method -> FilePath)
-> (StorePath -> Method) -> StorePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> Method
Store.storePathToRawFilePath)
(Either ErrorCall StorePath -> Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
-> IO (Either ErrorCall StorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StorePathName
-> (Either FilePath StorePath, [Logger])
-> IO (Either ErrorCall StorePath)
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 :: StorePathName
-> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult StorePathName
name (Either FilePath a, [Logger])
res =
Either ErrorCall a -> m (Either ErrorCall a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorCall a -> m (Either ErrorCall a))
-> Either ErrorCall a -> m (Either ErrorCall a)
forall a b. (a -> b) -> a -> b
$ (FilePath -> Either ErrorCall a)
-> (a -> Either ErrorCall a)
-> Either FilePath a
-> Either ErrorCall a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\ FilePath
msg -> ErrorCall -> Either ErrorCall a
forall a b. a -> Either a b
Left (ErrorCall -> Either ErrorCall a)
-> ErrorCall -> Either ErrorCall a
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to execute '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> StorePathName -> FilePath
forall a. ToString a => a -> FilePath
toString StorePathName
name FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"': " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
msg FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Logger] -> FilePath
forall b a. (Show a, IsString b) => a -> b
show [Logger]
logs)
a -> Either ErrorCall a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
((Either FilePath a, [Logger]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Either FilePath a, [Logger])
res)
where
logs :: [Logger]
logs = (Either FilePath a, [Logger]) -> [Logger]
forall a b. (a, b) -> b
snd (Either FilePath a, [Logger])
res
addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
addTextToStore :: StorePathName
-> StorePathName -> StorePathSet -> RecursiveFlag -> m StorePath
addTextToStore StorePathName
a StorePathName
b StorePathSet
c RecursiveFlag
d =
(ErrorCall -> m StorePath)
-> (StorePath -> m StorePath)
-> Either ErrorCall StorePath
-> m StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
ErrorCall -> m StorePath
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError
StorePath -> m StorePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either ErrorCall StorePath -> m StorePath)
-> m (Either ErrorCall StorePath) -> m StorePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StorePathName
-> StorePathName
-> StorePathSet
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
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) => FilePath -> m StorePath
addPath :: FilePath -> m StorePath
addPath FilePath
p =
(ErrorCall -> m StorePath)
-> (StorePath -> m StorePath)
-> Either ErrorCall StorePath
-> m StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
ErrorCall -> m StorePath
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError
StorePath -> m StorePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either ErrorCall StorePath -> m StorePath)
-> m (Either ErrorCall StorePath) -> m StorePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StorePathName
-> FilePath
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
StorePathName
-> FilePath
-> RecursiveFlag
-> RecursiveFlag
-> m (Either ErrorCall StorePath)
addToStore (FilePath -> StorePathName
forall a. ToText a => a -> StorePathName
toText (FilePath -> StorePathName) -> FilePath -> StorePathName
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
p) FilePath
p RecursiveFlag
True RecursiveFlag
False
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
toFile_ :: FilePath -> FilePath -> m StorePath
toFile_ FilePath
p FilePath
contents = StorePathName
-> StorePathName -> StorePathSet -> RecursiveFlag -> m StorePath
forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
StorePathName
-> StorePathName -> StorePathSet -> RecursiveFlag -> m StorePath
addTextToStore (FilePath -> StorePathName
forall a. ToText a => a -> StorePathName
toText FilePath
p) (FilePath -> StorePathName
forall a. ToText a => a -> StorePathName
toText FilePath
contents) StorePathSet
forall a. Monoid a => a
mempty RecursiveFlag
False