Added --autostart mode and install FDO autostart file

--autostart mode currently only uploads queued keys, but it will later
be expanded to do more. Including checking the BackupRecord for problems
when necessary.

The autostart file is installed by keysafe --backup, so that when keysafe
is installed with stack, and used, it will make sure it autostarts in the
future.

The autostart file is installed by the Makefile too. This will later
let --autostart check for keys that have not been backed up and prompt
about backing them up. This way, the user won't need to remember to run
keysafe to back things up.

Reused Utility.FreeDesktop from git-annex, and had to add some stuff it
depends on.

This commit was sponsored by Fernando Jimenez on Patreon.

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