diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Pierre Thierry (c) 2017 +Copyright Pierre Thierry (c) 2022–2023 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,18 +4,18 @@ ## Compliance -- [ ] `$XDG_DATA_HOME` +- [X] `$XDG_DATA_HOME` - [X] get path - [X] read file - - [ ] write file -- [ ] `$XDG_CONFIG_HOME` + - [X] write file +- [X] `$XDG_CONFIG_HOME` - [X] get path - [X] read file - - [ ] write file -- [ ] `$XDG_STATE_HOME` + - [X] write file +- [X] `$XDG_STATE_HOME` - [X] get path - [X] read file - - [ ] write file + - [X] write file - [X] `$XDG_DATA_DIRS` - [X] get path list - [X] read best file @@ -24,15 +24,17 @@ - [X] get path list - [X] read best file - [X] merge files -- [ ] `$XDG_CACHE_HOME` +- [X] `$XDG_CACHE_HOME` - [X] get path - [X] read file - - [ ] write file -- [ ] `$XDG_RUNTIME_DIR` + - [X] write file +- [X] `$XDG_RUNTIME_DIR` - [X] get path - [X] read file - - [ ] write file + - [X] write file - [X] treat relative paths as invalid + +As this library deals purely with accessing files, I eventually chose not to implement the notion of warning the user when `$XDG_RUNTIME_DIR` isn't set and of providing a replacement directory. Any application where that behaviour would be relevant can use the exception raised by `getRuntimeDir` to detect this problem, should deal with warning the user in its own context, and can set `$XDG_RUNTIME_DIR` with a path that makes sense for that application. # Build diff --git a/src/System/XDG.hs b/src/System/XDG.hs --- a/src/System/XDG.hs +++ b/src/System/XDG.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DataKinds #-} - {-| Module : System.XDG Description : XDG Basedir functions @@ -8,13 +6,40 @@ When an environment variable is missing that must be defined, they will -raise a `MissingEnv` exception. This applies to @$HOME@ and @$XDG_RUNTIME_DIR@. +raise a `System.XDG.Error.MissingEnv` exception. This applies to @$HOME@ and @$XDG_RUNTIME_DIR@. As per the specification, these functions will treat any relative path in the environment variables as invalid. They will be skipped when operating on a list of -paths. Functions that return a single path will raise an `InvalidPath` exception. +paths. Functions that return a single path will raise an `System.XDG.Error.InvalidPath` exception. -} -module System.XDG where +module System.XDG + ( + -- * Data + getDataHome + , getDataDirs + , readDataFile + , readData + , writeDataFile + -- * Config + , getConfigHome + , getConfigDirs + , readConfigFile + , readConfig + , writeConfigFile + -- * Cache + , getCacheHome + , readCacheFile + , writeCacheFile + -- * State + , getStateHome + , readStateFile + , writeStateFile + -- * Runtime + -- | The specification says that when @$XDG_RUNTIME_DIR@ isn't set, an application should fall back to a replacement directory and warn users. To that end, `getRuntimeDir` will raise a `System.XDG.Error.MissingEnv` exception when @$XDG_RUNTIME_DIR@ isn't set. The application can then set it to useful value and then use `readRuntimeFile` and `writeRuntimeFile`. + , getRuntimeDir + , readRuntimeFile + , writeRuntimeFile + ) where import Data.ByteString.Lazy ( ByteString ) import Path ( fromAbsDir ) @@ -115,3 +140,47 @@ readRuntimeFile file = In.runXDGIO $ In.maybeRead $ In.readStateFile file +{-| Writes a config file in the config home if it is writable. + +@ +> writeConfigFile "subdir/filename" $ BS.pack [1, 2, 3] +@ +-} +writeConfigFile :: FilePath -> ByteString -> IO () +writeConfigFile file content = In.runXDGIO $ In.writeConfigFile file content + +{-| Writes a data file in the data home if it is writable. + +@ +> writeDataFile "subdir/filename" $ BS.pack [1, 2, 3] +@ +-} +writeDataFile :: FilePath -> ByteString -> IO () +writeDataFile file content = In.runXDGIO $ In.writeDataFile file content + +{-| Writes a cache file in the cache home if it is writable. + +@ +> writeCacheFile "subdir/filename" $ BS.pack [1, 2, 3] +@ +-} +writeCacheFile :: FilePath -> ByteString -> IO () +writeCacheFile file content = In.runXDGIO $ In.writeCacheFile file content + +{-| Writes a state file in the state home if it is writable. + +@ +> writeStateFile "subdir/filename" $ BS.pack [1, 2, 3] +@ +-} +writeStateFile :: FilePath -> ByteString -> IO () +writeStateFile file content = In.runXDGIO $ In.writeStateFile file content + +{-| Writes a runtime file in the runtime dir if it is writable. + +@ +> writeRuntimeFile "subdir/filename" $ BS.pack [1, 2, 3] +@ +-} +writeRuntimeFile :: FilePath -> ByteString -> IO () +writeRuntimeFile file content = In.runXDGIO $ In.writeRuntimeFile file content diff --git a/src/System/XDG/Env.hs b/src/System/XDG/Env.hs --- a/src/System/XDG/Env.hs +++ b/src/System/XDG/Env.hs @@ -1,23 +1,20 @@ -{-# LANGUAGE TemplateHaskell, DataKinds #-} -{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} module System.XDG.Env where -import Polysemy -import System.Environment ( lookupEnv ) - +import Polysemy +import System.Environment (lookupEnv) data Env m a where - GetEnv ::String -> Env m (Maybe String) + GetEnv :: String -> Env m (Maybe String) makeSem ''Env - type EnvList = [(String, String)] runEnvList :: EnvList -> InterpreterFor Env r runEnvList envs = interpret (\(GetEnv name) -> pure $ lookup name envs) - runEnvIO :: Member (Embed IO) r => InterpreterFor Env r runEnvIO = interpret (\(GetEnv name) -> embed $ lookupEnv name) diff --git a/src/System/XDG/Error.hs b/src/System/XDG/Error.hs --- a/src/System/XDG/Error.hs +++ b/src/System/XDG/Error.hs @@ -1,18 +1,19 @@ module System.XDG.Error where -import Control.Exception -import Path - +import Control.Exception +import Path +-- | The type of exceptions raised by this library. data XDGError = FileNotFound (Path Abs File) | NoReadableFile - | MissingEnv String - | InvalidPath FilePath + | -- | This exception is raised when an environment variable that should be defined is not. It is not raised when an optional environment variable is not defined. + MissingEnv String + | -- | This exception is raised when an invalid file path or a relative path is found instead of a valid absolute path. + InvalidPath FilePath deriving (Eq, Show) instance Exception XDGError - throwIOLeft :: Exception e => Either e a -> IO a throwIOLeft = either throwIO pure diff --git a/src/System/XDG/FileSystem.hs b/src/System/XDG/FileSystem.hs --- a/src/System/XDG/FileSystem.hs +++ b/src/System/XDG/FileSystem.hs @@ -1,40 +1,65 @@ -{-# LANGUAGE TemplateHaskell, DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} module System.XDG.FileSystem where -import qualified Control.Exception as IO -import qualified Data.ByteString.Lazy as BS -import Path -import Polysemy -import Polysemy.Error -import qualified System.IO.Error as IO -import System.XDG.Error - +import qualified Control.Exception as IO +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as M +import Path +import Polysemy +import Polysemy.Error +import Polysemy.State ( + State, + evalState, + get, + modify, + ) +import qualified System.IO.Error as IO +import System.XDG.Error data ReadFile f m a where - ReadFile ::Path Abs File -> ReadFile f m f + ReadFile :: Path Abs File -> ReadFile f m f -makeSem ''ReadFile +data WriteFile f m a where + WriteFile :: Path Abs File -> f -> WriteFile f m () +makeSem ''ReadFile +makeSem ''WriteFile type FileList a = [(Path Abs File, a)] +type FileMap a = M.Map (Path Abs File) a -runReadFileList - :: Member (Error XDGError) r => FileList a -> InterpreterFor (ReadFile a) r -runReadFileList files = interpret - (\(ReadFile path) -> - maybe (throw $ FileNotFound path) pure $ lookup path files - ) +runReadWriteFileList :: + Member (Error XDGError) r => + FileList a -> + Sem (ReadFile a ': WriteFile a ': State (FileMap a) ': r) b -> + Sem r b +runReadWriteFileList files = + evalState (M.fromList files) + . interpret (\(WriteFile path content) -> modify (M.insert path content)) + . interpret + ( \(ReadFile path) -> do + fileMap <- get + maybe (throw $ FileNotFound path) pure $ M.lookup path fileMap + ) -runReadFileIO - :: Members '[Embed IO , Error XDGError] r - => InterpreterFor (ReadFile BS.ByteString) r -runReadFileIO = interpret - (\(ReadFile path) -> do - let notFound :: IO.IOException -> Maybe XDGError - notFound e = - if IO.isDoesNotExistError e then Just $ FileNotFound path else Nothing - result <- embed $ IO.tryJust notFound $ BS.readFile $ toFilePath path - either throw pure result - ) +runReadWriteFileIO :: + Members '[Embed IO, Error XDGError] r => + Sem (ReadFile BS.ByteString ': WriteFile BS.ByteString ': r) a -> + Sem r a +runReadWriteFileIO = + interpret + ( \(WriteFile path content) -> do + result <- embed $ IO.tryJust (notFound path) $ BS.writeFile (toFilePath path) content + either throw pure result + ) + . interpret + ( \(ReadFile path) -> do + result <- embed $ IO.tryJust (notFound path) $ BS.readFile $ toFilePath path + either throw pure result + ) + where + notFound :: Path Abs File -> IO.IOException -> Maybe XDGError + notFound path e = if IO.isDoesNotExistError e then Just $ FileNotFound path else Nothing diff --git a/src/System/XDG/Internal.hs b/src/System/XDG/Internal.hs --- a/src/System/XDG/Internal.hs +++ b/src/System/XDG/Internal.hs @@ -1,34 +1,34 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} module System.XDG.Internal where -import qualified Control.Exception as IO -import Data.ByteString.Lazy ( ByteString ) -import Data.Foldable ( fold ) -import Data.List.Split ( endBy ) -import Data.Maybe ( catMaybes - , fromMaybe - ) -import Path ( () - , Abs - , Dir - , File - , Path - , Rel - , mkRelDir - , parseAbsDir - , parseRelFile - ) -import Polysemy -import Polysemy.Error -import Polysemy.Operators -import Prelude hiding ( readFile ) -import System.XDG.Env -import System.XDG.Error -import System.XDG.FileSystem - +import qualified Control.Exception as IO +import Data.ByteString.Lazy (ByteString) +import Data.Foldable (fold) +import Data.List.Split (endBy) +import Data.Maybe ( + catMaybes, + fromMaybe, + ) +import Path ( + Abs, + Dir, + File, + Path, + Rel, + mkRelDir, + parseAbsDir, + parseRelFile, + (), + ) +import Polysemy +import Polysemy.Error +import Polysemy.Operators +import System.XDG.Env +import System.XDG.Error +import System.XDG.FileSystem +import Prelude hiding (readFile, writeFile) getDataHome :: XDGEnv (Path Abs Dir) getDataHome = getEnvHome "XDG_DATA_HOME" $(mkRelDir ".local/share") @@ -51,7 +51,7 @@ getDataDirs = getEnvDirs getDataHome "XDG_DATA_DIRS" ["/usr/local/share/", "/usr/share/"] -readDataFile :: FilePath -> '[Env , Error XDGError , ReadFile a] >@> a +readDataFile :: FilePath -> '[Env, Error XDGError, ReadFile a] >@> a readDataFile = readFileFromDirs getDataDirs readData :: Monoid b => (a -> b) -> FilePath -> XDGReader a b @@ -75,10 +75,11 @@ readRuntimeFile :: FilePath -> XDGReader a a readRuntimeFile = readFileFromDir getRuntimeDir +type XDGEnv a = '[Env, Error XDGError] >@> a -type XDGEnv a = '[Env , Error XDGError] >@> a +type XDGReader a b = '[Env, Error XDGError, ReadFile a] >@> b -type XDGReader a b = '[Env , Error XDGError , ReadFile a] >@> b +type XDGWriter a b = '[Env, Error XDGError, ReadFile a, WriteFile a] >@> b requireEnv :: String -> XDGEnv String requireEnv env = maybe (throw $ MissingEnv env) pure =<< getEnv env @@ -86,7 +87,7 @@ requireAbsDir :: FilePath -> (Error XDGError) -@> Path Abs Dir requireAbsDir path = maybe (throw $ InvalidPath path) pure $ parseAbsDir path -requireRelFile :: FilePath -> (Error XDGError) -@> Path Rel File +requireRelFile :: FilePath -> (Error XDGError) -@> Path Rel File requireRelFile path = maybe (throw $ InvalidPath path) pure $ parseRelFile path getEnvHome :: String -> Path Rel Dir -> XDGEnv (Path Abs Dir) @@ -95,24 +96,24 @@ maybe getDefault pure dir where getDefault = do - home <- requireEnv "HOME" + home <- requireEnv "HOME" home' <- requireAbsDir home pure $ home' defaultDir -getEnvDirs - :: (XDGEnv (Path Abs Dir)) -> String -> [String] -> XDGEnv [Path Abs Dir] +getEnvDirs :: + (XDGEnv (Path Abs Dir)) -> String -> [String] -> XDGEnv [Path Abs Dir] getEnvDirs getUserDir env defaultDirs = do userDir <- catch (Just <$> getUserDir) (const $ pure Nothing) - dirs <- fromMaybe defaultDirs . noEmpty . fmap (endBy ":") <$> getEnv env + dirs <- fromMaybe defaultDirs . noEmpty . fmap (endBy ":") <$> getEnv env pure $ catMaybes $ userDir : (map parseAbsDir dirs) where noEmpty (Just []) = Nothing - noEmpty x = x + noEmpty x = x readFileFromDir :: XDGEnv (Path Abs Dir) -> FilePath -> XDGReader a a readFileFromDir getDir subPath = do subFile <- requireRelFile subPath - dir <- getDir + dir <- getDir readFile $ dir subFile readFileFromDirs :: XDGEnv [Path Abs Dir] -> FilePath -> XDGReader a a @@ -122,24 +123,45 @@ dirs <- getDirs foldr tryOne (throw NoReadableFile) dirs -appendEnvFiles - :: Monoid b => XDGEnv [Path Abs Dir] -> (a -> b) -> FilePath -> XDGReader a b +appendEnvFiles :: + Monoid b => XDGEnv [Path Abs Dir] -> (a -> b) -> FilePath -> XDGReader a b appendEnvFiles getDirs parse subPath = do subFile <- requireRelFile subPath - files <- map ( subFile) <$> getDirs + files <- map ( subFile) <$> getDirs fold <$> traverse (\path -> catch (parse <$> readFile path) (pure mempty)) files maybeRead :: XDGReader a a -> XDGReader a (Maybe a) -maybeRead action = catch - (Just <$> action) - (\case - NoReadableFile -> pure Nothing - err -> throw err - ) +maybeRead action = + catch + (Just <$> action) + ( \case + NoReadableFile -> pure Nothing + err -> throw err + ) +writeConfigFile :: FilePath -> a -> XDGWriter a () +writeConfigFile = writeFileToDir getConfigHome -runXDGIO :: XDGReader ByteString a -> IO a +writeDataFile :: FilePath -> a -> XDGWriter a () +writeDataFile = writeFileToDir getDataHome + +writeCacheFile :: FilePath -> a -> XDGWriter a () +writeCacheFile = writeFileToDir getCacheHome + +writeStateFile :: FilePath -> a -> XDGWriter a () +writeStateFile = writeFileToDir getStateHome + +writeRuntimeFile :: FilePath -> a -> XDGWriter a () +writeRuntimeFile = writeFileToDir getRuntimeDir + +writeFileToDir :: XDGEnv (Path Abs Dir) -> FilePath -> a -> XDGWriter a () +writeFileToDir getDir subPath value = do + subFile <- requireRelFile subPath + dir <- getDir + writeFile (dir subFile) value + +runXDGIO :: XDGWriter ByteString a -> IO a runXDGIO action = do - result <- runM $ runError $ runReadFileIO $ runEnvIO action + result <- runM $ runError $ runReadWriteFileIO $ runEnvIO action either IO.throwIO pure result diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,32 +1,31 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} - -import Data.Aeson ( decode ) -import Data.ByteString.Lazy ( ByteString ) -import Data.List ( intercalate ) -import Data.Maybe ( fromJust - , fromMaybe - ) -import Data.Monoid ( Sum(..) ) -import Data.String ( IsString(..) ) -import Path hiding ( () ) -import Polysemy -import Polysemy.Error -import Polysemy.Operators -import System.Directory ( getCurrentDirectory ) -import System.Environment ( setEnv ) -import System.FilePath ( () ) -import qualified System.XDG as XDGIO -import System.XDG.Env -import System.XDG.Error -import System.XDG.FileSystem -import System.XDG.Internal -import Test.Hspec - +import Data.Aeson (decode) +import Data.ByteString.Lazy (ByteString) +import Data.List (intercalate) +import Data.Maybe ( + fromJust, + fromMaybe, + ) +import Data.Monoid (Sum (..)) +import Data.String (IsString (..)) +import Path hiding (()) +import Polysemy +import Polysemy.Error +import Polysemy.Operators +import Polysemy.State +import System.Directory (getCurrentDirectory, removeFile) +import System.Environment (setEnv) +import System.FilePath (()) +import qualified System.XDG as XDGIO +import System.XDG.Env +import System.XDG.Error +import System.XDG.FileSystem +import System.XDG.Internal +import Test.Hspec instance IsString (Path Abs Dir) where fromString = fromMaybe undefined . parseAbsDir @@ -34,59 +33,55 @@ instance IsString (Path Abs File) where fromString = fromMaybe undefined . parseAbsFile - - bareEnv :: EnvList bareEnv = [("HOME", "/alice")] fullEnv :: EnvList fullEnv = - [ ("HOME" , "/alice") + [ ("HOME", "/alice") , ("XDG_CONFIG_HOME", "/config") - , ("XDG_DATA_HOME" , "/data") - , ("XDG_STATE_HOME" , "/state") - , ("XDG_CACHE_HOME" , "/cache") + , ("XDG_DATA_HOME", "/data") + , ("XDG_STATE_HOME", "/state") + , ("XDG_CACHE_HOME", "/cache") , ("XDG_RUNTIME_DIR", "/runtime") ] badEnv :: EnvList badEnv = - [ ("HOME" , "/alice") + [ ("HOME", "/alice") , ("XDG_DATA_HOME", "data/") , ("XDG_DATA_DIRS", "/foo:./bar:/baz:foo/../bar") ] - userFiles :: FileList Integer userFiles = - [ ("/data/foo/bar" , 1) - , ("/config/foo/bar" , 10) - , ("/state/foo/bar" , 100) - , ("/cache/foo/bar" , 200) + [ ("/data/foo/bar", 1) + , ("/config/foo/bar", 10) + , ("/state/foo/bar", 100) + , ("/cache/foo/bar", 200) , ("/runtime/foo/bar", 300) ] sysFiles :: FileList Integer sysFiles = [ ("/usr/local/share/foo/bar", 2) - , ("/usr/share/foo/bar" , 3) - , ("/etc/xdg/foo/bar" , 20) + , ("/usr/share/foo/bar", 3) + , ("/etc/xdg/foo/bar", 20) ] allFiles :: FileList Integer allFiles = userFiles ++ sysFiles -testXDG - :: EnvList - -> FileList Integer - -> '[Env , ReadFile Integer , Error XDGError] @> a - -> Either XDGError a -testXDG env files = run . runError . runReadFileList files . runEnvList env +testXDG :: + EnvList -> + FileList Integer -> + '[Env, ReadFile Integer, WriteFile Integer, State (FileMap Integer), Error XDGError] @> a -> + Either XDGError a +testXDG env files = run . runError . runReadWriteFileList files . runEnvList env decodeInteger :: ByteString -> Sum Integer decodeInteger = Sum . fromMaybe 0 . decode - main :: IO () main = hspec $ do describe "XDG" $ do @@ -129,18 +124,32 @@ it "opens a runtime file" $ do testXDG fullEnv userFiles (readRuntimeFile "foo/bar") `shouldBe` Right 300 + it "writes a config file" $ do + testXDG fullEnv userFiles (writeConfigFile "foo/bar" 1000 >> readConfigFile "foo/bar") `shouldBe` Right 1000 + it "writes a data file" $ do + testXDG fullEnv userFiles (writeDataFile "foo/bar" 2000 >> readDataFile "foo/bar") `shouldBe` Right 2000 + it "writes a cache file" $ do + testXDG fullEnv userFiles (writeCacheFile "foo/bar" 3000 >> readCacheFile "foo/bar") `shouldBe` Right 3000 + it "writes a state file" $ do + testXDG fullEnv userFiles (writeStateFile "foo/bar" 4000 >> readStateFile "foo/bar") `shouldBe` Right 4000 + it "writes a runtime file" $ do + testXDG fullEnv userFiles (writeRuntimeFile "foo/bar" 5000 >> readRuntimeFile "foo/bar") `shouldBe` Right 5000 describe "IO interpreter" $ do it "opens a data file" $ do cwd <- getCurrentDirectory setEnv "XDG_DATA_HOME" $ cwd "test/dir1" - setEnv "XDG_DATA_DIRS" $ intercalate ":" $ map - (cwd ) - ["test/dir2", "test/dir3"] + setEnv "XDG_DATA_DIRS" $ + intercalate ":" $ + map + (cwd ) + ["test/dir2", "test/dir3"] (decodeInteger . fromJust) - <$> XDGIO.readDataFile "foo/bar.json" + <$> XDGIO.readDataFile "foo/bar.json" `shouldReturn` 1 it "merges data files" $ do XDGIO.readData decodeInteger "foo/bar.json" `shouldReturn` 3 XDGIO.readData decodeInteger "foo/baz.json" `shouldReturn` 30 - - + it "writes a data file" $ do + XDGIO.writeDataFile "foo/quux.json" "4" + (decodeInteger . fromJust) <$> XDGIO.readDataFile "foo/quux.json" `shouldReturn` 4 + ( "test/dir1/foo/quux.json") <$> getCurrentDirectory >>= removeFile diff --git a/xdg-basedir-compliant.cabal b/xdg-basedir-compliant.cabal --- a/xdg-basedir-compliant.cabal +++ b/xdg-basedir-compliant.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: xdg-basedir-compliant -version: 1.1.0 +version: 1.2.0 synopsis: XDG Basedir description: See README.md category: System @@ -13,7 +13,7 @@ bug-reports: https://github.com/kephas/xdg-basedir-compliant/issues author: Pierre Thierry maintainer: pierre@nothos.net -copyright: 2022 Pierre Thierry +copyright: 2022–2023 Pierre Thierry license: BSD3 license-file: LICENSE build-type: Simple @@ -49,6 +49,7 @@ build-depends: base >=4.7 && <5 , bytestring + , containers , directory , filepath , path @@ -80,6 +81,7 @@ , aeson , base >=4.7 && <5 , bytestring + , containers , directory , filepath , hspec