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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
{- git-annex webapp launcher
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.WebApp where
import Common.Annex
import Command
import Assistant
import Assistant.Common
import Assistant.NamedThread
import Assistant.Threads.WebApp
import Assistant.WebApp
import Assistant.Install
import Utility.WebApp
import Utility.Daemon (checkDaemon)
import Init
import qualified Git
import qualified Git.Config
import qualified Git.CurrentRepo
import qualified Annex
import Locations.UserConfig
import qualified Option
import System.Posix.Directory
import Control.Concurrent
import Control.Concurrent.STM
import System.Process (env, std_out, std_err)
import Network.Socket (HostName)
import System.Environment
def :: [Command]
def = [ withOptions [listenOption] $
noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $
command "webapp" paramNothing seek SectionCommon "launch webapp"]
listenOption :: Option
listenOption = Option.field [] "listen" paramAddress
"accept connections to this address"
seek :: [CommandSeek]
seek = [withField listenOption return $ \listenhost ->
withNothing $ start listenhost]
start :: Maybe HostName -> CommandStart
start = start' True
start' :: Bool -> Maybe HostName -> CommandStart
start' allowauto listenhost = do
liftIO $ ensureInstalled
ifM isInitialized ( go , auto )
stop
where
go = do
browser <- fromRepo webBrowser
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
ifM (checkpid <&&> checkshim f)
( if isJust listenhost
then error "The assistant is already running, so --listen cannot be used."
else liftIO $ openBrowser browser f Nothing Nothing
, startDaemon True True listenhost $ Just $
\origout origerr url htmlshim ->
if isJust listenhost
then maybe noop (`hPutStrLn` url) origout
else openBrowser browser htmlshim origout origerr
)
auto
| allowauto = liftIO startNoRepo
| otherwise = do
d <- liftIO getCurrentDirectory
error $ "no git repository in " ++ d
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
liftIO $ isJust <$> checkDaemon pidfile
checkshim f = liftIO $ doesFileExist f
{- When run without a repo, start the first available listed repository in
- the autostart file. If not, it's our first time being run! -}
startNoRepo :: IO ()
startNoRepo = do
-- FIXME should be able to reuse regular getopt, but
-- it currently runs in the Annex monad.
args <- getArgs
let listenhost = headMaybe $ map (snd . separate (== '=')) $
filter ("--listen=" `isPrefixOf`) args
dirs <- liftIO $ filterM doesDirectoryExist =<< readAutoStartFile
case dirs of
[] -> firstRun listenhost
(d:_) -> do
changeWorkingDirectory d
state <- Annex.new =<< Git.CurrentRepo.get
void $ Annex.eval state $ doCommand $
start' False listenhost
{- Run the webapp without a repository, which prompts the user, makes one,
- changes to it, starts the regular assistant, and redirects the
- browser to its url.
-
- This is a very tricky dance -- The first webapp calls the signaler,
- which signals the main thread when it's ok to continue by writing to a
- MVar. The main thread starts the second webapp, and uses its callback
- to write its url back to the MVar, from where the signaler retrieves it,
- returning it to the first webapp, which does the redirect.
-
- Note that it's important that mainthread never terminates! Much
- of this complication is due to needing to keep the mainthread running.
-}
firstRun :: Maybe HostName -> IO ()
firstRun listenhost = do
{- Without a repository, we cannot have an Annex monad, so cannot
- get a ThreadState. Using undefined is only safe because the
- webapp checks its noAnnex field before accessing the
- threadstate. -}
let st = undefined
{- Get a DaemonStatus without running in the Annex monad. -}
dstatus <- atomically . newTMVar =<< newDaemonStatus
d <- newAssistantData st dstatus
urlrenderer <- newUrlRenderer
v <- newEmptyMVar
let callback a = Just $ a v
runAssistant d $ do
startNamedThread urlrenderer $
webAppThread d urlrenderer True listenhost
(callback signaler)
(callback mainthread)
waitNamedThreads
where
signaler v = do
putMVar v ""
takeMVar v
mainthread v url htmlshim
| isJust listenhost = do
putStrLn url
go
| otherwise = do
browser <- maybe Nothing webBrowser <$> Git.Config.global
openBrowser browser htmlshim Nothing Nothing
go
where
go = do
_wait <- takeMVar v
state <- Annex.new =<< Git.CurrentRepo.get
Annex.eval state $
startDaemon True True listenhost $ Just $
sendurlback v
sendurlback v _origout _origerr url _htmlshim = putMVar v url
openBrowser :: Maybe FilePath -> FilePath -> Maybe Handle -> Maybe Handle -> IO ()
openBrowser cmd htmlshim outh errh = do
hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url
environ <- cleanEnvironment
(_, _, _, pid) <- createProcess p
{ env = environ
, std_out = maybe Inherit UseHandle outh
, std_err = maybe Inherit UseHandle errh
}
exitcode <- waitForProcess pid
unless (exitcode == ExitSuccess) $
hPutStrLn (fromMaybe stderr errh) "failed to start web browser"
where
url = fileUrl htmlshim
p = proc (fromMaybe browserCommand cmd) [htmlshim]
{- web.browser is a generic git config setting for a web browser program -}
webBrowser :: Git.Repo -> Maybe FilePath
webBrowser = Git.Config.getMaybe "web.browser"
fileUrl :: FilePath -> String
fileUrl file = "file://" ++ file
|
