git-annex/Assistant/Install.hs

176 lines
5.3 KiB
Haskell
Raw Normal View History

{- Assistant installation
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.Install where
import Assistant.Common
import Assistant.Install.AutoStart
2013-04-23 15:38:52 +00:00
import Config.Files
import Utility.FileMode
import Utility.Shell
2013-05-12 23:19:28 +00:00
import Utility.Tmp
2013-05-11 22:23:41 +00:00
import Utility.Env
import Utility.SshConfig
2012-09-28 23:18:08 +00:00
#ifdef darwin_HOST_OS
import Utility.OSX
2012-09-28 23:18:08 +00:00
#else
import Utility.FreeDesktop
import Utility.UserInfo
2013-12-15 21:10:24 +00:00
import Assistant.Install.Menu
2012-09-28 23:18:08 +00:00
#endif
standaloneAppBase :: IO (Maybe FilePath)
standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
{- The standalone app does not have an installation process.
- So when it's run, it needs to set up autostarting of the assistant
- daemon, as well as writing the programFile, and putting the
- git-annex-shell and git-annex-wrapper wrapper scripts into ~/.ssh
-
- Note that this is done every time it's started, so if the user moves
- it around, the paths this sets up won't break.
-
- File manager hook script installation is done even for
- packaged apps, since it has to go into the user's home directory.
-}
ensureInstalled :: IO ()
ensureInstalled = go =<< standaloneAppBase
2012-10-31 06:34:03 +00:00
where
go Nothing = installFileManagerHooks "git-annex"
2012-10-31 06:34:03 +00:00
go (Just base) = do
2012-11-28 20:17:13 +00:00
let program = base </> "git-annex"
2012-10-31 06:34:03 +00:00
programfile <- programFile
createDirectoryIfMissing True (parentDir programfile)
writeFile programfile program
#ifdef darwin_HOST_OS
2012-10-31 06:34:03 +00:00
autostartfile <- userAutoStart osxAutoStartLabel
#else
2013-07-10 00:50:41 +00:00
menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
icondir <- iconDir <$> userDataDir
installMenu program menufile base icondir
2012-10-31 06:34:03 +00:00
autostartfile <- autoStartPath "git-annex" <$> userConfigDir
#endif
2012-10-31 06:34:03 +00:00
installAutoStart program autostartfile
2012-10-31 06:34:03 +00:00
sshdir <- sshDir
let runshell var = "exec " ++ base </> "runshell " ++ var
let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
installWrapper (sshdir </> "git-annex-shell") $ unlines
[ shebang_local
2012-10-31 06:34:03 +00:00
, "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
, rungitannexshell "$SSH_ORIGINAL_COMMAND"
, "else"
, rungitannexshell "$@"
, "fi"
2012-10-31 06:34:03 +00:00
]
installWrapper (sshdir </> "git-annex-wrapper") $ unlines
[ shebang_local
, "set -e"
, runshell "\"$@\""
]
installFileManagerHooks program
installWrapper :: FilePath -> String -> IO ()
installWrapper file content = do
curr <- catchDefaultIO "" $ readFileStrict file
when (curr /= content) $ do
createDirectoryIfMissing True (parentDir file)
viaTmp writeFile file content
modifyFileMode file $ addModes [ownerExecuteMode]
installFileManagerHooks :: FilePath -> IO ()
#ifdef linux_HOST_OS
installFileManagerHooks program = do
-- Gnome
nautilusScriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir
createDirectoryIfMissing True nautilusScriptdir
genNautilusScript nautilusScriptdir "get"
genNautilusScript nautilusScriptdir "drop"
-- KDE
home <- myHomeDir
let kdeServiceMenusdir = home </> ".kde" </> "share" </> "kde4" </> "services" </> "ServiceMenus"
createDirectoryIfMissing True kdeServiceMenusdir
writeFile (kdeServiceMenusdir </> "git-annex.desktop")
(kdeDesktopFile ["get", "drop"])
where
genNautilusScript scriptdir action =
installscript (scriptdir </> scriptname action) $ unlines
2014-03-23 12:17:03 +00:00
[ shebang_local
, autoaddedcomment
, "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
]
scriptname action = "git-annex " ++ action
installscript f c = whenM (safetoinstallscript f) $ do
writeFile f c
modifyFileMode f $ addModes [ownerExecuteMode]
safetoinstallscript f = catchDefaultIO True $
elem autoaddedcomment . lines <$> readFileStrict f
autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)"
autoaddedmsg = "Automatically added by git-annex, do not edit."
kdeDesktopFile actions = unlines $ concat $
kdeDesktopHeader actions : map kdeDesktopAction actions
kdeDesktopHeader actions =
[ "# " ++ autoaddedmsg
, "[Desktop Entry]"
, "Type=Service"
, "ServiceTypes=all/allfiles"
, "MimeType=all/all;"
, "Actions=" ++ intercalate ";" (map kdeDesktopSection actions)
, "X-KDE-Priority=TopLevel"
, "X-KDE-Submenu=Git-Annex"
, "X-KDE-Icon=git-annex"
, "X-KDE-ServiceTypes=KonqPopupMenu/Plugin"
]
kdeDesktopSection command = "GitAnnex" ++ command
kdeDesktopAction command =
[ ""
, "[Desktop Action " ++ kdeDesktopSection command ++ "]"
, "Name=" ++ command
, "Icon=git-annex"
2014-07-21 19:30:40 +00:00
, unwords
[ "Exec=sh -c 'cd \"$(dirname '%U')\" &&"
, program
, command
, "--notify-start --notify-finish -- %U'"
]
]
#else
installFileManagerHooks _ = noop
#endif
{- Returns a cleaned up environment that lacks settings used to make the
- standalone builds use their bundled libraries and programs.
- Useful when calling programs not included in the standalone builds.
-
- For a non-standalone build, returns Nothing.
-}
cleanEnvironment :: IO (Maybe [(String, String)])
cleanEnvironment = clean <$> getEnvironment
where
clean environ
| null vars = Nothing
| otherwise = Just $ catMaybes $ map (restoreorig environ) environ
| otherwise = Nothing
where
vars = words $ fromMaybe "" $
lookup "GIT_ANNEX_STANDLONE_ENV" environ
restoreorig oldenviron p@(k, _v)
| k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of
(Just v')
| not (null v') -> Just (k, v')
_ -> Nothing
| otherwise = Just p