hslua-module-system 0.1.0.1 → 0.2.0

raw patch · 6 files changed

+375/−129 lines, 6 filesdep +containersdep +exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, exceptions

API changes (from Hackage documentation)

Files

• CHANGELOG.md +30/−1
• hslua-module-system.cabal +6/−2
• src/Foreign/Lua/Module/System.hs +144/−97
• src/Foreign/Lua/Module/SystemUtils.hs +103/−0
• test/system-module-tests.lua +88/−25
• test/test-hslua-module-system.hs +4/−4

@@ -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.

@@ -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 

@@ -1,135 +1,114 @@-{-# LANGUAGE ScopedTypeVariables #-} {-| Module      : Foreign.Lua.Module.System Copyright   : © 2019 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <albert+hslua@zeitkraut.de> 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')

@@ -0,0 +1,103 @@+{-|+Module      : Foreign.Lua.Module.SystemUtils+Copyright   : © 2019 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <albert+hslua@zeitkraut.de>+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))

@@ -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+)

@@ -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