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 , mountWatcherThread st dstatus scanremotes
, transferScannerThread st scanremotes transferqueue , transferScannerThread st scanremotes transferqueue
#ifdef WITH_WEBAPP #ifdef WITH_WEBAPP
, webAppThread dstatus , webAppThread st dstatus
#endif #endif
, watchThread st dstatus transferqueue changechan , watchThread st dstatus transferqueue changechan
] ]

31
Assistant/Threads/WebApp.hs
View file

@ -10,10 +10,12 @@
module Assistant.Threads.WebApp where module Assistant.Threads.WebApp where
import Assistant.Common import Assistant.Common
import Assistant.ThreadedMonad
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Utility.WebApp import Utility.WebApp
import Yesod import Yesod
import Network.Socket (PortNumber)
data WebApp = WebApp DaemonStatusHandle data WebApp = WebApp DaemonStatusHandle
@ -30,14 +32,33 @@ getHomeR = defaultLayout [whamlet|Hello, World<p><a href=@{ConfigR}>config|]
getConfigR :: Handler RepHtml getConfigR :: Handler RepHtml
getConfigR = defaultLayout [whamlet|<a href=@{HomeR}>main|] getConfigR = defaultLayout [whamlet|<a href=@{HomeR}>main|]
webAppThread :: DaemonStatusHandle -> IO () webAppThread :: ThreadState -> DaemonStatusHandle -> IO ()
webAppThread dstatus = do webAppThread st dstatus = do
app <- toWaiApp (WebApp dstatus) app <- toWaiApp (WebApp dstatus)
app' <- ifM debugEnabled app' <- ifM debugEnabled
( return $ httpDebugLogger app ( return $ httpDebugLogger app
, return 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 where
browser p = void $ url = "http://localhost:" ++ show port ++ "/"
runBrowser $ "http://" ++ localhost ++ ":" ++ show p

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 #ifdef WITH_ASSISTANT
import qualified Command.Watch import qualified Command.Watch
import qualified Command.Assistant import qualified Command.Assistant
#ifdef WITH_WEBAPP
import qualified Command.WebApp
#endif
#endif #endif
cmds :: [Command] cmds :: [Command]
@ -108,6 +111,9 @@ cmds = concat
#ifdef WITH_ASSISTANT #ifdef WITH_ASSISTANT
, Command.Watch.def , Command.Watch.def
, Command.Assistant.def , Command.Assistant.def
#ifdef WITH_WEBAPP
, Command.WebApp.def
#endif
#endif #endif
] ]

5
Locations.hs
View file

@ -27,6 +27,7 @@ module Locations (
gitAnnexPidFile, gitAnnexPidFile,
gitAnnexDaemonStatusFile, gitAnnexDaemonStatusFile,
gitAnnexLogFile, gitAnnexLogFile,
gitAnnexHtmlShim,
gitAnnexSshDir, gitAnnexSshDir,
gitAnnexRemotesDir, gitAnnexRemotesDir,
isLinkToAnnex, isLinkToAnnex,
@ -166,6 +167,10 @@ gitAnnexDaemonStatusFile r = gitAnnexDir r </> "daemon.status"
gitAnnexLogFile :: Git.Repo -> FilePath gitAnnexLogFile :: Git.Repo -> FilePath
gitAnnexLogFile r = gitAnnexDir r </> "daemon.log" 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 -} {- .git/annex/ssh/ is used for ssh connection caching -}
gitAnnexSshDir :: Git.Repo -> FilePath gitAnnexSshDir :: Git.Repo -> FilePath
gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh" gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh"

43
Utility/Daemon.hs
View file

@ -62,24 +62,33 @@ lockPidFile onfailure file = do
where where
newfile = file ++ ".new" 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. - If it's running, returns its pid. -}
- checkDaemon :: FilePath -> IO (Maybe ProcessID)
- To guard against a stale pid, check the lock of the pid file, checkDaemon pidfile = do
- and compare the process that has it locked with the file content. v <- catchMaybeIO $
-} openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
stopDaemon :: FilePath -> IO () case v of
stopDaemon pidfile = do Just fd -> do
fd <- openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) p <- readish <$> readFile pidfile
p <- readish <$> readFile pidfile return $ check locked p
case (locked, p) of Nothing -> return Nothing
(Nothing, _) -> noop where
(_, Nothing) -> noop check Nothing _ = Nothing
(Just (pid, _), Just pid') check _ Nothing = Nothing
| pid == pid' -> signalProcess sigTERM pid check (Just (pid, _)) (Just pid')
| otherwise -> error $ | pid == pid' = Just pid
| otherwise = error $
"stale pid in " ++ pidfile ++ "stale pid in " ++ pidfile ++
" (got " ++ show pid' ++ " (got " ++ show pid' ++
"; expected" ++ 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