This repository was archived by the owner on Mar 22, 2021. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 1
Expand file tree
/
Copy pathSystem.hs
More file actions
207 lines (178 loc) · 5.96 KB
/
System.hs
File metadata and controls
207 lines (178 loc) · 5.96 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
{-|
Module : Foreign.Lua.Module.System
Copyright : © 2019-2020 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 = 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')