diff options
| -rw-r--r-- | AutoStart.hs | 42 | ||||
| -rw-r--r-- | CHANGELOG | 2 | ||||
| -rw-r--r-- | CmdLine.hs | 6 | ||||
| -rw-r--r-- | INSTALL | 2 | ||||
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | Storage.hs | 4 | ||||
| -rw-r--r-- | TODO | 4 | ||||
| -rw-r--r-- | Utility/Exception.hs | 113 | ||||
| -rw-r--r-- | Utility/FreeDesktop.hs | 147 | ||||
| -rw-r--r-- | keysafe.autostart | 9 | ||||
| -rw-r--r-- | keysafe.cabal | 9 | ||||
| -rw-r--r-- | keysafe.hs | 27 |
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 + [] @@ -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 @@ -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/" @@ -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. @@ -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 @@ -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 @@ -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 @@ -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 |