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" (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
-- no idea where to install as root
( return $ "/Library/git-annex" </> appdir </> appfile
, return $ home </> "Desktop" </> appdir </> appfile
)
content <- maybe (readFile src) return mcontent
createDirectoryIfMissing True (parentDir dest)
writeFile dest content
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
|
