{-|
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 String
"arch" String
arch
  String -> String -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
Lua.addfield String
"compiler_name" String
compiler_name
  String -> [Int] -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
Lua.addfield String
"compiler_version" [Int]
compiler_version
  String -> String -> Lua ()
forall a. Pushable a => String -> a -> Lua ()
Lua.addfield String
"os" String
os
  String -> Lua NumResults -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"env" Lua NumResults
env
  String -> (String -> Lua (Optional String)) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"getenv" String -> Lua (Optional String)
getenv
  String -> Lua String -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"getwd" Lua String
getwd
  String -> (Optional String -> Lua [String]) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"ls" Optional String -> Lua [String]
ls
  String -> (String -> Bool -> Lua ()) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"mkdir" String -> Bool -> Lua ()
mkdir
  String -> (String -> Bool -> Lua ()) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"rmdir" String -> Bool -> Lua ()
rmdir
  String -> (String -> String -> Lua ()) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"setenv" String -> String -> Lua ()
setenv
  String -> (String -> Lua ()) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"setwd" String -> Lua ()
setwd
  String -> Lua String -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"tmpdirname" Lua String
tmpdirname
  String
-> (Map String String -> Callback -> Lua NumResults) -> Lua ()
forall a. ToHaskellFunction a => String -> a -> Lua ()
Lua.addfunction String
"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 String
"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 String
"with_wd" String -> Callback -> Lua NumResults
with_wd
  NumResults -> Lua NumResults
forall (m :: * -> *) a. Monad m => a -> m a
return NumResults
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 (a
k, 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 (-StackIndex
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 CInt
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 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 Optional String
fp = do
  let fp' :: String
fp' = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"." (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 String
fp 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 String
fp 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 String
name 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 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 String
fp 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
$ \String
_ -> 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 Map String String
environment 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)]
_ -> [(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 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 String
parentDir AnyValue
tmpl Optional Callback
callback =
  case Optional Callback -> Maybe Callback
forall a. Optional a -> Maybe a
fromOptional Optional Callback
callback of
    Maybe Callback
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' -> 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')