Allow XDG dirs to be overridden by env vars on Windows

Fixes #95.

System/Directory.hs

@@ -123,6 +123,7 @@ import System.FilePath
   , joinPath
   , makeRelative
   , splitDirectories
+  , splitSearchPath
   , takeDirectory
   )
 import Data.Time (UTCTime)
@@ -1504,8 +1505,10 @@ getHomeDirectory =
 --   Compared with 'getAppUserDataDirectory', this function provides a more
 --   fine-grained hierarchy as well as greater flexibility for the user.
 --
---   It also works on Windows, although in that case 'XdgData' and 'XdgConfig'
---   will map to the same directory.
+--   On Windows, 'XdgData' and 'XdgConfig' usually map to the same directory
+--   unless overridden.
+--
+--   Refer to the docs of 'XdgDirectory' for more details.
 --
 --   The second argument is usually the name of the application.  Since it
 --   will be integrated into the path, it must consist of valid path
@@ -1523,15 +1526,32 @@ getXdgDirectory :: XdgDirectory         -- ^ which special directory
                 -> IO FilePath
 getXdgDirectory xdgDir suffix =
   (`ioeAddLocation` "getXdgDirectory") `modifyIOError` do
-    simplify . (</> suffix) <$> getXdgDirectoryInternal getHomeDirectory xdgDir
+    simplify . (</> suffix) <$> do
+      env <- lookupEnv $ case xdgDir of
+        XdgData   -> "XDG_DATA_HOME"
+        XdgConfig -> "XDG_CONFIG_HOME"
+        XdgCache  -> "XDG_CACHE_HOME"
+      case env of
+        Nothing   -> getXdgDirectoryFallback getHomeDirectory xdgDir
+        Just path -> pure path
 
 -- | Similar to 'getXdgDirectory' but retrieves the entire list of XDG
 -- directories.
+--
+-- On Windows, 'XdgDataDirs' and 'XdgConfigDirs' usually map to the same list
+-- of directories unless overridden.
+--
+-- Refer to the docs of 'XdgDirectoryList' for more details.
 getXdgDirectoryList :: XdgDirectoryList -- ^ which special directory list
                     -> IO [FilePath]
 getXdgDirectoryList xdgDirs =
   (`ioeAddLocation` "getXdgDirectoryList") `modifyIOError` do
-    getXdgDirectoryListInternal xdgDirs
+    env <- lookupEnv $ case xdgDirs of
+      XdgDataDirs   -> "XDG_DATA_DIRS"
+      XdgConfigDirs -> "XDG_CONFIG_DIRS"
+    case env of
+      Nothing    -> getXdgDirectoryListFallback xdgDirs
+      Just paths -> pure (splitSearchPath paths)
 
 -- | Obtain the path to a special directory for storing user-specific
 --   application data (traditional Unix location).  Newer applications may

System/Directory/Internal/Common.hs

@@ -242,53 +242,59 @@ copyHandleData hFrom hTo =
         go buffer
 
 -- | Special directories for storing user-specific application data,
---   configuration, and cache files, as specified by the
---   <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.
+-- configuration, and cache files, as specified by the
+-- <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.
 --
---   Note: On Windows, 'XdgData' and 'XdgConfig' map to the same directory.
+-- Note: On Windows, 'XdgData' and 'XdgConfig' usually map to the same
+-- directory.
 --
---   @since 1.2.3.0
+-- @since 1.2.3.0
 data XdgDirectory
   = XdgData
     -- ^ For data files (e.g. images).
-    --   Defaults to @~\/.local\/share@ and can be
-    --   overridden by the @XDG_DATA_HOME@ environment variable.
-    --   On Windows, it is @%APPDATA%@
-    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).
-    --   Can be considered as the user-specific equivalent of @\/usr\/share@.
+    -- It uses the @XDG_DATA_HOME@ environment variable.
+    -- On non-Windows systems, the default is @~\/.local\/share@.
+    -- On Windows, the default is @%APPDATA%@
+    -- (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).
+    -- Can be considered as the user-specific equivalent of @\/usr\/share@.
   | XdgConfig
     -- ^ For configuration files.
-    --   Defaults to @~\/.config@ and can be
-    --   overridden by the @XDG_CONFIG_HOME@ environment variable.
-    --   On Windows, it is @%APPDATA%@
-    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).
-    --   Can be considered as the user-specific equivalent of @\/etc@.
+    -- It uses the @XDG_CONFIG_HOME@ environment variable.
+    -- On non-Windows systems, the default is @~\/.config@.
+    -- On Windows, the default is @%APPDATA%@
+    -- (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).
+    -- Can be considered as the user-specific equivalent of @\/etc@.
   | XdgCache
     -- ^ For non-essential files (e.g. cache).
-    --   Defaults to @~\/.cache@ and can be
-    --   overridden by the @XDG_CACHE_HOME@ environment variable.
-    --   On Windows, it is @%LOCALAPPDATA%@
-    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Local@).
-    --   Can be considered as the user-specific equivalent of @\/var\/cache@.
+    -- It uses the @XDG_CACHE_HOME@ environment variable.
+    -- On non-Windows systems, the default is @~\/.cache@.
+    -- On Windows, the default is @%LOCALAPPDATA%@
+    -- (e.g. @C:\/Users\//\<user\>/\/AppData\/Local@).
+    -- Can be considered as the user-specific equivalent of @\/var\/cache@.
   deriving (Bounded, Enum, Eq, Ord, Read, Show)
 
 -- | Search paths for various application data, as specified by the
---   <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.
+-- <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.
 --
---   Note: On Windows, 'XdgDataDirs' and 'XdgConfigDirs' yield the same result.
+-- The list of paths is split using 'System.FilePath.searchPathSeparator',
+-- which on Windows is a semicolon.
 --
---   @since 1.3.2.0
+-- Note: On Windows, 'XdgDataDirs' and 'XdgConfigDirs' usually yield the same
+-- result.
+--
+-- @since 1.3.2.0
 data XdgDirectoryList
   = XdgDataDirs
     -- ^ For data files (e.g. images).
-    --   Defaults to @\/usr\/local\/share\/@ and @\/usr\/share\/@ and can be
-    --   overridden by the @XDG_DATA_DIRS@ environment variable.
-    --   On Windows, it is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@
-    --   (e.g. @C:\/ProgramData@).
+    -- It uses the @XDG_DATA_DIRS@ environment variable.
+    -- On non-Windows systems, the default is @\/usr\/local\/share\/@ and
+    -- @\/usr\/share\/@.
+    -- On Windows, the default is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@
+    -- (e.g. @C:\/ProgramData@).
   | XdgConfigDirs
     -- ^ For configuration files.
-    --   Defaults to @\/etc\/xdg@ and can be
-    --   overridden by the @XDG_CONFIG_DIRS@ environment variable.
-    --   On Windows, it is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@
-    --   (e.g. @C:\/ProgramData@).
+    -- It uses the @XDG_CONFIG_DIRS@ environment variable.
+    -- On non-Windows systems, the default is @\/etc\/xdg@.
+    -- On Windows, the default is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@
+    -- (e.g. @C:\/ProgramData@).
   deriving (Bounded, Enum, Eq, Ord, Read, Show)

System/Directory/Internal/Posix.hsc

@@ -283,30 +283,18 @@ getPath = splitSearchPath <$> getEnv "PATH"
 getHomeDirectoryInternal :: IO FilePath
 getHomeDirectoryInternal = getEnv "HOME"
 
-getXdgDirectoryInternal :: IO FilePath -> XdgDirectory -> IO FilePath
-getXdgDirectoryInternal getHomeDirectory xdgDir = do
-  case xdgDir of
-    XdgData   -> get "XDG_DATA_HOME"   ".local/share"
-    XdgConfig -> get "XDG_CONFIG_HOME" ".config"
-    XdgCache  -> get "XDG_CACHE_HOME"  ".cache"
-  where
-    get name fallback = do
-      env <- lookupEnv name
-      case env of
-        Nothing   -> (</> fallback) <$> getHomeDirectory
-        Just path -> pure path
-
-getXdgDirectoryListInternal :: XdgDirectoryList -> IO [FilePath]
-getXdgDirectoryListInternal xdgDirs =
-  case xdgDirs of
-    XdgDataDirs   -> get "XDG_DATA_DIRS"   ["/usr/local/share/", "/usr/share/"]
-    XdgConfigDirs -> get "XDG_CONFIG_DIRS" ["/etc/xdg"]
-  where
-    get name fallback = do
-      env <- lookupEnv name
-      case env of
-        Nothing    -> pure fallback
-        Just paths -> pure (splitSearchPath paths)
+getXdgDirectoryFallback :: IO FilePath -> XdgDirectory -> IO FilePath
+getXdgDirectoryFallback getHomeDirectory xdgDir = do
+  (<$> getHomeDirectory) $ flip (</>) $ case xdgDir of
+    XdgData   -> ".local/share"
+    XdgConfig -> ".config"
+    XdgCache  -> ".cache"
+
+getXdgDirectoryListFallback :: XdgDirectoryList -> IO [FilePath]
+getXdgDirectoryListFallback xdgDirs =
+  pure $ case xdgDirs of
+    XdgDataDirs   -> ["/usr/local/share/", "/usr/share/"]
+    XdgConfigDirs -> ["/etc/xdg"]
 
 getAppUserDataDirectoryInternal :: FilePath -> IO FilePath
 getAppUserDataDirectoryInternal appName =

System/Directory/Internal/Windows.hsc

@@ -646,21 +646,21 @@ getHomeDirectoryInternal =
   getFolderPath Win32.cSIDL_PROFILE `catchIOError` \ _ ->
     getFolderPath Win32.cSIDL_WINDOWS
 
-getXdgDirectoryInternal :: IO FilePath -> XdgDirectory -> IO FilePath
-getXdgDirectoryInternal _ xdgDir = do
+getXdgDirectoryFallback :: IO FilePath -> XdgDirectory -> IO FilePath
+getXdgDirectoryFallback _ xdgDir = do
   case xdgDir of
     XdgData   -> getFolderPath Win32.cSIDL_APPDATA
     XdgConfig -> getFolderPath Win32.cSIDL_APPDATA
     XdgCache  -> getFolderPath win32_cSIDL_LOCAL_APPDATA
 
-getXdgDirectoryListInternal :: XdgDirectoryList -> IO [FilePath]
-getXdgDirectoryListInternal _ =
+getXdgDirectoryListFallback :: XdgDirectoryList -> IO [FilePath]
+getXdgDirectoryListFallback _ =
   pure <$> getFolderPath win32_cSIDL_COMMON_APPDATA
 
 getAppUserDataDirectoryInternal :: FilePath -> IO FilePath
 getAppUserDataDirectoryInternal appName =
   (\ appData -> appData <> ('\\' : appName))
-  <$> getXdgDirectoryInternal getHomeDirectoryInternal XdgData
+  <$> getXdgDirectoryFallback getHomeDirectoryInternal XdgData
 
 getUserDocumentsDirectoryInternal :: IO FilePath
 getUserDocumentsDirectoryInternal = getFolderPath Win32.cSIDL_PERSONAL

changelog.md

@@ -1,6 +1,12 @@
 Changelog for the [`directory`][1] package
 ==========================================
 
+## 1.3.4.0 (July 2019)
+
+  * `getXdgDirectory` and `getXdgDirectoryList` on Windows will now respect
+    the XDG environment variables if present.
+    ([#95](https://github.com/haskell/directory/issues/95))
+
 ## 1.3.3.2 (January 2019)
 
   * `getXdgDirectory` will no longer reject environment variables containing

directory.cabal

@@ -1,5 +1,5 @@
 name:           directory
-version:        1.3.3.2
+version:        1.3.4.0
 -- NOTE: Don't forget to update ./changelog.md
 license:        BSD3
 license-file:   LICENSE

tests/Xdg.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE CPP #-}
 module Xdg where
-#if !defined(mingw32_HOST_OS) && MIN_VERSION_base(4, 7, 0)
+#if MIN_VERSION_base(4, 7, 0)
+import qualified Data.List as List
 import System.Environment (setEnv, unsetEnv)
+import System.FilePath ((</>), searchPathSeparator)
 #endif
 #include "util.inl"
 
@@ -14,20 +16,35 @@ main _t = do
 
   T(expect) () True -- avoid warnings about redundant imports
 
-#if !defined(mingw32_HOST_OS) && MIN_VERSION_base(4, 7, 0)
-  unsetEnv "XDG_DATA_DIRS"
+  -- setEnv, unsetEnv require base 4.7.0.0+
+#if MIN_VERSION_base(4, 7, 0)
+#if !defined(mingw32_HOST_OS)
+  unsetEnv "XDG_CONFIG_HOME"
+  home <- getHomeDirectory
+  T(expectEq) () (home </> ".config/mow") =<< getXdgDirectory XdgConfig "mow"
+#endif
+
+  setEnv "XDG_DATA_HOME"   "ar"
+  setEnv "XDG_CONFIG_HOME" "aw"
+  setEnv "XDG_CACHE_HOME"  "ba"
+  T(expectEq) () ("ar" </> "ff") =<< getXdgDirectory XdgData   "ff"
+  T(expectEq) () ("aw" </> "oo") =<< getXdgDirectory XdgConfig "oo"
+  T(expectEq) () ("ba" </> "rk") =<< getXdgDirectory XdgCache  "rk"
+
   unsetEnv "XDG_CONFIG_DIRS"
-  T(expectEq) () ["/usr/local/share/", "/usr/share/"] =<<
-    getXdgDirectoryList XdgDataDirs
-  T(expectEq) () ["/etc/xdg"] =<< getXdgDirectoryList XdgConfigDirs
+  unsetEnv "XDG_DATA_DIRS"
+  _xdgConfigDirs <- getXdgDirectoryList XdgConfigDirs
+  _xdgDataDirs <- getXdgDirectoryList XdgDataDirs
 
-  setEnv "XDG_DATA_DIRS" "/a:/b:/c"
-  setEnv "XDG_CONFIG_DIRS" "/d:/e:/f"
-  T(expectEq) () ["/a", "/b", "/c"] =<< getXdgDirectoryList XdgDataDirs
-  T(expectEq) () ["/d", "/e", "/f"] =<< getXdgDirectoryList XdgConfigDirs
+#if !defined(mingw32_HOST_OS)
+  T(expectEq) () ["/etc/xdg"] _xdgConfigDirs
+  T(expectEq) () ["/usr/local/share/", "/usr/share/"] _xdgDataDirs
+#endif
 
-  setEnv "XDG_CACHE_HOME" "g"
-  T(expectEq) () "g/h" =<< getXdgDirectory XdgCache "h"
+  setEnv "XDG_DATA_DIRS" (List.intercalate [searchPathSeparator] ["/a", "/b"])
+  setEnv "XDG_CONFIG_DIRS" (List.intercalate [searchPathSeparator] ["/c", "/d"])
+  T(expectEq) () ["/a", "/b"] =<< getXdgDirectoryList XdgDataDirs
+  T(expectEq) () ["/c", "/d"] =<< getXdgDirectoryList XdgConfigDirs
 #endif
 
   return ()