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
|
{- 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.DaemonStatus
import Assistant.ScanRemotes
import Assistant.TransferQueue
import Assistant.TransferSlots
import Assistant.Threads.WebApp
import Assistant.WebApp
import Assistant.Install
import Utility.WebApp
import Utility.Daemon (checkDaemon, lockPidFile)
import Init
import qualified Git
import qualified Git.Config
import qualified Git.CurrentRepo
import qualified Annex
import Locations.UserConfig
import System.Posix.Directory
import Control.Concurrent
import Control.Concurrent.STM
def :: [Command]
def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
command "webapp" paramNothing seek "launch webapp"]
seek :: [CommandSeek]
seek = [withNothing start]
start :: CommandStart
start = notBareRepo $ do
liftIO $ ensureInstalled
ifM isInitialized ( go , liftIO startNoRepo )
stop
where
go = do
browser <- fromRepo webBrowser
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
ifM (checkpid <&&> checkshim f)
( liftIO $ openBrowser browser f
, startDaemon True True $ Just $
const $ openBrowser browser
)
checkpid = do
pidfile <- fromRepo gitAnnexPidFile
liftIO $ isJust <$> checkDaemon pidfile
checkshim f = liftIO $ doesFileExist f
{- When run without a repo, see if there is an autoStartFile,
- and if so, start the first available listed repository.
- If not, it's our first time being run! -}
startNoRepo :: IO ()
startNoRepo = do
autostartfile <- autoStartFile
ifM (doesFileExist autostartfile) ( autoStart autostartfile , firstRun )
autoStart :: FilePath -> IO ()
autoStart autostartfile = do
dirs <- lines <$> readFile autostartfile
edirs <- filterM doesDirectoryExist dirs
case edirs of
[] -> firstRun -- what else can I do? Nothing works..
(d:_) -> do
changeWorkingDirectory d
state <- Annex.new =<< Git.CurrentRepo.get
void $ Annex.eval state $ doCommand start
{- 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 :: IO ()
firstRun = do
dstatus <- atomically . newTMVar =<< newDaemonStatus
scanremotes <- newScanRemoteMap
transferqueue <- newTransferQueue
transferslots <- newTransferSlots
urlrenderer <- newUrlRenderer
v <- newEmptyMVar
let callback a = Just $ a v
void $ runNamedThread dstatus $
webAppThread Nothing dstatus scanremotes
transferqueue transferslots urlrenderer
(callback signaler) (callback mainthread)
where
signaler v = do
putMVar v ""
takeMVar v
mainthread v _url htmlshim = do
browser <- maybe Nothing webBrowser <$> Git.Config.global
openBrowser browser htmlshim
_wait <- takeMVar v
state <- Annex.new =<< Git.CurrentRepo.get
Annex.eval state $ do
dummydaemonize
startAssistant True id $ Just $ sendurlback v
sendurlback v url _htmlshim = putMVar v url
{- Set up the pid file in the new repo. -}
dummydaemonize =
liftIO . lockPidFile =<< fromRepo gitAnnexPidFile
openBrowser :: Maybe FilePath -> FilePath -> IO ()
openBrowser cmd htmlshim = go $ maybe runBrowser runCustomBrowser cmd
where
url = fileUrl htmlshim
go a = unlessM (a url) $
error $ "failed to start web browser on url " ++ url
runCustomBrowser c u = boolSystem c [Param u]
{- 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
|
