{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
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 ( fromMaybe )
import Polysemy
import Polysemy.Error
import Polysemy.Operators
import Prelude hiding ( readFile )
import System.FilePath ( (</>) )
import qualified System.IO.Error as IO
import System.XDG.Env
import System.XDG.Error
import System.XDG.FileSystem
getDataHome :: Env -@> FilePath
getDataHome = getEnvHome "XDG_DATA_HOME" ".local/share"
getConfigHome :: Env -@> FilePath
getConfigHome = getEnvHome "XDG_CONFIG_HOME" ".config"
getStateHome :: Env -@> FilePath
getStateHome = getEnvHome "XDG_STATE_HOME" ".local/state"
getCacheHome :: Env -@> FilePath
getCacheHome = getEnvHome "XDG_CACHE_HOME" ".local/cache"
getRuntimeDir :: '[Env, Error XDGError] >@> FilePath
getRuntimeDir = maybe (throw $ MissingEnv env) pure =<< getEnv env
where env = "XDG_RUNTIME_DIR"
getDataDirs :: Env -@> [FilePath]
getDataDirs =
getEnvDirs getDataHome "XDG_DATA_DIRS" ["/usr/local/share/", "/usr/share/"]
readDataFile :: FilePath -> '[Env , Error XDGError , ReadFile a] >@> a
readDataFile = readFileFromDirs getDataDirs
readData :: Monoid b => (a -> b) -> FilePath -> XDGReader a b
readData = appendEnvFiles getDataDirs
getConfigDirs :: Env -@> [FilePath]
getConfigDirs = getEnvDirs getConfigHome "XDG_CONFIG_DIRS" ["/etc/xdg"]
readConfigFile :: FilePath -> '[Env, Error XDGError, ReadFile a] >@> a
readConfigFile = readFileFromDirs getConfigDirs
readConfig :: Monoid b => (a -> b) -> FilePath -> XDGReader a b
readConfig = appendEnvFiles getConfigDirs
readStateFile :: FilePath -> XDGReader a a
readStateFile = readFileFromDir getStateHome
readCacheFile :: FilePath -> XDGReader a a
readCacheFile = readFileFromDir getCacheHome
readRuntimeFile :: FilePath -> XDGReader a a
readRuntimeFile = readFileFromDir getRuntimeDir
type XDGReader a b = '[Env , Error XDGError , ReadFile a] >@> b
getUserHome :: Env -@> FilePath
getUserHome = fromMaybe "" <$> getEnv "HOME" --TODO: throw error if no $HOME
getEnvHome :: String -> FilePath -> Env -@> FilePath
getEnvHome env defaultHome = do
home <- getUserHome
fromMaybe (home </> defaultHome) <$> getEnv env
getEnvDirs :: (Env -@> FilePath) -> String -> [String] -> Env -@> [FilePath]
getEnvDirs getHome env defaultDirs = do
dirsHome <- getHome
dirs <- fromMaybe defaultDirs . noEmpty . fmap (endBy ":") <$> getEnv env
pure $ dirsHome : dirs
where
noEmpty (Just []) = Nothing
noEmpty x = x
readFileFromDir
:: '[Env, Error XDGError] >@> FilePath -> FilePath -> XDGReader a a
readFileFromDir getDir file = do
dir <- getDir
readFile $ dir </> file
readFileFromDirs
:: Env -@> [FilePath]
-> FilePath
-> '[Env , Error XDGError , ReadFile a] >@> a
readFileFromDirs getDirs file = do
dirs <- getDirs
foldr tryOne (throw NoReadableFile) dirs
where tryOne dir next = catch (readFile $ dir </> file) (const next)
appendEnvFiles
:: Monoid b
=> Env -@> [FilePath]
-> (a -> b)
-> FilePath
-> '[Env , Error XDGError , ReadFile a] >@> b
appendEnvFiles getDirs parse file = do
files <- map (</> file) <$> getDirs
fold
<$> traverse (\file -> catch (parse <$> readFile file) (pure mempty)) files
maybeRead :: XDGReader a a -> XDGReader a (Maybe a)
maybeRead action = catch
(Just <$> action)
(\case
NoReadableFile -> pure Nothing
error -> throw error
)
runXDGIO :: XDGReader ByteString a -> IO a
runXDGIO action = do
result <- runM $ runError $ runReadFileIO $ runEnvIO action
either IO.throwIO pure result