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
|
-- |
-- Description : High-level environment variables management functions
-- Copyright : (c) 2015 Egor Tensin <Egor.Tensin@gmail.com>
-- License : MIT
-- Maintainer : Egor.Tensin@gmail.com
-- Stability : experimental
-- Portability : Windows-only
--
-- High-level functions for reading and writing Windows environment variables.
{-# LANGUAGE CPP #-}
module WindowsEnv.Environment
( Profile(..)
, profileKeyPath
, VarName
, VarValue
, query
, engrave
, engraveForce
, wipe
, pathJoin
, pathSplit
, expand
, ExpandedPath(..)
, pathSplitAndExpand
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT(..))
import Data.List (intercalate)
import Data.List.Split (splitOn)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Storable (sizeOf)
import System.IO.Error (catchIOError)
import qualified System.Win32.Types as WinAPI
import qualified WindowsEnv.Registry as Registry
import WindowsEnv.Utils (notifyEnvironmentUpdate)
data Profile = CurrentUser
| AllUsers
deriving (Eq, Show)
profileKeyPath :: Profile -> Registry.KeyPath
profileKeyPath CurrentUser = Registry.KeyPath Registry.CurrentUser ["Environment"]
profileKeyPath AllUsers = Registry.KeyPath Registry.LocalMachine
[ "SYSTEM"
, "CurrentControlSet"
, "Control"
, "Session Manager"
, "Environment"
]
type VarName = String
type VarValue = String
query :: Profile -> VarName -> ExceptT IOError IO VarValue
query profile name = Registry.getStringDoNotExpand (profileKeyPath profile) name
engrave :: Profile -> VarName -> VarValue -> ExceptT IOError IO ()
engrave profile name value = do
ret <- Registry.setStringPreserveType (profileKeyPath profile) name value
lift notifyEnvironmentUpdate
return ret
engraveForce :: Profile -> VarName -> VarValue -> ExceptT IOError IO ()
engraveForce profile name value = do
ret <- Registry.setString (profileKeyPath profile) name value
lift notifyEnvironmentUpdate
return ret
wipe :: Profile -> VarName -> ExceptT IOError IO ()
wipe profile name = do
ret <- Registry.deleteValue (profileKeyPath profile) name
lift notifyEnvironmentUpdate
return ret
pathSep :: VarValue
pathSep = ";"
pathSplit :: VarValue -> [VarValue]
pathSplit = filter (not . null) . splitOn pathSep
pathJoin :: [VarValue] -> VarValue
pathJoin = intercalate pathSep . filter (not . null)
#include "ccall.h"
-- ExpandEnvironmentStrings isn't provided by Win32 (as of version 2.4.0.0).
foreign import WINDOWS_ENV_CCALL unsafe "Windows.h ExpandEnvironmentStringsW"
c_ExpandEnvironmentStrings :: WinAPI.LPCTSTR -> WinAPI.LPTSTR -> WinAPI.DWORD -> IO WinAPI.ErrCode
expand :: VarValue -> ExceptT IOError IO VarValue
expand value = ExceptT $ catchIOError (Right <$> doExpand) (return . Left)
where
doExpandIn valuePtr bufferPtr bufferLength = do
newBufferLength <- WinAPI.failIfZero "ExpandEnvironmentStringsW" $
c_ExpandEnvironmentStrings valuePtr bufferPtr bufferLength
let newBufferSize = (fromIntegral newBufferLength) * sizeOf (undefined :: WinAPI.TCHAR)
if newBufferLength > bufferLength
then allocaBytes newBufferSize $ \newBufferPtr -> doExpandIn valuePtr newBufferPtr newBufferLength
else WinAPI.peekTString bufferPtr
doExpand = WinAPI.withTString value $ \valuePtr -> doExpandIn valuePtr WinAPI.nullPtr 0
data ExpandedPath = ExpandedPath
{ pathOriginal :: VarValue
, pathExpanded :: VarValue
} deriving (Eq, Show)
pathSplitAndExpand :: VarValue -> ExceptT IOError IO [ExpandedPath]
pathSplitAndExpand pathValue = do
expandedOnce <- expandOnce
zipWith ExpandedPath originalPaths <$>
if length expandedOnce == length originalPaths
then return expandedOnce
else expandEach
where
originalPaths = pathSplit pathValue
expandOnce = pathSplit <$> expand pathValue
expandEach = mapM expand originalPaths
|
