Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: d20cd192cc
Fetching contributors…

Cannot retrieve contributors at this time

123 lines (107 sloc) 3.385 kB
{- Generating and installing a desktop menu entry file
- and a desktop autostart file. (And OSX equivilants.)
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Build.InstallDesktopFile where
import Utility.Exception
import Utility.FreeDesktop
import Utility.Path
import Utility.Monad
import Locations.UserConfig
import Utility.OSX
import Assistant.Install.AutoStart
import Control.Applicative
import System.Directory
import System.Environment
import System.Posix.User
import System.Posix.Files
import System.FilePath
import Data.Maybe
{- The command can be either just "git-annex", or the full path to use
- to run it. -}
desktop :: FilePath -> DesktopEntry
desktop command = genDesktopEntry
"Git Annex"
"Track and sync the files in your Git Annex"
False
(command ++ " webapp")
["Network", "FileTransfer"]
autostart :: FilePath -> DesktopEntry
autostart command = genDesktopEntry
"Git Annex Assistant"
"Autostart"
False
(command ++ " assistant --autostart")
[]
systemwideInstall :: IO Bool
systemwideInstall = isroot <||> destdirset
where
isroot = do
uid <- fromIntegral <$> getRealUserID
return $ uid == (0 :: Int)
destdirset = isJust <$> catchMaybeIO (getEnv "DESTDIR")
inDestDir :: FilePath -> IO FilePath
inDestDir f = do
destdir <- catchDefaultIO "" (getEnv "DESTDIR")
return $ destdir ++ "/" ++ f
writeFDODesktop :: FilePath -> IO ()
writeFDODesktop command = do
datadir <- ifM systemwideInstall ( return systemDataDir, userDataDir )
writeDesktopMenuFile (desktop command)
=<< inDestDir (desktopMenuFilePath "git-annex" datadir)
configdir <- ifM systemwideInstall ( return systemConfigDir, userConfigDir )
writeDesktopMenuFile (autostart command)
=<< inDestDir (autoStartPath "git-annex" configdir)
writeOSXDesktop :: FilePath -> IO ()
writeOSXDesktop command = do
installAutoStart command =<< inDestDir =<< ifM systemwideInstall
( return $ systemAutoStart autoStartLabel
, userAutoStart autoStartLabel
)
{- Install the OSX app in non-self-contained mode. -}
let appdir = "git-annex.app"
installOSXAppFile appdir "Contents/Info.plist" Nothing
installOSXAppFile appdir "Contents/Resources/git-annex.icns" Nothing
installOSXAppFile appdir "Contents/MacOS/git-annex-webapp" (Just webappscript)
where
webappscript = unlines
[ "#!/bin/sh"
, command ++ " webapp"
]
installOSXAppFile :: FilePath -> FilePath -> Maybe String -> IO ()
installOSXAppFile appdir appfile mcontent = do
let src = "ui-macos" </> appdir </> appfile
home <- myHomeDir
dest <- ifM systemwideInstall
( return $ "/Applications" </> appdir </> appfile
, return $ home </> "Desktop" </> appdir </> appfile
)
createDirectoryIfMissing True (parentDir dest)
case mcontent of
Just content -> writeFile dest content
Nothing -> copyFile src dest
mode <- fileMode <$> getFileStatus src
setFileMode dest mode
install :: FilePath -> IO ()
install command = do
#ifdef darwin_HOST_OS
writeOSXDesktop command
#else
writeFDODesktop command
#endif
ifM systemwideInstall
( return ()
, do
programfile <- inDestDir =<< programFile
createDirectoryIfMissing True (parentDir programfile)
writeFile programfile command
)
main :: IO ()
main = getArgs >>= go
where
go [] = error "specify git-annex command"
go (command:_) = install command
Jump to Line
Something went wrong with that request. Please try again.