diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Exception.hs | 113 | ||||
| -rw-r--r-- | Utility/FreeDesktop.hs | 147 |
2 files changed, 260 insertions, 0 deletions
diff --git a/Utility/Exception.hs b/Utility/Exception.hs new file mode 100644 index 0000000..0ffc710 --- /dev/null +++ b/Utility/Exception.hs @@ -0,0 +1,113 @@ +{- Simple IO exception handling (and some more) + - + - Copyright 2011-2015 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Exception ( + module X, + catchBoolIO, + catchMaybeIO, + catchDefaultIO, + catchMsgIO, + catchIO, + tryIO, + bracketIO, + catchNonAsync, + tryNonAsync, + tryWhenExists, + catchIOErrorType, + IOErrorType(..), + catchPermissionDenied, +) where + +import Control.Monad.Catch as X hiding (Handler) +import qualified Control.Monad.Catch as M +import Control.Exception (IOException, AsyncException) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) +import Control.Exception (SomeAsyncException) +#endif +#endif +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) +import System.IO.Error (isDoesNotExistError, ioeGetErrorType) +import GHC.IO.Exception (IOErrorType(..)) + +import Utility.Data + +{- Catches IO errors and returns a Bool -} +catchBoolIO :: MonadCatch m => m Bool -> m Bool +catchBoolIO = catchDefaultIO False + +{- Catches IO errors and returns a Maybe -} +catchMaybeIO :: MonadCatch m => m a -> m (Maybe a) +catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just) + +{- Catches IO errors and returns a default value. -} +catchDefaultIO :: MonadCatch m => a -> m a -> m a +catchDefaultIO def a = catchIO a (const $ return def) + +{- Catches IO errors and returns the error message. -} +catchMsgIO :: MonadCatch m => m a -> m (Either String a) +catchMsgIO a = do + v <- tryIO a + return $ either (Left . show) Right v + +{- catch specialized for IO errors only -} +catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a +catchIO = M.catch + +{- try specialized for IO errors only -} +tryIO :: MonadCatch m => m a -> m (Either IOException a) +tryIO = M.try + +{- bracket with setup and cleanup actions lifted to IO. + - + - Note that unlike catchIO and tryIO, this catches all exceptions. -} +bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a +bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) + +{- Catches all exceptions except for async exceptions. + - This is often better to use than catching them all, so that + - ThreadKilled and UserInterrupt get through. + -} +catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a +catchNonAsync a onerr = a `catches` + [ M.Handler (\ (e :: AsyncException) -> throwM e) +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) + , M.Handler (\ (e :: SomeAsyncException) -> throwM e) +#endif +#endif + , M.Handler (\ (e :: SomeException) -> onerr e) + ] + +tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) +tryNonAsync a = go `catchNonAsync` (return . Left) + where + go = do + v <- a + return (Right v) + +{- Catches only DoesNotExist exceptions, and lets all others through. -} +tryWhenExists :: MonadCatch m => m a -> m (Maybe a) +tryWhenExists a = do + v <- tryJust (guard . isDoesNotExistError) a + return (eitherToMaybe v) + +{- Catches only IO exceptions of a particular type. + - Ie, use HardwareFault to catch disk IO errors. -} +catchIOErrorType :: MonadCatch m => IOErrorType -> (IOException -> m a) -> m a -> m a +catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching + where + onlymatching e + | ioeGetErrorType e == errtype = onmatchingerr e + | otherwise = throwM e + +catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a +catchPermissionDenied = catchIOErrorType PermissionDenied diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs new file mode 100644 index 0000000..76b07fb --- /dev/null +++ b/Utility/FreeDesktop.hs @@ -0,0 +1,147 @@ +{- Freedesktop.org specifications + - + - http://standards.freedesktop.org/basedir-spec/latest/ + - http://standards.freedesktop.org/desktop-entry-spec/latest/ + - http://standards.freedesktop.org/menu-spec/latest/ + - http://standards.freedesktop.org/icon-theme-spec/latest/ + - + - Copyright 2012 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.FreeDesktop ( + DesktopEntry, + genDesktopEntry, + buildDesktopMenuFile, + writeDesktopMenuFile, + desktopMenuFilePath, + autoStartPath, + iconDir, + iconFilePath, + systemDataDir, + systemConfigDir, + userDataDir, + userConfigDir, + userDesktopDir +) where + +import Utility.Exception +import Utility.UserInfo + +import System.Environment +import System.FilePath +import System.Directory +import System.Process +import Data.List +import Data.Maybe +import Control.Applicative +import Prelude + +type DesktopEntry = [(Key, Value)] + +type Key = String + +data Value = StringV String | BoolV Bool | NumericV Float | ListV [Value] + +toString :: Value -> String +toString (StringV s) = s +toString (BoolV b) + | b = "true" + | otherwise = "false" +toString (NumericV f) = show f +toString (ListV l) + | null l = "" + | otherwise = (intercalate ";" $ map (concatMap escapesemi . toString) l) ++ ";" + where + escapesemi ';' = "\\;" + escapesemi c = [c] + +genDesktopEntry :: String -> String -> Bool -> FilePath -> Maybe String -> [String] -> DesktopEntry +genDesktopEntry name comment terminal program icon categories = catMaybes + [ item "Type" StringV "Application" + , item "Version" NumericV 1.0 + , item "Name" StringV name + , item "Comment" StringV comment + , item "Terminal" BoolV terminal + , item "Exec" StringV program + , maybe Nothing (item "Icon" StringV) icon + , item "Categories" ListV (map StringV categories) + ] + where + item x c y = Just (x, c y) + +buildDesktopMenuFile :: DesktopEntry -> String +buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n" + where + keyvalue (k, v) = k ++ "=" ++ toString v + +writeDesktopMenuFile :: DesktopEntry -> String -> IO () +writeDesktopMenuFile d file = do + createDirectoryIfMissing True (takeDirectory file) + writeFile file $ buildDesktopMenuFile d + +{- Path to use for a desktop menu file, in either the systemDataDir or + - the userDataDir -} +desktopMenuFilePath :: String -> FilePath -> FilePath +desktopMenuFilePath basename datadir = + datadir </> "applications" </> desktopfile basename + +{- Path to use for a desktop autostart file, in either the systemDataDir + - or the userDataDir -} +autoStartPath :: String -> FilePath -> FilePath +autoStartPath basename configdir = + configdir </> "autostart" </> desktopfile basename + +{- Base directory to install an icon file, in either the systemDataDir + - or the userDatadir. -} +iconDir :: FilePath -> FilePath +iconDir datadir = datadir </> "icons" </> "hicolor" + +{- Filename of an icon, given the iconDir to use. + - + - The resolution is something like "48x48" or "scalable". -} +iconFilePath :: FilePath -> String -> FilePath -> FilePath +iconFilePath file resolution icondir = + icondir </> resolution </> "apps" </> file + +desktopfile :: FilePath -> FilePath +desktopfile f = f ++ ".desktop" + +{- Directory used for installation of system wide data files.. -} +systemDataDir :: FilePath +systemDataDir = "/usr/share" + +{- Directory used for installation of system wide config files. -} +systemConfigDir :: FilePath +systemConfigDir = "/etc/xdg" + +{- Directory for user data files. -} +userDataDir :: IO FilePath +userDataDir = xdgEnvHome "DATA_HOME" ".local/share" + +{- Directory for user config files. -} +userConfigDir :: IO FilePath +userConfigDir = xdgEnvHome "CONFIG_HOME" ".config" + +{- Directory for the user's Desktop, may be localized. + - + - This is not looked up very fast; the config file is in a shell format + - that is best parsed by shell, so xdg-user-dir is used, with a fallback + - to ~/Desktop. -} +userDesktopDir :: IO FilePath +userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir) + where + parse s = case lines <$> s of + Just (l:_) -> Just l + _ -> Nothing + xdg_user_dir = catchMaybeIO $ readProcess "xdg-user-dir" ["DESKTOP"] [] + fallback = xdgEnvHome "DESKTOP_DIR" "Desktop" + +xdgEnvHome :: String -> String -> IO String +xdgEnvHome envbase homedef = do + home <- myHomeDir + catchDefaultIO (home </> homedef) $ + getEnv $ "XDG_" ++ envbase |