diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,34 @@ # Revision history for hslua-module-system +## 0.2.0 -- 2019-05-01 + +All fields and functions are now exported from the Haskell module under +the same name as that used in Lua. + +### New fields + +- `arch`: processor architecture. +- `compiler_name`: Haskell compiler that was used to compile the module. +- `compiler_version`: version of the compiler. +- `os`: operating system. + +### New functions + +- `mkdir`: create a new directory. +- `rmdir`: remove a directory. +- `with_env`: perform action with custom environment. +- `with_wd`: perform action in another directory. + +### Removed or renamed functions + +- `currentdir` was renamed to `getwd`. +- `chdir` was renamed to `setwd`. +- `pwd` was removed. + +### Misc + +- Fix typos and copy-paste errors in docs, tests. + ## 0.1.0 -- 2019-04-26 -* First version. Released on an unsuspecting world. +- First version. Released on an unsuspecting world. diff --git a/hslua-module-system.cabal b/hslua-module-system.cabal --- a/hslua-module-system.cabal +++ b/hslua-module-system.cabal @@ -1,5 +1,5 @@ name: hslua-module-system -version: 0.1.0.1 +version: 0.2.0 synopsis: Lua module wrapper around Haskell's System module. description: Provides access to system information and functionality @@ -20,6 +20,7 @@ extra-source-files: CHANGELOG.md test/system-module-tests.lua cabal-version: >=1.10 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 source-repository head type: git @@ -27,12 +28,15 @@ library build-depends: base >= 4.9 && < 5 - , directory >= 1.3 && < 1.4 + , containers >= 0.5 && < 0.7 + , directory >= 1.3 && < 1.4 + , exceptions >= 0.8 && < 0.11 , hslua >= 1.0 && < 1.2 , temporary >= 1.2 && < 1.4 default-extensions: LambdaCase default-language: Haskell2010 exposed-modules: Foreign.Lua.Module.System + other-modules: Foreign.Lua.Module.SystemUtils hs-source-dirs: src other-extensions: OverloadedStrings diff --git a/src/Foreign/Lua/Module/System.hs b/src/Foreign/Lua/Module/System.hs --- a/src/Foreign/Lua/Module/System.hs +++ b/src/Foreign/Lua/Module/System.hs @@ -1,135 +1,114 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-| Module : Foreign.Lua.Module.System Copyright : © 2019 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : alpha -Portability : Requires language extensions ForeignFunctionInterface, - OverloadedStrings. +Portability : Requires GHC 8 or later. Provide a Lua module containing a selection of @'System'@ functions. -} -module Foreign.Lua.Module.System - ( pushModule +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.Exception (IOException, catch, evaluate, try) +import Control.Monad (forM_) +import Control.Monad.Catch (bracket) import Data.Maybe (fromMaybe) -import Foreign.Lua (Lua, NumResults(..), Optional (..), Peekable, Pushable, - StackIndex, ToHaskellFunction) -import System.IO.Error (IOError, isDoesNotExistError) +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 --- | Pushes the @text@ module to the lua stack. +-- +-- Module +-- + +-- | Pushes the @system@ module to the Lua stack. pushModule :: Lua NumResults pushModule = do Lua.newtable - addFunction "chdir" chdir - addFunction "currentdir" currentdir + addField "arch" arch + addField "compiler_name" compiler_name + addField "compiler_version" compiler_version + addField "os" os addFunction "env" env addFunction "getenv" getenv + addFunction "getwd" getwd addFunction "ls" ls - addFunction "pwd" currentdir + addFunction "mkdir" mkdir + addFunction "rmdir" rmdir addFunction "setenv" setenv + addFunction "setwd" setwd addFunction "tmpdirname" tmpdirname + addFunction "with_env" with_env addFunction "with_tmpdir" with_tmpdir + addFunction "with_wd" with_wd return 1 --- | Add the text module under the given name to the table of preloaded --- packages. +-- | Add the @system@ module under the given name to the table of +-- preloaded packages. preloadModule :: String -> Lua () preloadModule = flip addPackagePreloader pushModule --- | Registers a preloading function. Takes an module name and the Lua --- operation which produces the package. -addPackagePreloader :: String -> Lua NumResults -> Lua () -addPackagePreloader name modulePusher = do - Lua.getfield Lua.registryindex Lua.preloadTableRegistryField - Lua.pushHaskellFunction modulePusher - Lua.setfield (-2) name - Lua.pop 1 --- | Attach a function to the table at the top of the stack, using the --- given name. -addFunction :: ToHaskellFunction a => String -> a -> Lua () -addFunction name fn = do - Lua.push name - Lua.pushHaskellFunction fn - Lua.rawset (-3) +-- +-- Fields +-- --- | Lua callback function -newtype Callback = Callback { callbackStackIndex :: StackIndex } +-- | The machine architecture on which the program is running. +arch :: String +arch = Info.arch -instance Peekable Callback where - peek idx = do - isFn <- Lua.isfunction idx - if isFn - then return (Callback idx) - else Lua.throwException "Function expected" +-- | The Haskell implementation with which the host program was +-- compiled. +compiler_name :: String +compiler_name = Info.compilerName -instance Pushable Callback where - push (Callback idx) = Lua.pushvalue idx +-- | The version of `compiler_name` with which the host program was +-- compiled. +compiler_version :: [Int] +compiler_version = versionBranch Info.compilerVersion +-- | The operating system on which the program is running. +os :: String +os = Info.os --- | Any value of unknown type -newtype AnyValue = AnyValue { fromAnyValue :: StackIndex } -instance Peekable AnyValue where - peek = return . AnyValue - -instance Pushable AnyValue where - push (AnyValue idx) = Lua.pushvalue idx - -with_tmpdir :: String -- ^ parent dir or template - -> AnyValue -- ^ template or callback - -> Optional Callback -- ^ callback or nil - -> Lua NumResults -with_tmpdir parentDir tmpl callback = do - case fromOptional 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' = parentDir - callback' <- Lua.peek (fromAnyValue tmpl) - Temp.withSystemTempDirectory tmpl' (callWithFilename callback') - Just callback' -> do - -- all args given. Second value must be converted to a string. - tmpl' <- Lua.peek (fromAnyValue tmpl) - Temp.withTempDirectory parentDir tmpl' (callWithFilename callback') - --- | Call Lua callback function with the given filename as its argument. -callWithFilename :: Callback -> FilePath -> Lua NumResults -callWithFilename callback filename = do - oldTop <- Lua.gettop - Lua.push callback - Lua.push filename - Lua.call (Lua.NumArgs 1) Lua.multret - newTop <- Lua.gettop - return . NumResults . fromIntegral . Lua.fromStackIndex $ - newTop - oldTop - --- | List the contents of a directory. -ls :: Optional FilePath -> Lua [FilePath] -ls fp = do - let fp' = fromMaybe "." (fromOptional fp) - ioToLua (Directory.listDirectory fp') - --- | Change current working directory. -chdir :: FilePath -> Lua () -chdir fp = ioToLua $ Directory.setCurrentDirectory fp - --- | Return the current working directory. -currentdir :: Lua FilePath -currentdir = ioToLua Directory.getCurrentDirectory +-- +-- Functions +-- -- | Retrieve the entire environment env :: Lua NumResults @@ -140,22 +119,90 @@ mapM_ addValue kvs return (NumResults 1) +-- | Return the current working directory as an absolute path. +getwd :: Lua FilePath +getwd = ioToLua Directory.getCurrentDirectory + -- | Returns the value of an environment variable getenv :: String -> Lua (Optional String) getenv name = ioToLua (Optional <$> Env.lookupEnv name) +-- | List the contents of a directory. +ls :: Optional FilePath -> Lua [FilePath] +ls fp = do + let fp' = fromMaybe "." (fromOptional fp) + ioToLua (Directory.listDirectory 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 fp createParent = + if createParent + then ioToLua (Directory.createDirectoryIfMissing True fp) + else ioToLua (Directory.createDirectory fp) + +-- | Remove an existing directory. +rmdir :: FilePath -> Bool -> Lua () +rmdir fp recursive = + if recursive + then ioToLua (Directory.removeDirectoryRecursive fp) + else ioToLua (Directory.removeDirectory fp) + -- | Set the specified environment variable to a new value. setenv :: String -> String -> Lua () setenv name value = ioToLua (Env.setEnv name value) +-- | Change current working directory. +setwd :: FilePath -> Lua () +setwd fp = ioToLua $ Directory.setCurrentDirectory fp + -- | Get the current directory for temporary files. tmpdirname :: Lua FilePath tmpdirname = ioToLua Directory.getTemporaryDirectory --- | Convert a System IO operation to a Lua operation. -ioToLua :: IO a -> Lua a -ioToLua action = do - result <- Lua.liftIO (try action) - case result of - Right result' -> return result' - Left err -> Lua.throwException (show (err :: IOException)) +-- | Run an action in a different directory, then restore the old +-- working directory. +with_wd :: FilePath -> Callback -> Lua NumResults +with_wd fp callback = + bracket (Lua.liftIO Directory.getCurrentDirectory) + (Lua.liftIO . Directory.setCurrentDirectory) + $ \_ -> do + Lua.liftIO (Directory.setCurrentDirectory fp) + callback `invokeWithFilePath` fp + + +-- | Run an action, then restore the old environment variable values. +with_env :: Map.Map String String -> Callback -> Lua NumResults +with_env environment callback = + bracket (Lua.liftIO Env.getEnvironment) + setEnvironment + (\_ -> setEnvironment (Map.toList environment) >> invoke callback) + where + setEnvironment newEnv = Lua.liftIO $ do + -- Crude, but fast enough: delete all entries in new environment, + -- then restore old environment one-by-one. + curEnv <- Env.getEnvironment + forM_ curEnv (Env.unsetEnv . fst) + forM_ newEnv (uncurry Env.setEnv) + +with_tmpdir :: String -- ^ parent dir or template + -> AnyValue -- ^ template or callback + -> Optional Callback -- ^ callback or nil + -> Lua NumResults +with_tmpdir parentDir tmpl callback = + case fromOptional 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' = parentDir + callback' <- Lua.peek (fromAnyValue tmpl) + Temp.withSystemTempDirectory tmpl' (invokeWithFilePath callback') + Just callback' -> do + -- all args given. Second value must be converted to a string. + tmpl' <- Lua.peek (fromAnyValue tmpl) + Temp.withTempDirectory parentDir tmpl' (invokeWithFilePath callback') diff --git a/src/Foreign/Lua/Module/SystemUtils.hs b/src/Foreign/Lua/Module/SystemUtils.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Module/SystemUtils.hs @@ -0,0 +1,103 @@ +{-| +Module : Foreign.Lua.Module.SystemUtils +Copyright : © 2019 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : Requires GHC 8 or later. + +Utility functions and types for HsLua's system module. +-} +module Foreign.Lua.Module.SystemUtils + ( AnyValue (..) + , Callback (..) + , addPackagePreloader + , addField + , addFunction + , invoke + , invokeWithFilePath + , ioToLua + ) +where + +import Control.Exception (IOException, try) +import Foreign.Lua (Lua, NumResults(..), Peekable, Pushable, + StackIndex, ToHaskellFunction) + +import qualified Foreign.Lua as Lua + +-- | Registers a preloading function. Takes an module name and the Lua +-- operation which produces the package. +addPackagePreloader :: String -> Lua NumResults -> Lua () +addPackagePreloader name modulePusher = do + Lua.getfield Lua.registryindex Lua.preloadTableRegistryField + Lua.pushHaskellFunction modulePusher + Lua.setfield (-2) name + Lua.pop 1 + +-- | Add a string-indexed field to the table at the top of the stack. +addField :: Pushable a => String -> a -> Lua () +addField name value = do + Lua.push name + Lua.push value + Lua.rawset (Lua.nthFromTop 3) + +-- | Attach a function to the table at the top of the stack, using the +-- given name. +addFunction :: ToHaskellFunction a => String -> a -> Lua () +addFunction name fn = do + Lua.push name + Lua.pushHaskellFunction fn + Lua.rawset (-3) + +-- | Lua callback function +newtype Callback = Callback StackIndex + +instance Peekable Callback where + peek idx = do + isFn <- Lua.isfunction idx + if isFn + then return (Callback idx) + else Lua.throwException "Function expected" + +instance Pushable Callback where + push (Callback idx) = Lua.pushvalue idx + + +-- | Any value of unknown type +newtype AnyValue = AnyValue { fromAnyValue :: StackIndex } + +instance Peekable AnyValue where + peek = return . AnyValue + +instance Pushable AnyValue where + push (AnyValue idx) = Lua.pushvalue idx + +-- | Call Lua callback function and return all of its results. +invoke :: Callback -> Lua NumResults +invoke callback = do + oldTop <- Lua.gettop + Lua.push callback + Lua.call 0 Lua.multret + newTop <- Lua.gettop + return . NumResults . fromIntegral . Lua.fromStackIndex $ + newTop - oldTop + +-- | Call Lua callback function with the given filename as its argument. +invokeWithFilePath :: Callback -> FilePath -> Lua NumResults +invokeWithFilePath callback filename = do + oldTop <- Lua.gettop + Lua.push callback + Lua.push filename + Lua.call (Lua.NumArgs 1) Lua.multret + newTop <- Lua.gettop + return . NumResults . fromIntegral . Lua.fromStackIndex $ + newTop - oldTop + +-- | Convert a System IO operation to a Lua operation. +ioToLua :: IO a -> Lua a +ioToLua action = do + result <- Lua.liftIO (try action) + case result of + Right result' -> return result' + Left err -> Lua.throwException (show (err :: IOException)) diff --git a/test/system-module-tests.lua b/test/system-module-tests.lua --- a/test/system-module-tests.lua +++ b/test/system-module-tests.lua @@ -1,23 +1,16 @@ -- --- Tests for the hstext module +-- Tests for the system module -- local system = require 'system' -local token = 'Banana' -function write_read_token (tmpdir) - local filename = tmpdir .. '/foo.txt' - local fh = io.open(filename, 'w') - fh:write(token .. '\n') - fh:close() - return io.open(filename):read '*l' -end - --- with_tmpdir -assert(system.with_tmpdir('.', 'foo', write_read_token) == token) -assert(system.with_tmpdir('foo', write_read_token) == token) +-- Check existence static fields +assert(type(system.arch) == 'string') +assert(type(system.compiler_name) == 'string') +assert(type(system.compiler_version) == 'table') +assert(type(system.os) == 'string') --- tmpdirname -assert(type(system.tmpdirname()) == 'string', "tmpdirname should return a string") +-- getwd +assert(type(system.getwd()) == 'string') -- env assert(type(system.env()) == 'table') @@ -29,26 +22,84 @@ assert(pcall(system.ls, 'thisdoesnotexist') == false) assert(pcall(system.ls, 'README.md') == false) --- currentdir -assert(type(system.currentdir()) == 'string') --- pwd is an alias for currentdir -assert(system.currentdir() == system.pwd()) - - --- Complex scripts +-- mkdir and rmdir function in_tmpdir (callback) - local orig_dir = system.currentdir() + local orig_dir = system.getwd() return system.with_tmpdir( 'hello', function (tmpdir) - system.chdir(tmpdir) + system.setwd(tmpdir) local result = callback(tmpdir) - system.chdir(orig_dir) + system.setwd(orig_dir) return result end ) end +function test_mkdir_rmdir () + -- mkdir + assert(not pcall(system.mkdir, '.'), "should not be possible to create `.`") + assert(pcall(system.mkdir, 'foo'), "normal dir creation") + assert(pcall(system.mkdir, 'foo', true), "dir creation if exists") + assert((system.ls())[1] == 'foo') + assert(not pcall(system.mkdir, 'bar/baz'), + "creation of nested dir") + assert(pcall(system.mkdir, 'bar/baz', true), + "nested dir creation, including parent directories") + assert((system.ls 'bar')[1] == 'baz') + + -- rmdir + assert(pcall(system.rmdir, 'foo'), "delete empty directory") + assert(not pcall(system.rmdir, 'bar'), "cannot delete non-empty dir") + assert(pcall(system.rmdir, 'bar', true), "delete dir recursively") + assert(#system.ls() == 0, "dir should be empty") +end +in_tmpdir(test_mkdir_rmdir) + +-- tmpdirname +assert(type(system.tmpdirname()) == 'string', "tmpdirname should return a string") + +-- with_env +local outer_value = 'outer test value' +local inner_value = 'inner test value' +local inner_only = 'test #2' + +function check_env () + assert(os.getenv 'SYSTEM_TEST' == inner_value, "env has test value") + assert(os.getenv 'SYSTEM_TEST_INNER_ONLY' == inner_only, + "inner only exists") + assert(os.getenv 'SYSTEM_TEST_OUTER_ONLY' == nil, + "outer only variable should be unset") +end + +local test_env = { + SYSTEM_TEST = inner_value, + SYSTEM_TEST_INNER_ONLY = inner_only +} +system.setenv('SYSTEM_TEST_OUTER_ONLY', outer_value) +system.setenv('SYSTEM_TEST', outer_value) +system.with_env(test_env, check_env) + +assert(system.getenv 'SYSTEM_TEST' == outer_value, "value was restored") +assert(system.getenv 'SYSTEM_TEST_INNER_ONLY' == nil, "value was restored") +assert(system.getenv 'SYSTEM_TEST_OUTER_ONLY' == outer_value, + "value was restored") + +-- with_tmpdir +local token = 'Banana' +function write_read_token (tmpdir) + local filename = tmpdir .. '/foo.txt' + local fh = io.open(filename, 'w') + fh:write(token .. '\n') + fh:close() + return io.open(filename):read '*l' +end + +assert(system.with_tmpdir('.', 'foo', write_read_token) == token) +assert(system.with_tmpdir('foo', write_read_token) == token) + + +-- Complex scripts function create_then_count_files () io.open('README.org', 'w'):close() return #system.ls '.' @@ -59,3 +110,15 @@ system.setenv('TESTING', token) assert(system.getenv 'TESTING' == token, 'setting and getting env var is inconsistent') + +-- with_wd +local cwd = system.getwd() +function check_wd (path) + assert(path == system.getwd(), "current path is given as arg") + assert(path ~= cwd, "current path has changed from original") +end + +system.with_tmpdir( + 'wd-test', + function (path) return system.with_wd(path, check_wd) end +) diff --git a/test/test-hslua-module-system.hs b/test/test-hslua-module-system.hs --- a/test/test-hslua-module-system.hs +++ b/test/test-hslua-module-system.hs @@ -28,18 +28,18 @@ [ testCase "system module can be pushed to the stack" $ Lua.run (void pushModule) - , testCase "text module can be added to the preloader" . Lua.run $ do + , testCase "system module can be added to the preloader" . Lua.run $ do Lua.openlibs preloadModule "system" assertEqual' "function not added to preloader" Lua.TypeFunction =<< do Lua.getglobal' "package.preload.system" Lua.ltype (-1) - , testCase "text module can be loaded as hstext" . Lua.run $ do + , testCase "system module can be loaded as hssystem" . Lua.run $ do Lua.openlibs - preloadModule "system" + preloadModule "hssystem" assertEqual' "loading the module fails " Lua.OK =<< - Lua.dostring "require 'system'" + Lua.dostring "require 'hssystem'" , testCase "Lua tests pass" . Lua.run $ do Lua.openlibs