{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module Nix.Effects where

import           Prelude                 hiding ( putStr
                                                , putStrLn
                                                , print
                                                )
import qualified Prelude

import           Control.Monad.Trans
import           Data.Text                      ( Text )
import qualified Data.Text                     as T
import           Network.HTTP.Client     hiding ( path )
import           Network.HTTP.Client.TLS
import           Network.HTTP.Types
import           Nix.Expr
import           Nix.Frames
import           Nix.Parser
import           Nix.Render
import           Nix.Utils
import           Nix.Value
import qualified Paths_hnix
import qualified System.Directory              as S
import           System.Environment
import           System.Exit
import qualified System.Info
import           System.Process

-- | 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
    \_ -> Word -> IO Word
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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 "exec: missing program"
    (prog :: FilePath
prog : args :: [FilePath]
args) -> do
      (exitCode :: ExitCode
exitCode, out :: FilePath
out, _) <- 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 ""
      let t :: Text
t    = Text -> Text
T.strip (FilePath -> Text
T.pack FilePath
out)
      let emsg :: FilePath
emsg = "program[" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
prog FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "] args=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
args
      case ExitCode
exitCode of
        ExitSuccess -> if Text -> Bool
T.null Text
t
          then Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (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
$ "exec has no output :" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
emsg
          else case Text -> Result NExprLoc
parseNixTextLoc Text
t of
            Failure err :: Doc Void
err ->
              Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return
                (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
$  "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
forall a. [a] -> [a] -> [a]
++ FilePath
emsg
            Success v :: NExprLoc
v -> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (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
        err :: ExitCode
err ->
          Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return
            (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
$  "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
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 expr :: FilePath
expr = do
    FilePath -> IO ()
forall (m :: * -> *). Monad m => FilePath -> m ()
traceM (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Executing: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show
      ["nix-instantiate", "--eval", "--expr ", FilePath
expr]
    (exitCode :: ExitCode
exitCode, out :: FilePath
out, err :: FilePath
err) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode "nix-instantiate"
                                                    ["--eval", "--expr", FilePath
expr]
                                                    ""
    case ExitCode
exitCode of
      ExitSuccess -> case Text -> Result NExprLoc
parseNixTextLoc (FilePath -> Text
T.pack FilePath
out) of
        Failure e :: Doc Void
e ->
          Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return
            (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
$  "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 v :: NExprLoc
v -> Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (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
      status :: ExitCode
status ->
        Either ErrorCall NExprLoc -> IO (Either ErrorCall NExprLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return
          (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
$  "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
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
doesFileExist

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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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
    "i386" -> "i686"
    arch :: 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 url :: 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
$ "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 = "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
/= 200
      then
        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
$  "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]
++ " 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 (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
$  "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]
++ "\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

class Monad m => MonadStore m where
    -- | Import a path into the nix store, and return the resulting path
    addPath' :: FilePath -> m (Either ErrorCall StorePath)

    -- | Add a file with the given name and contents to the nix store
    toFile_' :: FilePath -> String -> m (Either ErrorCall StorePath)

instance MonadStore IO where
  addPath' :: FilePath -> IO (Either ErrorCall StorePath)
addPath' path :: FilePath
path = do
    (exitCode :: ExitCode
exitCode, out :: FilePath
out, _) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode "nix-store" ["--add", FilePath
path] ""
    case ExitCode
exitCode of
      ExitSuccess -> do
        let dropTrailingLinefeed :: [a] -> [a]
dropTrailingLinefeed p :: [a]
p = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [a]
p
        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
$ FilePath -> FilePath
forall a. [a] -> [a]
dropTrailingLinefeed FilePath
out
      _ ->
        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
$  "addPath: failed: nix-store --add "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
path

--TODO: Use a temp directory so we don't overwrite anything important
  toFile_' :: FilePath -> FilePath -> IO (Either ErrorCall StorePath)
toFile_' filepath :: FilePath
filepath content :: FilePath
content = do
    FilePath -> FilePath -> IO ()
writeFile FilePath
filepath FilePath
content
    Either ErrorCall StorePath
storepath <- FilePath -> IO (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
FilePath -> m (Either ErrorCall StorePath)
addPath' FilePath
filepath
    FilePath -> IO ()
S.removeFile FilePath
filepath
    Either ErrorCall StorePath -> IO (Either ErrorCall StorePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorCall StorePath
storepath

addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
addPath :: FilePath -> m StorePath
addPath p :: 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
=<< FilePath -> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
FilePath -> m (Either ErrorCall StorePath)
addPath' FilePath
p

toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
toFile_ :: FilePath -> FilePath -> m StorePath
toFile_ p :: FilePath
p contents :: FilePath
contents = (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
=<< FilePath -> FilePath -> m (Either ErrorCall StorePath)
forall (m :: * -> *).
MonadStore m =>
FilePath -> FilePath -> m (Either ErrorCall StorePath)
toFile_' FilePath
p FilePath
contents