{-|
Module      : Foreign.Lua.Module.System
Copyright   : © 2019 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <albert+hslua@zeitkraut.de>
Stability   : alpha
Portability : Requires GHC 8 or later.

Provide a Lua module containing a selection of @'System'@ functions.
-}
module Foreign.Lua.Module.System (

  -- * Module
    pushModule
  , preloadModule

  -- * Fields
  , arch
  , compiler_name
  , compiler_version
  , os

  -- * Functions
  , env
  , getwd
  , getenv
  , ls
  , mkdir
  , rmdir
  , setenv
  , setwd
  , tmpdirname
  , with_env
  , with_tmpdir
  , with_wd
  )
where

import Control.Applicative ((<$>))
import Control.Monad (forM_)
import Control.Monad.Catch (bracket)
import Data.Maybe (fromMaybe)
import Data.Version (versionBranch)
import Foreign.Lua (Lua, NumResults (..), Optional (..))
import Foreign.Lua.Module.SystemUtils

import qualified Data.Map as Map
import qualified Foreign.Lua as Lua
import qualified System.Directory as Directory
import qualified System.Environment as Env
import qualified System.Info as Info
import qualified System.IO.Temp as Temp

--
-- Module
--

-- | Pushes the @system@ module to the Lua stack.
pushModule :: Lua NumResults
pushModule :: Lua NumResults
pushModule = do
  Lua ()
Lua.newtable
  String -> String -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
Lua.addfield "arch" String
arch
  String -> String -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
Lua.addfield "compiler_name" String
compiler_name
  String -> [Int] -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
Lua.addfield "compiler_version" [Int]
compiler_version
  String -> String -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
Lua.addfield "os" String
os
  String -> Lua NumResults -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "env" Lua NumResults
env
  String -> (String -> Lua (Optional String)) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "getenv" String -> Lua (Optional String)
getenv
  String -> Lua String -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "getwd" Lua String
getwd
  String -> (Optional String -> Lua [String]) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "ls" Optional String -> Lua [String]
ls
  String -> (String -> Bool -> Lua ()) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "mkdir" String -> Bool -> Lua ()
mkdir
  String -> (String -> Bool -> Lua ()) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "rmdir" String -> Bool -> Lua ()
rmdir
  String -> (String -> String -> Lua ()) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "setenv" String -> String -> Lua ()
setenv
  String -> (String -> Lua ()) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "setwd" String -> Lua ()
setwd
  String -> Lua String -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "tmpdirname" Lua String
tmpdirname
  String
-> (Map String String -> Callback -> Lua NumResults) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "with_env" Map String String -> Callback -> Lua NumResults
with_env
  String
-> (String -> AnyValue -> Optional Callback -> Lua NumResults)
-> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "with_tmpdir" String -> AnyValue -> Optional Callback -> Lua NumResults
with_tmpdir
  String -> (String -> Callback -> Lua NumResults) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction "with_wd" String -> Callback -> Lua NumResults
with_wd
  NumResults -> Lua NumResults
forall (m :: * -> *) a. Monad m => a -> m a
return 1

-- | Add the @system@ module under the given name to the table of
-- preloaded packages.
preloadModule :: String -> Lua ()
preloadModule :: String -> Lua ()
preloadModule = (String -> Lua NumResults -> Lua ())
-> Lua NumResults -> String -> Lua ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Lua NumResults -> Lua ()
Lua.preloadhs Lua NumResults
pushModule

--
-- Fields
--

-- | The machine architecture on which the program is running.
arch :: String
arch :: String
arch = String
Info.arch

-- | The Haskell implementation with which the host program was
-- compiled.
compiler_name :: String
compiler_name :: String
compiler_name = String
Info.compilerName

-- | The version of `compiler_name` with which the host program was
-- compiled.
compiler_version :: [Int]
compiler_version :: [Int]
compiler_version = Version -> [Int]
versionBranch Version
Info.compilerVersion

-- | The operating system on which the program is running.
os :: String
os :: String
os = String
Info.os


--
-- Functions
--

-- | Retrieve the entire environment
env :: Lua NumResults
env :: Lua NumResults
env = do
  [(String, String)]
kvs <- IO [(String, String)] -> Lua [(String, String)]
forall a. IO a -> Lua a
ioToLua IO [(String, String)]
Env.getEnvironment
  let addValue :: (a, a) -> Lua ()
addValue (k :: a
k, v :: a
v) = a -> Lua ()
forall a. Pushable a => a -> Lua ()
Lua.push a
k Lua () -> Lua () -> Lua ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a -> Lua ()
forall a. Pushable a => a -> Lua ()
Lua.push a
v Lua () -> Lua () -> Lua ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StackIndex -> Lua ()
Lua.rawset (-3)
  Lua ()
Lua.newtable
  ((String, String) -> Lua ()) -> [(String, String)] -> Lua ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, String) -> Lua ()
forall a a. (Pushable a, Pushable a) => (a, a) -> Lua ()
addValue [(String, String)]
kvs
  NumResults -> Lua NumResults
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> NumResults
NumResults 1)

-- | Return the current working directory as an absolute path.
getwd :: Lua FilePath
getwd :: Lua String
getwd = IO String -> Lua String
forall a. IO a -> Lua a
ioToLua IO String
Directory.getCurrentDirectory

-- | Returns the value of an environment variable
getenv :: String -> Lua (Optional String)
getenv :: String -> Lua (Optional String)
getenv name :: String
name = IO (Optional String) -> Lua (Optional String)
forall a. IO a -> Lua a
ioToLua (Maybe String -> Optional String
forall a. Maybe a -> Optional a
Optional (Maybe String -> Optional String)
-> IO (Maybe String) -> IO (Optional String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
Env.lookupEnv String
name)

-- | List the contents of a directory.
ls :: Optional FilePath -> Lua [FilePath]
ls :: Optional String -> Lua [String]
ls fp :: Optional String
fp = do
  let fp' :: String
fp' = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "." (Optional String -> Maybe String
forall a. Optional a -> Maybe a
fromOptional Optional String
fp)
  IO [String] -> Lua [String]
forall a. IO a -> Lua a
ioToLua (String -> IO [String]
Directory.listDirectory String
fp')

-- | Create a new directory which is initially empty, or as near to
-- empty as the operating system allows.
--
-- If the optional second parameter is `false`, then create the new
-- directory only if it doesn't exist yet. If the parameter is `true`,
-- then parent directories are created as necessary.
mkdir :: FilePath -> Bool -> Lua ()
mkdir :: String -> Bool -> Lua ()
mkdir fp :: String
fp createParent :: Bool
createParent =
  if Bool
createParent
  then IO () -> Lua ()
forall a. IO a -> Lua a
ioToLua (Bool -> String -> IO ()
Directory.createDirectoryIfMissing Bool
True String
fp)
  else IO () -> Lua ()
forall a. IO a -> Lua a
ioToLua (String -> IO ()
Directory.createDirectory String
fp)

-- | Remove an existing directory.
rmdir :: FilePath -> Bool -> Lua ()
rmdir :: String -> Bool -> Lua ()
rmdir fp :: String
fp recursive :: Bool
recursive =
  if Bool
recursive
  then IO () -> Lua ()
forall a. IO a -> Lua a
ioToLua (String -> IO ()
Directory.removeDirectoryRecursive String
fp)
  else IO () -> Lua ()
forall a. IO a -> Lua a
ioToLua (String -> IO ()
Directory.removeDirectory String
fp)

-- | Set the specified environment variable to a new value.
setenv :: String -> String -> Lua ()
setenv :: String -> String -> Lua ()
setenv name :: String
name value :: String
value = IO () -> Lua ()
forall a. IO a -> Lua a
ioToLua (String -> String -> IO ()
Env.setEnv String
name String
value)

-- | Change current working directory.
setwd :: FilePath -> Lua ()
setwd :: String -> Lua ()
setwd fp :: String
fp = IO () -> Lua ()
forall a. IO a -> Lua a
ioToLua (IO () -> Lua ()) -> IO () -> Lua ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.setCurrentDirectory String
fp

-- | Get the current directory for temporary files.
tmpdirname :: Lua FilePath
tmpdirname :: Lua String
tmpdirname = IO String -> Lua String
forall a. IO a -> Lua a
ioToLua IO String
Directory.getTemporaryDirectory

-- | Run an action in a different directory, then restore the old
-- working directory.
with_wd :: FilePath -> Callback -> Lua NumResults
with_wd :: String -> Callback -> Lua NumResults
with_wd fp :: String
fp callback :: Callback
callback =
  Lua String
-> (String -> Lua ())
-> (String -> Lua NumResults)
-> Lua NumResults
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO String -> Lua String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO IO String
Directory.getCurrentDirectory)
          (IO () -> Lua ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (IO () -> Lua ()) -> (String -> IO ()) -> String -> Lua ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
Directory.setCurrentDirectory)
          ((String -> Lua NumResults) -> Lua NumResults)
-> (String -> Lua NumResults) -> Lua NumResults
forall a b. (a -> b) -> a -> b
$ \_ -> do
              IO () -> Lua ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (String -> IO ()
Directory.setCurrentDirectory String
fp)
              Callback
callback Callback -> String -> Lua NumResults
`invokeWithFilePath` String
fp


-- | Run an action, then restore the old environment variable values.
with_env :: Map.Map String String -> Callback -> Lua NumResults
with_env :: Map String String -> Callback -> Lua NumResults
with_env environment :: Map String String
environment callback :: Callback
callback =
  Lua [(String, String)]
-> ([(String, String)] -> Lua ())
-> ([(String, String)] -> Lua NumResults)
-> Lua NumResults
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO [(String, String)] -> Lua [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO IO [(String, String)]
Env.getEnvironment)
          [(String, String)] -> Lua ()
forall (m :: * -> *) (t :: * -> *).
(MonadIO m, Foldable t) =>
t (String, String) -> m ()
setEnvironment
          (\_ -> [(String, String)] -> Lua ()
forall (m :: * -> *) (t :: * -> *).
(MonadIO m, Foldable t) =>
t (String, String) -> m ()
setEnvironment (Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String String
environment) Lua () -> Lua NumResults -> Lua NumResults
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Callback -> Lua NumResults
invoke Callback
callback)
 where
  setEnvironment :: t (String, String) -> m ()
setEnvironment newEnv :: t (String, String)
newEnv = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Lua.liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- Crude, but fast enough: delete all entries in new environment,
    -- then restore old environment one-by-one.
    [(String, String)]
curEnv <- IO [(String, String)]
Env.getEnvironment
    [(String, String)] -> ((String, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, String)]
curEnv (String -> IO ()
Env.unsetEnv (String -> IO ())
-> ((String, String) -> String) -> (String, String) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst)
    t (String, String) -> ((String, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (String, String)
newEnv ((String -> String -> IO ()) -> (String, String) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> IO ()
Env.setEnv)

with_tmpdir :: String            -- ^ parent dir or template
            -> AnyValue          -- ^ template or callback
            -> Optional Callback -- ^ callback or nil
            -> Lua NumResults
with_tmpdir :: String -> AnyValue -> Optional Callback -> Lua NumResults
with_tmpdir parentDir :: String
parentDir tmpl :: AnyValue
tmpl callback :: Optional Callback
callback =
  case Optional Callback -> Maybe Callback
forall a. Optional a -> Maybe a
fromOptional Optional Callback
callback of
    Nothing -> do
      -- At most two args. The first arg (parent dir) has probably been
      -- omitted, so we shift arguments and use the system's canonical
      -- temporary directory.
      let tmpl' :: String
tmpl' = String
parentDir
      Callback
callback' <- StackIndex -> Lua Callback
forall a. Peekable a => StackIndex -> Lua a
Lua.peek (AnyValue -> StackIndex
fromAnyValue AnyValue
tmpl)
      String -> (String -> Lua NumResults) -> Lua NumResults
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
Temp.withSystemTempDirectory String
tmpl' (Callback -> String -> Lua NumResults
invokeWithFilePath Callback
callback')
    Just callback' :: Callback
callback' -> do
      -- all args given. Second value must be converted to a string.
      String
tmpl' <- StackIndex -> Lua String
forall a. Peekable a => StackIndex -> Lua a
Lua.peek (AnyValue -> StackIndex
fromAnyValue AnyValue
tmpl)
      String -> String -> (String -> Lua NumResults) -> Lua NumResults
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
Temp.withTempDirectory String
parentDir String
tmpl' (Callback -> String -> Lua NumResults
invokeWithFilePath Callback
callback')