{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
module Nix.Effects where
import Prelude hiding ( putStr
, putStrLn
, print
)
import qualified Prelude
import Control.Monad.Trans
import qualified Data.HashSet as HS
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Client hiding ( path, Proxy )
import Network.HTTP.Client.TLS
import Network.HTTP.Types
import Nix.Expr
import Nix.Frames hiding ( Proxy )
import Nix.Parser
import Nix.Render
import Nix.Utils
import Nix.Value
import qualified Paths_hnix
import System.Environment
import System.Exit
import System.FilePath ( takeFileName )
import qualified System.Info
import System.Process
import qualified System.Nix.Hash as Store
import qualified System.Nix.Store.Remote as Store
import qualified System.Nix.Store.Remote.Types as Store
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 ()
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
#if MIN_VERSION_ghc_datasize(0,2,0)
recursiveSize
#else
\_ -> return 0
#endif
#else
\a
_ -> Word -> IO Word
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0
#endif
class Monad m => MonadExec m where
exec' :: [String] -> m (Either ErrorCall NExprLoc)
default exec' :: (MonadTrans t, MonadExec m', m ~ t m')
=> [String] -> 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))
-> ([FilePath] -> m' (Either ErrorCall NExprLoc))
-> [FilePath]
-> t m' (Either ErrorCall NExprLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> m' (Either ErrorCall NExprLoc)
forall (m :: * -> *).
MonadExec m =>
[FilePath] -> m (Either ErrorCall NExprLoc)
exec'
instance MonadExec IO where
exec' :: [FilePath] -> 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"
(FilePath
prog : [FilePath]
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 FilePath
prog [FilePath]
args FilePath
""
let t :: Text
t = Text -> Text
T.strip (FilePath -> Text
T.pack FilePath
out)
let emsg :: FilePath
emsg = FilePath
"program[" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
prog FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"] args=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
args
case ExitCode
exitCode of
ExitCode
ExitSuccess -> if Text -> Bool
T.null Text
t
then 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
$ FilePath
"exec has no output :" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
emsg
else case Text -> Result NExprLoc
parseNixTextLoc Text
t of
Failure Doc Void
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
$ FilePath
"Error parsing output of exec: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc Void -> FilePath
forall a. Show a => a -> FilePath
show Doc Void
err
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
emsg
Success NExprLoc
v -> 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
$ NExprLoc -> Either ErrorCall NExprLoc
forall a b. b -> Either a b
Right NExprLoc
v
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
$ FilePath
"exec failed: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
err
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
emsg
class Monad m => MonadInstantiate m where
instantiateExpr :: String -> m (Either ErrorCall NExprLoc)
default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => String -> 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))
-> (FilePath -> m' (Either ErrorCall NExprLoc))
-> FilePath
-> t m' (Either ErrorCall NExprLoc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' (Either ErrorCall NExprLoc)
forall (m :: * -> *).
MonadInstantiate m =>
FilePath -> m (Either ErrorCall NExprLoc)
instantiateExpr
instance MonadInstantiate IO where
instantiateExpr :: FilePath -> IO (Either ErrorCall NExprLoc)
instantiateExpr FilePath
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. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show
[FilePath
"nix-instantiate", FilePath
"--eval", FilePath
"--expr ", FilePath
expr]
(ExitCode
exitCode, FilePath
out, FilePath
err) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"nix-instantiate"
[FilePath
"--eval", FilePath
"--expr", FilePath
expr]
FilePath
""
case ExitCode
exitCode of
ExitCode
ExitSuccess -> case Text -> Result NExprLoc
parseNixTextLoc (FilePath -> Text
T.pack FilePath
out) of
Failure Doc Void
e ->
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
$ FilePath
"Error parsing output of nix-instantiate: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc Void -> FilePath
forall a. Show a => a -> FilePath
show Doc Void
e
Success NExprLoc
v -> 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
$ NExprLoc -> Either ErrorCall NExprLoc
forall a b. b -> Either a b
Right NExprLoc
v
ExitCode
status ->
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
$ FilePath
"nix-instantiate failed: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
status
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
pathExists :: MonadFile m => FilePath -> m Bool
pathExists :: FilePath -> m Bool
pathExists = FilePath -> m Bool
forall (m :: * -> *). MonadFile m => FilePath -> m Bool
doesPathExist
class Monad m => MonadEnv m where
getEnvVar :: String -> m (Maybe String)
default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => String -> m (Maybe String)
getEnvVar = m' (Maybe FilePath) -> t m' (Maybe FilePath)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' (Maybe FilePath) -> t m' (Maybe FilePath))
-> (FilePath -> m' (Maybe FilePath))
-> FilePath
-> t m' (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' (Maybe FilePath)
forall (m :: * -> *). MonadEnv m => FilePath -> m (Maybe FilePath)
getEnvVar
getCurrentSystemOS :: m Text
default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
getCurrentSystemOS = m' Text -> t m' Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' Text
forall (m :: * -> *). MonadEnv m => m Text
getCurrentSystemOS
getCurrentSystemArch :: m Text
default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
getCurrentSystemArch = m' Text -> t m' Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' Text
forall (m :: * -> *). MonadEnv m => m Text
getCurrentSystemArch
instance MonadEnv IO where
getEnvVar :: FilePath -> IO (Maybe FilePath)
getEnvVar = FilePath -> IO (Maybe FilePath)
lookupEnv
getCurrentSystemOS :: IO Text
getCurrentSystemOS = Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
System.Info.os
getCurrentSystemArch :: IO Text
getCurrentSystemArch = Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ case FilePath
System.Info.arch of
FilePath
"i386" -> FilePath
"i686"
FilePath
arch -> FilePath
arch
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
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))
-> (Text -> m' (Either ErrorCall StorePath))
-> Text
-> t m' (Either ErrorCall StorePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m' (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadHttp m =>
Text -> m (Either ErrorCall StorePath)
getURL
instance MonadHttp IO where
getURL :: Text -> IO (Either ErrorCall StorePath)
getURL Text
url = do
let urlstr :: FilePath
urlstr = Text -> FilePath
T.unpack Text
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. [a] -> [a] -> [a]
++ FilePath
urlstr
Request
req <- FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest FilePath
urlstr
Manager
manager <- if Request -> Bool
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 (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response)
if Int
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
200
then
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
"fail, got "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
status
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" when fetching url:"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
urlstr
else
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
"success in downloading but hnix-store is not yet ready; url = "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
urlstr
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
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. [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 a. Show a => a -> FilePath
show
instance MonadPutStr IO where
putStr :: FilePath -> IO ()
putStr = FilePath -> IO ()
Prelude.putStr
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 Text
a FilePath
b Bool
c Bool
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
$ Text -> FilePath -> Bool -> Bool -> m' (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
Text -> FilePath -> Bool -> Bool -> m (Either ErrorCall StorePath)
addToStore Text
a FilePath
b Bool
c Bool
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' Text
a Text
b StorePathSet
c Bool
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
$ Text
-> Text -> StorePathSet -> Bool -> m' (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
Text
-> Text -> StorePathSet -> Bool -> m (Either ErrorCall StorePath)
addTextToStore' Text
a Text
b StorePathSet
c Bool
d
parseStoreResult :: Monad m => String -> (Either String a, [Store.Logger]) -> m (Either ErrorCall a)
parseStoreResult :: FilePath -> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult FilePath
name (Either FilePath a, [Logger])
res = case (Either FilePath a, [Logger])
res of
(Left FilePath
msg, [Logger]
logs) -> Either ErrorCall a -> m (Either ErrorCall a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorCall a -> m (Either ErrorCall a))
-> Either ErrorCall a -> m (Either ErrorCall a)
forall a b. (a -> b) -> a -> b
$ 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. [a] -> [a] -> [a]
++ FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"': " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Logger] -> FilePath
forall a. Show a => a -> FilePath
show [Logger]
logs
(Right a
result, [Logger]
_) -> Either ErrorCall a -> m (Either ErrorCall a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorCall a -> m (Either ErrorCall a))
-> Either ErrorCall a -> m (Either ErrorCall a)
forall a b. (a -> b) -> a -> b
$ a -> Either ErrorCall a
forall a b. b -> Either a b
Right a
result
instance MonadStore IO where
addToStore :: Text -> FilePath -> Bool -> Bool -> IO (Either ErrorCall StorePath)
addToStore Text
name FilePath
path Bool
recursive Bool
repair = case Text -> Either FilePath StorePathName
Store.makeStorePathName Text
name of
Left FilePath
err -> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (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. [a] -> [a] -> [a]
++ Text -> FilePath
forall a. Show a => a -> FilePath
show Text
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' is not a valid path name: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
Right 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.runStore (MonadStore StorePath -> IO (Either FilePath StorePath, [Logger]))
-> MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a b. (a -> b) -> a -> b
$ StorePathName
-> FilePath
-> Bool
-> (FilePath -> Bool)
-> Bool
-> MonadStore StorePath
forall (a :: HashAlgorithm).
(ValidAlgo a, NamedAlgo a) =>
StorePathName
-> FilePath
-> Bool
-> (FilePath -> Bool)
-> Bool
-> MonadStore StorePath
Store.addToStore @'Store.SHA256 StorePathName
pathName FilePath
path Bool
recursive (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
False) Bool
repair
FilePath
-> (Either FilePath StorePath, [Logger])
-> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a.
Monad m =>
FilePath -> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult FilePath
"addToStore" (Either FilePath StorePath, [Logger])
res IO (Either ErrorCall StorePath)
-> (Either ErrorCall StorePath -> IO (Either ErrorCall StorePath))
-> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ErrorCall
err -> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (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
err
Right StorePath
storePath -> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorCall StorePath -> IO (Either ErrorCall StorePath))
-> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePath -> Either ErrorCall StorePath
forall a b. b -> Either a b
Right (StorePath -> Either ErrorCall StorePath)
-> StorePath -> Either ErrorCall StorePath
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePath
StorePath (FilePath -> StorePath) -> FilePath -> StorePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Method -> Text
T.decodeUtf8 (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ StorePath -> Method
Store.storePathToRawFilePath StorePath
storePath
addTextToStore' :: Text
-> Text -> StorePathSet -> Bool -> IO (Either ErrorCall StorePath)
addTextToStore' Text
name Text
text StorePathSet
references Bool
repair = do
(Either FilePath StorePath, [Logger])
res <- MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a. MonadStore a -> IO (Either FilePath a, [Logger])
Store.runStore (MonadStore StorePath -> IO (Either FilePath StorePath, [Logger]))
-> MonadStore StorePath -> IO (Either FilePath StorePath, [Logger])
forall a b. (a -> b) -> a -> b
$ Text -> Text -> StorePathSet -> Bool -> MonadStore StorePath
Store.addTextToStore Text
name Text
text StorePathSet
references Bool
repair
FilePath
-> (Either FilePath StorePath, [Logger])
-> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a.
Monad m =>
FilePath -> (Either FilePath a, [Logger]) -> m (Either ErrorCall a)
parseStoreResult FilePath
"addTextToStore" (Either FilePath StorePath, [Logger])
res IO (Either ErrorCall StorePath)
-> (Either ErrorCall StorePath -> IO (Either ErrorCall StorePath))
-> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ErrorCall
err -> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (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
err
Right StorePath
path -> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorCall StorePath -> IO (Either ErrorCall StorePath))
-> Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall a b. (a -> b) -> a -> b
$ StorePath -> Either ErrorCall StorePath
forall a b. b -> Either a b
Right (StorePath -> Either ErrorCall StorePath)
-> StorePath -> Either ErrorCall StorePath
forall a b. (a -> b) -> a -> b
$ FilePath -> StorePath
StorePath (FilePath -> StorePath) -> FilePath -> StorePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Method -> Text
T.decodeUtf8 (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ StorePath -> Method
Store.storePathToRawFilePath StorePath
path
addTextToStore :: (Framed e m, MonadStore m) => StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath
addTextToStore :: Text -> Text -> StorePathSet -> Bool -> m StorePath
addTextToStore Text
a Text
b StorePathSet
c Bool
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 (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorCall StorePath -> m StorePath)
-> m (Either ErrorCall StorePath) -> m StorePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text
-> Text -> StorePathSet -> Bool -> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
Text
-> Text -> StorePathSet -> Bool -> m (Either ErrorCall StorePath)
addTextToStore' Text
a Text
b StorePathSet
c Bool
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 (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorCall StorePath -> m StorePath)
-> m (Either ErrorCall StorePath) -> m StorePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> FilePath -> Bool -> Bool -> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
Text -> FilePath -> Bool -> Bool -> m (Either ErrorCall StorePath)
addToStore (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
p) FilePath
p Bool
True Bool
False
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
toFile_ :: FilePath -> FilePath -> m StorePath
toFile_ FilePath
p FilePath
contents = Text -> Text -> StorePathSet -> Bool -> m StorePath
forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Text -> Text -> StorePathSet -> Bool -> m StorePath
addTextToStore (FilePath -> Text
T.pack FilePath
p) (FilePath -> Text
T.pack FilePath
contents) StorePathSet
forall a. HashSet a
HS.empty Bool
False