mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

git annex webapp now opens a browser to the webapp

Browse source 
Also, starts the assistant if it wasn't already running.
This commit is contained in:
Joey Hess 2012-07-25 23:13:01 -04:00
parent e6ce54de82
commit 1ffef3ad75
6 changed files with 122 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Assistant.hs
View file

@ -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
]

31
Assistant/Threads/WebApp.hs
View file

@ -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
View 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)

6
GitAnnex.hs
View file

@ -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
]

5
Locations.hs
View file

@ -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"

39
Utility/Daemon.hs
View file

@ -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
- 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
case (locked, p) of
(Nothing, _) -> noop
(_, Nothing) -> noop
(Just (pid, _), Just pid')
| pid == pid' -> signalProcess sigTERM pid
| otherwise -> error $
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