hslua-module-system-0.2.1/0000755000000000000000000000000000000000000013562 5ustar0000000000000000hslua-module-system-0.2.1/CHANGELOG.md0000755000000000000000000000171700000000000015404 0ustar0000000000000000# Revision history for hslua-module-system ## 0.2.1 -- 2019-05-04 - Use module helpers made available with HsLua 1.0.3. This avoids code duplication when used with other hslua modules. ## 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. hslua-module-system-0.2.1/LICENSE0000644000000000000000000000204400000000000014567 0ustar0000000000000000Copyright (c) 2019 Albert Krewinkel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hslua-module-system-0.2.1/Setup.hs0000644000000000000000000000005600000000000015217 0ustar0000000000000000import Distribution.Simple main = defaultMain hslua-module-system-0.2.1/hslua-module-system.cabal0000644000000000000000000000425000000000000020470 0ustar0000000000000000name: hslua-module-system version: 0.2.1 synopsis: Lua module wrapper around Haskell's System module. description: Provides access to system information and functionality to Lua scripts via Haskell's `System` module. . Intended usage for this package is to preload it by adding the loader function to `package.preload`. Note that the Lua `package` library must have already been loaded before the loader can be added. homepage: https://github.com/hslua/hslua-module-system license: MIT license-file: LICENSE author: Albert Krewinkel maintainer: albert+hslua@zeitkraut.de copyright: Albert Krewinkel category: Foreign build-type: Simple 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 location: https://github.com/hslua/hslua-module-system.git library build-depends: base >= 4.9 && < 5 , containers >= 0.5 && < 0.7 , directory >= 1.3 && < 1.4 , exceptions >= 0.8 && < 0.11 , hslua >= 1.0.3 && < 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 test-suite test-hslua-module-system default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: test-hslua-module-system.hs hs-source-dirs: test ghc-options: -Wall -threaded build-depends: base , hslua , hslua-module-system , tasty , tasty-hunit , text hslua-module-system-0.2.1/src/Foreign/Lua/Module/0000755000000000000000000000000000000000000017710 5ustar0000000000000000hslua-module-system-0.2.1/src/Foreign/Lua/Module/System.hs0000644000000000000000000001372000000000000021533 0ustar0000000000000000{-| Module : Foreign.Lua.Module.System Copyright : © 2019 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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 = do Lua.newtable Lua.addfield "arch" arch Lua.addfield "compiler_name" compiler_name Lua.addfield "compiler_version" compiler_version Lua.addfield "os" os Lua.addfunction "env" env Lua.addfunction "getenv" getenv Lua.addfunction "getwd" getwd Lua.addfunction "ls" ls Lua.addfunction "mkdir" mkdir Lua.addfunction "rmdir" rmdir Lua.addfunction "setenv" setenv Lua.addfunction "setwd" setwd Lua.addfunction "tmpdirname" tmpdirname Lua.addfunction "with_env" with_env Lua.addfunction "with_tmpdir" with_tmpdir Lua.addfunction "with_wd" with_wd return 1 -- | Add the @system@ module under the given name to the table of -- preloaded packages. preloadModule :: String -> Lua () preloadModule = flip Lua.preloadhs pushModule -- -- Fields -- -- | The machine architecture on which the program is running. arch :: String arch = Info.arch -- | The Haskell implementation with which the host program was -- compiled. compiler_name :: String compiler_name = Info.compilerName -- | 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 -- -- Functions -- -- | Retrieve the entire environment env :: Lua NumResults env = do kvs <- ioToLua Env.getEnvironment let addValue (k, v) = Lua.push k *> Lua.push v *> Lua.rawset (-3) Lua.newtable 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 -- | 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') hslua-module-system-0.2.1/src/Foreign/Lua/Module/SystemUtils.hs0000644000000000000000000000400000000000000022543 0ustar0000000000000000{-| 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 (..) , invoke , invokeWithFilePath , ioToLua ) where import Control.Exception (IOException, try) import Foreign.Lua (Lua, NumResults(..), Peekable, Pushable, StackIndex) import qualified Foreign.Lua as Lua -- | 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)) hslua-module-system-0.2.1/test/0000755000000000000000000000000000000000000014541 5ustar0000000000000000hslua-module-system-0.2.1/test/system-module-tests.lua0000755000000000000000000000712000000000000021216 0ustar0000000000000000-- -- Tests for the system module -- local system = require 'system' -- 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') -- getwd assert(type(system.getwd()) == 'string') -- env assert(type(system.env()) == 'table') -- ls assert(type(system.ls('.')) == 'table') assert(#system.ls('.') == #system.ls()) -- ls should fail when called on files or non-existent directories assert(pcall(system.ls, 'thisdoesnotexist') == false) assert(pcall(system.ls, 'README.md') == false) -- mkdir and rmdir function in_tmpdir (callback) local orig_dir = system.getwd() return system.with_tmpdir( 'hello', function (tmpdir) system.setwd(tmpdir) local result = callback(tmpdir) 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 '.' end assert(in_tmpdir(create_then_count_files) == 1, 'Number of files should be 1') 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 ) hslua-module-system-0.2.1/test/test-hslua-module-system.hs0000644000000000000000000000334600000000000022001 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : Main Copyright : © 2019 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : alpha Portability : Requires language extensions ForeignFunctionInterface, OverloadedStrings. Tests for the `system` Lua module. -} import Control.Monad (void, when) import Foreign.Lua (Lua) import Foreign.Lua.Module.System (preloadModule, pushModule) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertEqual, testCase) import qualified Foreign.Lua as Lua main :: IO () main = defaultMain $ testGroup "hslua-module-system" [tests] -- | HSpec tests for the Lua 'system' module tests :: TestTree tests = testGroup "HsLua System module" [ testCase "system module can be pushed to the stack" $ Lua.run (void pushModule) , 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 "system module can be loaded as hssystem" . Lua.run $ do Lua.openlibs preloadModule "hssystem" assertEqual' "loading the module fails " Lua.OK =<< Lua.dostring "require 'hssystem'" , testCase "Lua tests pass" . Lua.run $ do Lua.openlibs preloadModule "system" assertEqual' "error while running lua tests" Lua.OK =<< do st <- Lua.loadfile "test/system-module-tests.lua" when (st == Lua.OK) $ Lua.call 0 0 return st ] assertEqual' :: (Show a, Eq a) => String -> a -> a -> Lua () assertEqual' msg expected = Lua.liftIO . assertEqual msg expected