From f1a4c2b98f1707c09e17ddd07cb25d6e1cfe4022 Mon Sep 17 00:00:00 2001 From: Egor Tensin Date: Mon, 12 Dec 2016 20:43:42 +0300 Subject: use monad transformers --- apps/AddPath.hs | 32 ++++++++++++++++++-------------- apps/RemovePath.hs | 26 ++++++++++++++++---------- apps/SetEnv.hs | 7 ++++++- apps/UnsetEnv.hs | 7 ++++++- src/Windows/Environment.hs | 27 +++++++++++++++------------ src/Windows/Registry.hs | 40 +++++++++++++++++++--------------------- windows-env.cabal | 6 +++++- 7 files changed, 85 insertions(+), 60 deletions(-) diff --git a/apps/AddPath.hs b/apps/AddPath.hs index a32244c..2f1870c 100644 --- a/apps/AddPath.hs +++ b/apps/AddPath.hs @@ -7,6 +7,8 @@ module Main (main) where import Control.Monad (void, when) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except import Data.List (union) import System.IO.Error (ioError, isDoesNotExistError) @@ -52,16 +54,8 @@ main = execParser parser >>= addPath addPath :: Options -> IO () addPath options = do - oldValue <- Env.query profile varName >>= emptyIfMissing - let oldPaths = Env.pathSplit oldValue - let newPaths = oldPaths `union` pathsToAdd - when (length oldPaths /= length newPaths) $ do - let newValue = Env.pathJoin newPaths - let promptAnd = if skipPrompt - then withoutPrompt - else withPrompt $ engraveMessage profile varName oldValue newValue - let engrave = Env.engrave profile varName newValue - void $ promptAnd engrave + ret <- runExceptT $ doAddPath + either ioError return ret where varName = optName options pathsToAdd = optPaths options @@ -73,7 +67,17 @@ addPath options = do skipPrompt = optYes options - emptyIfMissing (Left e) - | isDoesNotExistError e = return "" - | otherwise = ioError e - emptyIfMissing (Right s) = return s + emptyIfMissing e | isDoesNotExistError e = return "" + | otherwise = throwE e + + doAddPath = do + oldValue <- Env.query profile varName `catchE` emptyIfMissing + let oldPaths = Env.pathSplit oldValue + let newPaths = oldPaths `union` pathsToAdd + when (length oldPaths /= length newPaths) $ do + let newValue = Env.pathJoin newPaths + let promptAnd = if skipPrompt + then withoutPrompt + else withPrompt $ engraveMessage profile varName oldValue newValue + let engrave = Env.engrave profile varName newValue + lift $ void $ promptAnd $ runExceptT engrave diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs index eb1cb00..02bda10 100644 --- a/apps/RemovePath.hs +++ b/apps/RemovePath.hs @@ -7,6 +7,8 @@ module Main (main) where import Control.Monad (void, when) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except import Data.List ((\\)) import System.IO.Error (ioError, isDoesNotExistError) @@ -52,9 +54,8 @@ main = execParser parser >>= removePath removePath :: Options -> IO () removePath options = do - removePathFrom Env.CurrentUser - when forAllUsers $ - removePathFrom Env.AllUsers + ret <- runExceptT $ doRemovePath + either ioError return ret where varName = optName options pathsToRemove = optPaths options @@ -63,13 +64,18 @@ removePath options = do skipPrompt = optYes options - removePathFrom profile = do - oldValue <- Env.query profile varName - either ignoreMissing (doRemovePathFrom profile) oldValue - ignoreMissing e - | isDoesNotExistError e = return () - | otherwise = ioError e + | isDoesNotExistError e = return "" + | otherwise = throwE e + + doRemovePath = do + removePathFrom Env.CurrentUser + when forAllUsers $ + removePathFrom Env.AllUsers + + removePathFrom profile = do + oldValue <- Env.query profile varName `catchE` ignoreMissing + doRemovePathFrom profile oldValue doRemovePathFrom profile oldValue = do let oldPaths = Env.pathSplit oldValue @@ -80,4 +86,4 @@ removePath options = do then withoutPrompt else withPrompt $ engraveMessage profile varName oldValue newValue let engrave = Env.engrave profile varName newValue - void $ promptAnd engrave + lift $ void $ promptAnd $ runExceptT engrave diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs index 96ef7b1..2f3b8f7 100644 --- a/apps/SetEnv.hs +++ b/apps/SetEnv.hs @@ -7,6 +7,9 @@ module Main (main) where import Control.Monad (void) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import System.IO.Error (ioError) import Options.Applicative import qualified Windows.Environment as Env @@ -48,7 +51,9 @@ main = execParser parser >>= setEnv fullDesc <> progDesc "Set environment variables" setEnv :: Options -> IO () -setEnv options = void $ promptAnd engrave +setEnv options = do + ret <- runExceptT $ lift $ void $ promptAnd $ runExceptT engrave + either ioError return ret where varName = optName options varValue = optValue options diff --git a/apps/UnsetEnv.hs b/apps/UnsetEnv.hs index 2ca0997..d56d40c 100644 --- a/apps/UnsetEnv.hs +++ b/apps/UnsetEnv.hs @@ -7,6 +7,9 @@ module Main (main) where import Control.Monad (void) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import System.IO.Error (ioError) import Options.Applicative import qualified Windows.Environment as Env @@ -43,7 +46,9 @@ main = execParser parser >>= unsetEnv fullDesc <> progDesc "Unset environment variables" unsetEnv :: Options -> IO () -unsetEnv options = void $ promptAnd wipe +unsetEnv options = do + ret <- runExceptT $ lift $ void $ promptAnd $ runExceptT wipe + either ioError return ret where varName = optName options diff --git a/src/Windows/Environment.hs b/src/Windows/Environment.hs index 8597d42..0399d5b 100644 --- a/src/Windows/Environment.hs +++ b/src/Windows/Environment.hs @@ -20,9 +20,10 @@ module Windows.Environment , pathSplit ) where -import Control.Exception (finally) -import Data.List (intercalate) -import Data.List.Split (splitOn) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT(..)) +import Data.List (intercalate) +import Data.List.Split (splitOn) import qualified Windows.Registry as Registry import Windows.Utils (notifyEnvironmentUpdate) @@ -44,18 +45,20 @@ profileKeyPath AllUsers = Registry.KeyPath Registry.LocalMachine type VarName = String type VarValue = String -query :: Profile -> VarName -> IO (Either IOError VarValue) +query :: Profile -> VarName -> ExceptT IOError IO VarValue query profile name = Registry.getExpandedString (profileKeyPath profile) name -engrave :: Profile -> VarName -> VarValue -> IO (Either IOError ()) -engrave profile name value = finally doEngrave notifyEnvironmentUpdate - where - doEngrave = Registry.setStringPreserveType (profileKeyPath profile) name value +engrave :: Profile -> VarName -> VarValue -> ExceptT IOError IO () +engrave profile name value = do + ret <- Registry.setStringPreserveType (profileKeyPath profile) name value + lift notifyEnvironmentUpdate + return ret -wipe :: Profile -> VarName -> IO (Either IOError ()) -wipe profile name = finally doWipe notifyEnvironmentUpdate - where - doWipe = Registry.deleteValue (profileKeyPath profile) name +wipe :: Profile -> VarName -> ExceptT IOError IO () +wipe profile name = do + ret <- Registry.deleteValue (profileKeyPath profile) name + lift notifyEnvironmentUpdate + return ret pathSep :: VarValue pathSep = ";" diff --git a/src/Windows/Registry.hs b/src/Windows/Registry.hs index c0ead17..5203fb8 100644 --- a/src/Windows/Registry.hs +++ b/src/Windows/Registry.hs @@ -6,8 +6,6 @@ -- -- Low-level utility functions for reading and writing registry values. -{-# OPTIONS_GHC -XTupleSections #-} - module Windows.Registry ( IsKeyPath(..) , RootKey(..) @@ -45,6 +43,7 @@ import Data.Tuple (swap) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf16LE, encodeUtf16LE) import Control.Exception (bracket) +import Control.Monad.Trans.Except (ExceptT(..), catchE, throwE) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Alloc (alloca, allocaBytes) import Foreign.Marshal.Array (peekArray, pokeArray) @@ -138,10 +137,10 @@ decodeString (_, bytes) = T.unpack dropLastZero | T.last text == '\0' = T.init text | otherwise = text -openCloseCatch :: IsKeyPath a => a -> (Handle -> IO b) -> IO (Either IOError b) -openCloseCatch keyPath f = catchIOError (fmap Right openClose) $ return . Left +openCloseCatch :: IsKeyPath a => a -> (Handle -> IO b) -> ExceptT IOError IO b +openCloseCatch keyPath f = ExceptT $ catchIOError (openApplyClose >>= return . Right) $ return . Left where - openClose = bracket (openUnsafe keyPath) close f + openApplyClose = bracket (openUnsafe keyPath) close f foreign import ccall unsafe "Windows.h RegQueryValueExW" c_RegQueryValueEx :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPDWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode @@ -152,7 +151,7 @@ foreign import ccall unsafe "Windows.h RegSetValueExW" foreign import ccall unsafe "Windows.h RegGetValueW" c_RegGetValue :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPCTSTR -> WinAPI.DWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode -queryValue :: IsKeyPath a => a -> ValueName -> IO (Either IOError ValueData) +queryValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueData queryValue keyPath valueName = openCloseCatch keyPath $ \keyHandle -> withForeignPtr keyHandle $ \keyHandlePtr -> @@ -170,7 +169,7 @@ queryValue keyPath valueName = valueType <- toEnum . fromIntegral <$> peek valueTypePtr return (valueType, buffer) -queryType :: IsKeyPath a => a -> ValueName -> IO (Either IOError ValueType) +queryType :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueType queryType keyPath valueName = openCloseCatch keyPath $ \keyHandle -> withForeignPtr keyHandle $ \keyHandlePtr -> @@ -209,7 +208,7 @@ getValueFlagsTable = , (DoNotExpand, 0x10000000) ] -getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> IO (Either IOError ValueData) +getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueData getValue keyPath valueName flags = openCloseCatch keyPath $ \keyHandle -> withForeignPtr keyHandle $ \keyHandlePtr -> @@ -230,7 +229,7 @@ getValue keyPath valueName flags = where rawFlags = fromIntegral $ foldr (.|.) 0 $ map fromEnum flags -getType :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> IO (Either IOError ValueType) +getType :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueType getType keyPath valueName flags = openCloseCatch keyPath $ \keyHandle -> withForeignPtr keyHandle $ \keyHandlePtr -> @@ -243,12 +242,12 @@ getType keyPath valueName flags = where rawFlags = fromIntegral $ foldr (.|.) 0 $ map fromEnum $ DoNotExpand : flags -getExpandedString :: IsKeyPath a => a -> ValueName -> IO (Either IOError String) +getExpandedString :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String getExpandedString keyPath valueName = do valueData <- getValue keyPath valueName [RestrictString, RestrictExpandableString] - return $ fmap decodeString valueData + return $ decodeString valueData -setValue :: IsKeyPath a => a -> ValueName -> ValueData -> IO (Either IOError ()) +setValue :: IsKeyPath a => a -> ValueName -> ValueData -> ExceptT IOError IO () setValue keyPath valueName (valueType, valueData) = openCloseCatch keyPath $ \keyHandle -> withForeignPtr keyHandle $ \keyHandlePtr -> @@ -262,24 +261,23 @@ setValue keyPath valueName (valueType, valueData) = buffer = B.unpack valueData bufferSize = B.length valueData -setString :: IsKeyPath a => a -> ValueName -> String -> IO (Either IOError ()) +setString :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () setString keyPath valueName valueData = setValue keyPath valueName (TypeString, encodeString valueData) -setExpandableString :: IsKeyPath a => a -> ValueName -> String -> IO (Either IOError ()) +setExpandableString :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () setExpandableString keyPath valueName valueData = setValue keyPath valueName (TypeExpandableString, encodeString valueData) -setStringPreserveType :: IsKeyPath a => a -> ValueName -> String -> IO (Either IOError ()) +setStringPreserveType :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO () setStringPreserveType keyPath valueName valueData = do - valueType <- stringIfMissing <$> getType keyPath valueName [RestrictString, RestrictExpandableString] - either (return . Left) (setValue keyPath valueName . (, encodeString valueData)) valueType + valueType <- getType keyPath valueName [RestrictString, RestrictExpandableString] `catchE` stringByDefault + setValue keyPath valueName (valueType, encodeString valueData) where - stringIfMissing (Left e) | isDoesNotExistError e = Right TypeString - | otherwise = Left e - stringIfMissing (Right x) = Right x + stringByDefault e | isDoesNotExistError e = return TypeString + | otherwise = throwE e -deleteValue :: IsKeyPath a => a -> ValueName -> IO (Either IOError ()) +deleteValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO () deleteValue keyPath valueName = openCloseCatch keyPath $ \keyHandle -> withForeignPtr keyHandle $ \keyHandlePtr -> diff --git a/windows-env.cabal b/windows-env.cabal index aee69dc..98f4e3d 100644 --- a/windows-env.cabal +++ b/windows-env.cabal @@ -18,7 +18,7 @@ library exposed-modules: Windows.Environment other-modules: Windows.Registry, Windows.Utils ghc-options: -Wall -Werror - build-depends: base, bytestring, split, text, Win32 + build-depends: base, bytestring, split, text, transformers, Win32 default-language: Haskell2010 executable addpath @@ -28,6 +28,7 @@ executable addpath ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , optparse-applicative + , transformers , windows-env default-language: Haskell2010 @@ -48,6 +49,7 @@ executable delpath ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , optparse-applicative + , transformers , windows-env default-language: Haskell2010 @@ -58,6 +60,7 @@ executable setenv ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , optparse-applicative + , transformers , windows-env default-language: Haskell2010 @@ -68,6 +71,7 @@ executable delenv ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , optparse-applicative + , transformers , windows-env default-language: Haskell2010 -- cgit v1.2.3