summaryrefslogtreecommitdiff
path: root/Build/InstallDesktopFile.hs
blob: 9e4229024757e434f204aab38da894672cbd49d8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
{- 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 Control.Applicative
import Control.Monad
import System.Directory
import System.Environment
import System.Posix.User
import System.Posix.Types
import System.Posix.Files
import System.FilePath

{- 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")
	[]

isRoot :: IO Bool
isRoot = do
	uid <- fromIntegral <$> getRealUserID
	return $ uid == 0

inDestDir :: FilePath -> IO FilePath
inDestDir f = do
	destdir <- catchDefaultIO "" (getEnv "DESTDIR")
	return $ destdir </> f

writeFDODesktop :: FilePath -> IO ()
writeFDODesktop command = do
	datadir <- ifM isRoot ( return systemDataDir, userDataDir )
	writeDesktopMenuFile (desktop command) 
		=<< inDestDir (desktopMenuFilePath "git-annex" datadir)

	configdir <- ifM isRoot ( return systemConfigDir, userConfigDir )
	writeDesktopMenuFile (autostart command) 
		=<< inDestDir (autoStartPath "git-annex" configdir)

	ifM isRoot
		( return ()
		, do
			programfile <- inDestDir =<< programFile
			createDirectoryIfMissing True (parentDir programfile)
			writeFile programfile command
		)

writeOSXDesktop :: FilePath -> IO ()
writeOSXDesktop command = do
	home <- myHomeDir

	let base = "Library" </> "LaunchAgents" </> label ++ ".plist"
	autostart <- ifM isRoot ( inDestDir $ "/" </> base , inDestDir $ home </> base)
	createDirectoryIfMissing True (parentDir autostart)
	writeFile autostart $ genOSXAutoStartFile label command

	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
		label = "com.branchable.git-annex.assistant"
		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 isRoot
		( 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

genOSXAutoStartFile :: String -> String -> String
genOSXAutoStartFile label command = unlines
	[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
	, "<!DOCTYPE plist PUBLIC \"-//Apple//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">"
	, "<plist version=\"1.0\">"
	, "<dict>"
	, "<key>Label</key>"
	, "<string>" ++ label ++ "</string>"
	, "<key>ProgramArguments</key>"
	, "<array>"
	, "<string>" ++ command ++ "</string>"
	, "<string>assistant</string>"
	, "<string>--autostart</string>"
	, "</array>"
	, "<key>RunAtLoad</key>"
	, "</dict>"
	, "</plist>"
	]

writeDesktop :: FilePath -> IO ()
#ifdef darwin_HOST_OS
writeDesktop = writeOSXDesktop
#else
writeDesktop = writeFDODesktop
#endif

main = getArgs >>= go
	where
		go [] = error "specify git-annex command"
		go (command:_) = writeDesktop command