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.

12 files changed, 355 insertions, 12 deletions

diff --git a/AutoStart.hs b/AutoStart.hs
new file mode 100644
index 0000000..dc022df
--- /dev/null
+++ b/AutoStart.hs
@@ -0,0 +1,42 @@
+{- Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module AutoStart where
+
+import Utility.FreeDesktop
+import System.Info
+import System.Environment
+import System.Directory
+
+installAutoStartFile :: IO ()
+installAutoStartFile = go =<< autoStartFile
+  where
+	go (Just f) = case os of
+		"linux" -> installFdoAutoStart f
+		"freebsd" -> installFdoAutoStart f
+		_ -> return ()
+	go Nothing = return ()
+
+isAutoStartFileInstalled :: IO Bool
+isAutoStartFileInstalled = maybe (pure False) doesFileExist =<< autoStartFile
+
+autoStartFile :: IO (Maybe FilePath)
+autoStartFile = case os of
+	"linux" -> Just . autoStartPath "keysafe" <$> userConfigDir
+	_ -> return Nothing
+
+installFdoAutoStart :: FilePath -> IO ()
+installFdoAutoStart f = do
+	command <- getExecutablePath
+	writeDesktopMenuFile (fdoAutostart command) f
+
+fdoAutostart :: FilePath -> DesktopEntry
+fdoAutostart command = genDesktopEntry
+        "Keysafe"
+        "Autostart"
+        False
+        (command ++ " --autostart")
+        Nothing
+        []
diff --git a/CHANGELOG b/CHANGELOG
index 7de7c89..f675930 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -10,6 +10,8 @@ keysafe (0.20160915) UNRELEASED; urgency=medium
   * Change format of ~/.keysafe/backup.log
   * Added --backup-server and --restore-server to aid in backing up keysafe
     servers with minimal information leakage.
+  * Added --autostart mode, and make both keysafe --backup and 
+    the Makefile install a FDO desktop autostart file to use it.
 
  -- Joey Hess <id@joeyh.name>  Wed, 14 Sep 2016 20:19:43 -0400
 
diff --git a/CmdLine.hs b/CmdLine.hs
index f4a6b92..99414ff 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -29,7 +29,7 @@ data CmdLine = CmdLine
 	, serverConfig :: ServerConfig
 	}
 
-data Mode = Backup | Restore | UploadQueued | Server | GenBackup FilePath | RestoreBackup FilePath | Chaff HostName | Benchmark | Test
+data Mode = Backup | Restore | UploadQueued | AutoStart | Server | GenBackup FilePath | RestoreBackup FilePath | Chaff HostName | Benchmark | Test
 	deriving (Show)
 
 data ServerConfig = ServerConfig
@@ -113,6 +113,10 @@ parseMode =
 		( long "uploadqueued"
 		<> help "Upload any data to servers that was queued by a previous --backup run."
 		)
+	<|> flag' AutoStart
+		( long "autostart"
+		<> help "Run automatically on login by desktop autostart file."
+		)
 	<|> flag' Server
 		( long "server"
 		<> help "Run as a keysafe server, accepting objects and storing them to ~/.keysafe/objects/local/"
diff --git a/INSTALL b/INSTALL
index a4a3bc0..9662eee 100644
--- a/INSTALL
+++ b/INSTALL
@@ -18,7 +18,7 @@ Note that there is a manpage, but stack doesn't install it yet.
 ## System-wide installation
 
 This installs keysafe in /usr/bin, and includes the man page, 
-desktop file, systemd service file, etc.
+desktop file, autostart file, systemd service file, etc.
 
 Start by installing the dependencies as shown in Quick installation.
 
diff --git a/Makefile b/Makefile
index c3ecbda..d309837 100644
--- a/Makefile
+++ b/Makefile
@@ -30,5 +30,7 @@ install-files: keysafe
 	install -m 0644 keysafe.service $(PREFIX)/lib/systemd/system/keysafe.service
 	install -d $(PREFIX)/usr/share/applications/
 	install -m 0644 keysafe.desktop $(PREFIX)/usr/share/applications/keysafe.desktop
+	install -d $(PREFIX)/etc/xdg/autostart/
+	install -m 0644 keysafe.autostart $(PREFIX)/etc/xdg/autostart/keysafe.desktop
 
 .PHONY: keysafe
diff --git a/Storage.hs b/Storage.hs
index ef042ba..aa52d7c 100644
--- a/Storage.hs
+++ b/Storage.hs
@@ -119,8 +119,8 @@ retrieveShares (StorageLocations locs) sis updateprogress = do
 				go (unusedlocs++[loc]) usedlocs' rest shares'
 
 -- | Returns descriptions of any failures.
-uploadQueued :: Maybe LocalStorageDirectory -> IO [String]
-uploadQueued d = do
+tryUploadQueued :: Maybe LocalStorageDirectory -> IO [String]
+tryUploadQueued d = do
 	results <- forM locs $ \loc -> case uploadQueue loc of
 		Nothing -> return []
 		Just q -> moveShares q loc
diff --git a/TODO b/TODO
index f2fa3b1..ec65396 100644
--- a/TODO
+++ b/TODO
@@ -3,8 +3,8 @@ Soon:
 * Implement the different categories of servers in the server list.
 * Get some keysafe servers set up.
 * Run --uploadqueued periodically (systemd timer or desktop autostart?)
-* Add desktop autostart mode that checks for gpg keys that have not been
-  backed up, and offers to back them up. Only once.
+* In --autostart mode, check for gpg keys that have not been
+  backed up, and offer to back them up. Only once per key.
 
 Later:
 
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
diff --git a/keysafe.autostart b/keysafe.autostart
new file mode 100644
index 0000000..0705e51
--- /dev/null
+++ b/keysafe.autostart
@@ -0,0 +1,9 @@
+[Desktop Entry]
+Type=Application
+Version=1.0
+Name=Keysafe
+Comment=Autostart
+Terminal=false
+Exec=keysafe --autostart
+Categories=
+
diff --git a/keysafe.cabal b/keysafe.cabal
index a01983d..dc90e3c 100644
--- a/keysafe.cabal
+++ b/keysafe.cabal
@@ -24,6 +24,7 @@ Extra-Source-Files:
   keysafe.1
   keysafe.service
   keysafe.desktop
+  keysafe.autostart
   Makefile
 
 Executable keysafe
@@ -69,11 +70,14 @@ Executable keysafe
     , SafeSemaphore == 0.10.*
     , crypto-random == 0.0.*
     , async == 2.1.*
+    , unix-compat == 0.4.*
+    , exceptions == 0.8.*
     -- Temporarily inlined due to FTBFS bug
     -- https://github.com/ocharles/argon2/issues/2
     -- argon2 == 1.1.*
   Extra-Libraries: argon2
   Other-Modules:
+    AutoStart
     BackupRecord
     Benchmark
     ByteStrings
@@ -110,6 +114,11 @@ Executable keysafe
     UI.Readline
     UI.NonInteractive
     UI.Zenity
+    Utility.Data
+    Utility.Env
+    Utility.Exception
+    Utility.FreeDesktop
+    Utility.UserInfo
 
 source-repository head
   type: git
diff --git a/keysafe.hs b/keysafe.hs
index be5850b..6d5186a 100644
--- a/keysafe.hs
+++ b/keysafe.hs
@@ -20,6 +20,7 @@ import SecretKey
 import Share
 import Storage
 import BackupRecord
+import AutoStart
 import HTTP.Server
 import ServerBackup
 import qualified Gpg
@@ -64,11 +65,10 @@ dispatch cmdline ui storagelocations tunables possibletunables = do
 			=<< Gpg.getKeyToBackup ui
 	go CmdLine.Restore Nothing =
 		restore cmdline storagelocations ui possibletunables Gpg.anyKey
-	go CmdLine.UploadQueued _ = do
-		problems <- uploadQueued (CmdLine.localstoragedirectory cmdline)
-		if null problems
-			then return ()
-			else showError ui ("Problem uploading queued data to servers:\n\n" ++ unlines problems ++ "\n\nYour secret keys have not yet been backed up.")
+	go CmdLine.UploadQueued _ =
+		uploadQueued ui (CmdLine.localstoragedirectory cmdline)
+	go CmdLine.AutoStart _ =
+		autoStart ui (CmdLine.localstoragedirectory cmdline)
 	go (CmdLine.Server) _ =
 		runServer
 			(CmdLine.localstoragedirectory cmdline)
@@ -86,6 +86,7 @@ dispatch cmdline ui storagelocations tunables possibletunables = do
 
 backup :: CmdLine.CmdLine -> StorageLocations -> UI -> Tunables -> SecretKeySource -> SecretKey -> IO ()
 backup cmdline storagelocations ui tunables secretkeysource secretkey = do
+	installAutoStartFile
 	username <- userName
 	Name theirname <- case CmdLine.name cmdline of
 		Just n -> pure n
@@ -118,7 +119,10 @@ backup cmdline storagelocations ui tunables secretkeysource secretkey = do
 			StoreSuccess -> do
 				storeBackupRecord backuprecord
 				if queued
-					then showInfo ui "Backup queued" "Some data was not sucessfully uploaded to servers, and has been queued for later upload. Run keysafe --uploadqueued at a later point to finish the backup."
+					then do
+						willautostart <- isAutoStartFileInstalled
+						showInfo ui "Backup queued" $ "Some data was not sucessfully uploaded to servers, and has been queued for later upload."
+							++ if willautostart then "" else " Run keysafe --uploadqueued at a later point to finish the backup."
 					else showInfo ui "Backup success" "Your secret key was successfully encrypted and backed up."
 			StoreFailure s -> showError ui ("There was a problem storing your encrypted secret key: " ++ s)
 			StoreAlreadyExists -> do
@@ -326,3 +330,14 @@ userName :: IO Name
 userName = do
 	u <- getUserEntryForID =<< getEffectiveUserID
 	return $ Name $ BU8.fromString $ takeWhile (/= ',') (userGecos u)
+
+uploadQueued :: UI -> Maybe LocalStorageDirectory -> IO ()
+uploadQueued ui d = do
+	problems <- tryUploadQueued d
+	if null problems
+		then return ()
+		else showError ui ("Problem uploading queued data to servers:\n\n" ++ unlines problems ++ "\n\nYour secret keys have not yet been backed up.")
+
+autoStart :: UI -> Maybe LocalStorageDirectory -> IO ()
+autoStart ui d = do
+	uploadQueued ui d