git annex webapp now opens a browser to the webapp
Also, starts the assistant if it wasn't already running.
This commit is contained in:
Joey Hess
parent
e6ce54de82
commit
1ffef3ad75
6 changed files with 122 additions and 23 deletions
|
|
@ -152,7 +152,7 @@ startDaemon assistant foreground
|
|||
, mountWatcherThread st dstatus scanremotes
|
||||
, transferScannerThread st scanremotes transferqueue
|
||||
#ifdef WITH_WEBAPP
|
||||
, webAppThread dstatus
|
||||
, webAppThread st dstatus
|
||||
#endif
|
||||
, watchThread st dstatus transferqueue changechan
|
||||
]
|
||||
|
|
|
|||
|
|
@ -10,10 +10,12 @@
|
|||
module Assistant.Threads.WebApp where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Utility.WebApp
|
||||
|
||||
import Yesod
|
||||
import Network.Socket (PortNumber)
|
||||
|
||||
data WebApp = WebApp DaemonStatusHandle
|
||||
|
||||
|
|
@ -30,14 +32,33 @@ getHomeR = defaultLayout [whamlet|Hello, World<p><a href=@{ConfigR}>config|]
|
|||
getConfigR :: Handler RepHtml
|
||||
getConfigR = defaultLayout [whamlet|<a href=@{HomeR}>main|]
|
||||
|
||||
webAppThread :: DaemonStatusHandle -> IO ()
|
||||
webAppThread dstatus = do
|
||||
webAppThread :: ThreadState -> DaemonStatusHandle -> IO ()
|
||||
webAppThread st dstatus = do
|
||||
app <- toWaiApp (WebApp dstatus)
|
||||
app' <- ifM debugEnabled
|
||||
( return $ httpDebugLogger app
|
||||
, return app
|
||||
)
|
||||
runWebApp app' browser
|
||||
runWebApp app' $ \p -> runThreadState st $ writeHtmlShim p
|
||||
|
||||
{- Creates a html shim file that's used to redirect into the webapp. -}
|
||||
writeHtmlShim :: PortNumber -> Annex ()
|
||||
writeHtmlShim port = do
|
||||
htmlshim <- fromRepo gitAnnexHtmlShim
|
||||
liftIO $ writeFile htmlshim $ genHtmlShim port
|
||||
|
||||
{- TODO: generate this static file using Yesod. -}
|
||||
genHtmlShim :: PortNumber -> String
|
||||
genHtmlShim port = unlines
|
||||
[ "<html>"
|
||||
, "<head>"
|
||||
, "<meta http-equiv=\"refresh\" content=\"0; URL=" ++ url ++ "\">"
|
||||
, "</head>"
|
||||
, "<body>"
|
||||
, "<p>"
|
||||
, "<a href=\"" ++ url ++ "\">Starting webapp...</a>"
|
||||
, "</p>"
|
||||
, "</body>"
|
||||
]
|
||||
where
|
||||
browser p = void $
|
||||
runBrowser $ "http://" ++ localhost ++ ":" ++ show p
|
||||
url = "http://localhost:" ++ show port ++ "/"
|
||||
|
|
|
|||
58
Command/WebApp.hs
Normal file
58
Command/WebApp.hs
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
{- 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 Utility.WebApp
|
||||
import Utility.Daemon
|
||||
import qualified Annex
|
||||
|
||||
import Control.Concurrent
|
||||
import System.Posix.Process
|
||||
|
||||
def :: [Command]
|
||||
def = [command "webapp" paramNothing seek "launch webapp"]
|
||||
|
||||
seek :: [CommandSeek]
|
||||
seek = [withNothing start]
|
||||
|
||||
start :: CommandStart
|
||||
start = notBareRepo $ do
|
||||
r <- checkpid
|
||||
when (r == Nothing) $
|
||||
startassistant
|
||||
f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim
|
||||
let url = "file://" ++ f
|
||||
ifM (liftIO $ runBrowser url)
|
||||
( stop
|
||||
, error $ "failed to start web browser on url " ++ url
|
||||
)
|
||||
where
|
||||
checkpid = do
|
||||
pidfile <- fromRepo gitAnnexPidFile
|
||||
liftIO $ checkDaemon pidfile
|
||||
startassistant = do
|
||||
{- Fork a separate process to run the assistant,
|
||||
- with a copy of the Annex state. -}
|
||||
state <- Annex.getState id
|
||||
liftIO $ void $ forkProcess $
|
||||
Annex.eval state $ startDaemon True False
|
||||
waitdaemon (100 :: Int)
|
||||
waitdaemon 0 = error "failed to start git-annex assistant"
|
||||
waitdaemon n = do
|
||||
r <- checkpid
|
||||
case r of
|
||||
Just _ -> return ()
|
||||
Nothing -> do
|
||||
liftIO $
|
||||
threadDelay 100000 -- 0.1 seconds
|
||||
|
||||
|
||||
waitdaemon (n - 1)
|
||||
|
|
@ -63,6 +63,9 @@ import qualified Command.Version
|
|||
#ifdef WITH_ASSISTANT
|
||||
import qualified Command.Watch
|
||||
import qualified Command.Assistant
|
||||
#ifdef WITH_WEBAPP
|
||||
import qualified Command.WebApp
|
||||
#endif
|
||||
#endif
|
||||
|
||||
cmds :: [Command]
|
||||
|
|
@ -108,6 +111,9 @@ cmds = concat
|
|||
#ifdef WITH_ASSISTANT
|
||||
, Command.Watch.def
|
||||
, Command.Assistant.def
|
||||
#ifdef WITH_WEBAPP
|
||||
, Command.WebApp.def
|
||||
#endif
|
||||
#endif
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ module Locations (
|
|||
gitAnnexPidFile,
|
||||
gitAnnexDaemonStatusFile,
|
||||
gitAnnexLogFile,
|
||||
gitAnnexHtmlShim,
|
||||
gitAnnexSshDir,
|
||||
gitAnnexRemotesDir,
|
||||
isLinkToAnnex,
|
||||
|
|
@ -166,6 +167,10 @@ gitAnnexDaemonStatusFile r = gitAnnexDir r </> "daemon.status"
|
|||
gitAnnexLogFile :: Git.Repo -> FilePath
|
||||
gitAnnexLogFile r = gitAnnexDir r </> "daemon.log"
|
||||
|
||||
{- Html shim file used to launch the webapp. -}
|
||||
gitAnnexHtmlShim :: Git.Repo -> FilePath
|
||||
gitAnnexHtmlShim r = gitAnnexDir r </> "webapp.html"
|
||||
|
||||
{- .git/annex/ssh/ is used for ssh connection caching -}
|
||||
gitAnnexSshDir :: Git.Repo -> FilePath
|
||||
gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"
|
||||
|
|
|
|||
|
|
@ -62,24 +62,33 @@ lockPidFile onfailure file = do
|
|||
where
|
||||
newfile = file ++ ".new"
|
||||
|
||||
{- Stops the daemon.
|
||||
{- Checks if the daemon is running, by checking that the pid file
|
||||
- is locked by the same process that is listed in the pid file.
|
||||
-
|
||||
- The pid file is used to get the daemon's pid.
|
||||
-
|
||||
- To guard against a stale pid, check the lock of the pid file,
|
||||
- and compare the process that has it locked with the file content.
|
||||
-}
|
||||
stopDaemon :: FilePath -> IO ()
|
||||
stopDaemon pidfile = do
|
||||
fd <- openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
|
||||
locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
|
||||
p <- readish <$> readFile pidfile
|
||||
case (locked, p) of
|
||||
(Nothing, _) -> noop
|
||||
(_, Nothing) -> noop
|
||||
(Just (pid, _), Just pid')
|
||||
| pid == pid' -> signalProcess sigTERM pid
|
||||
| otherwise -> error $
|
||||
- If it's running, returns its pid. -}
|
||||
checkDaemon :: FilePath -> IO (Maybe ProcessID)
|
||||
checkDaemon pidfile = do
|
||||
v <- catchMaybeIO $
|
||||
openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
|
||||
case v of
|
||||
Just fd -> do
|
||||
locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
|
||||
p <- readish <$> readFile pidfile
|
||||
return $ check locked p
|
||||
Nothing -> return Nothing
|
||||
where
|
||||
check Nothing _ = Nothing
|
||||
check _ Nothing = Nothing
|
||||
check (Just (pid, _)) (Just pid')
|
||||
| pid == pid' = Just pid
|
||||
| otherwise = error $
|
||||
"stale pid in " ++ pidfile ++
|
||||
" (got " ++ show pid' ++
|
||||
"; expected" ++ show pid ++ " )"
|
||||
|
||||
{- Stops the daemon, safely. -}
|
||||
stopDaemon :: FilePath -> IO ()
|
||||
stopDaemon pidfile = go =<< checkDaemon pidfile
|
||||
where
|
||||
go Nothing = noop
|
||||
go (Just pid) = signalProcess sigTERM pid
|
||||
|
|
|
|||
Loading…
Reference in a new issue