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

-- | A path into the nix 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
  -- | Determine the absolute path of relative path in the current context
  makeAbsolutePath :: FilePath -> m FilePath
  findEnvPath :: String -> m FilePath

  -- | Having an explicit list of sets corresponding to the NIX_PATH
  -- and a file path try to find an existing path
  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

  -- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
  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
    -- print req
    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 -- do
        -- let bstr = responseBody response
        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
    --TODO: Should this be used *only* when the Nix to be evaluated invokes a
    --`trace` operation?
    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

    -- | Copy the contents of a local path to the store.  The resulting store
    -- path is returned.  Note: This does not support yet support the expected
    -- `filter` function that allows excluding some files.
    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

    -- | Like addToStore, but the contents written to the output path is a
    -- regular file containing the given string.
    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
      -- TODO: redesign the filter parameter
      (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