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
|
-- |
-- 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
, Name
, Value(..)
, query
, engrave
, wipe
, pathJoin
, pathSplit
, expand
, pathSplitAndExpand
, ExpandedPath(..)
, pathOriginal
, pathExpanded
, pathExists
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT(..), catchE, throwE)
import Data.List (intercalate)
import Data.List.Split (splitOn)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Storable (sizeOf)
import System.Directory (doesDirectoryExist)
import System.IO.Error (catchIOError, isDoesNotExistError)
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 Name = String
data Value = Value
{ valueExpandable :: Bool
, valueString :: String
} deriving (Eq, Show)
valueFromRegistry :: Registry.StringValue -> Value
valueFromRegistry (valueType, valueData)
| valueType == Registry.TypeString = Value False valueData
| valueType == Registry.TypeExpandableString = Value True valueData
| otherwise = error "WindowsEnv.Environment: unexpected"
valueToRegistry :: Value -> Registry.StringValue
valueToRegistry value
| valueExpandable value = (Registry.TypeExpandableString, valueString value)
| otherwise = (Registry.TypeString, valueString value)
query :: Profile -> Name -> ExceptT IOError IO Value
query profile name = valueFromRegistry <$> Registry.getStringValue (profileKeyPath profile) name
engrave :: Profile -> Name -> Value -> ExceptT IOError IO ()
engrave profile name value = do
ret <- Registry.setStringValue (profileKeyPath profile) name $ valueToRegistry value
lift notifyEnvironmentUpdate
return ret
wipe :: Profile -> Name -> ExceptT IOError IO ()
wipe profile name = do
ret <- Registry.deleteValue (profileKeyPath profile) name `catchE` ignoreIfMissing
lift notifyEnvironmentUpdate
return ret
where
ignoreIfMissing e
| isDoesNotExistError e = return ()
| otherwise = throwE e
pathSep :: String
pathSep = ";"
pathSplit :: String -> [String]
pathSplit = filter (not . null) . splitOn pathSep
pathJoin :: [String] -> String
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 :: String -> ExceptT IOError IO String
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 = UnexpandedPath String
| ExpandedPath String String
deriving (Eq, Show)
pathOriginal :: ExpandedPath -> String
pathOriginal (UnexpandedPath path) = path
pathOriginal (ExpandedPath original _) = original
pathExpanded :: ExpandedPath -> String
pathExpanded (UnexpandedPath path) = path
pathExpanded (ExpandedPath _ expanded) = expanded
pathExists :: ExpandedPath -> IO Bool
pathExists = doesDirectoryExist . pathExpanded
pathSplitAndExpand :: Value -> ExceptT IOError IO [ExpandedPath]
pathSplitAndExpand value
| valueExpandable value = do
expanded <- expandOnce
zipWith ExpandedPath split <$>
if length expanded == length split
then return expanded
else expandEach
| otherwise = return $ map UnexpandedPath $ pathSplit joined
where
joined = valueString value
split = pathSplit joined
expandOnce = pathSplit <$> expand joined
expandEach = mapM expand split
|
