diff options
| -rw-r--r-- | Assistant.hs | 7 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 8 | ||||
| -rw-r--r-- | Command/Watch.hs | 2 | ||||
| -rw-r--r-- | Command/WebApp.hs | 72 | ||||
| -rw-r--r-- | Usage.hs | 2 | ||||
| -rw-r--r-- | Utility/WebApp.hs | 27 | ||||
| -rw-r--r-- | debian/changelog | 2 | ||||
| -rw-r--r-- | doc/git-annex.mdwn | 11 | ||||
| -rw-r--r-- | git-annex.cabal | 2 |
9 files changed, 89 insertions, 44 deletions
diff --git a/Assistant.hs b/Assistant.hs index 0d9dafd96..92cc275b5 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -161,6 +161,7 @@ import Utility.ThreadScheduler import qualified Build.SysConfig as SysConfig import System.Log.Logger +import Network.Socket (HostName) stopDaemon :: Annex () stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile @@ -170,8 +171,8 @@ stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile - - startbrowser is passed the url and html shim file, as well as the original - stdout and stderr descriptors. -} -startDaemon :: Bool -> Bool -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () -startDaemon assistant foreground startbrowser = do +startDaemon :: Bool -> Bool -> Maybe HostName -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () +startDaemon assistant foreground listenhost startbrowser = do pidfile <- fromRepo gitAnnexPidFile logfile <- fromRepo gitAnnexLogFile logfd <- liftIO $ openLog logfile @@ -218,7 +219,7 @@ startDaemon assistant foreground startbrowser = do mapM_ (startthread urlrenderer) [ watch $ commitThread #ifdef WITH_WEBAPP - , assist $ webAppThread d urlrenderer False Nothing webappwaiter + , assist $ webAppThread d urlrenderer False listenhost Nothing webappwaiter #ifdef WITH_PAIRING , assist $ pairListenerThread urlrenderer #endif diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index b7bfd0c4a..6fadd7be7 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -38,7 +38,7 @@ import Git import Yesod import Yesod.Static -import Network.Socket (SockAddr) +import Network.Socket (SockAddr, HostName) import Data.Text (pack, unpack) mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") @@ -49,10 +49,11 @@ webAppThread :: AssistantData -> UrlRenderer -> Bool + -> Maybe HostName -> Maybe (IO String) -> Maybe (Url -> FilePath -> IO ()) -> NamedThread -webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ liftIO $ do +webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup = thread $ liftIO $ do webapp <- WebApp <$> pure assistantdata <*> (pack <$> genRandomToken) @@ -60,13 +61,14 @@ webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ <*> pure $(embed "static") <*> pure postfirstrun <*> pure noannex + <*> pure listenhost setUrlRenderer urlrenderer $ yesodRender webapp (pack "") app <- toWaiAppPlain webapp app' <- ifM debugEnabled ( return $ httpDebugLogger app , return app ) - runWebApp app' $ \addr -> if noannex + runWebApp listenhost app' $ \addr -> if noannex then withTempFile "webapp.html" $ \tmpfile _ -> go addr webapp tmpfile Nothing else do diff --git a/Command/Watch.hs b/Command/Watch.hs index f965c30cd..c5fd1a8cd 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -31,5 +31,5 @@ start :: Bool -> Bool -> Bool -> CommandStart start assistant foreground stopdaemon = do if stopdaemon then stopDaemon - else startDaemon assistant foreground Nothing -- does not return + else startDaemon assistant foreground Nothing Nothing -- does not return stop diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 33d6f536a..2d01b0d15 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -23,24 +23,33 @@ 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 = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $ +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 = [withNothing start] +seek = [withField listenOption return $ \listenhost -> + withNothing $ start listenhost] -start :: CommandStart +start :: Maybe HostName -> CommandStart start = start' True -start' :: Bool -> CommandStart -start' allowauto = do +start' :: Bool -> Maybe HostName -> CommandStart +start' allowauto listenhost = do liftIO $ ensureInstalled ifM isInitialized ( go , auto ) stop @@ -49,10 +58,14 @@ start' allowauto = do browser <- fromRepo webBrowser f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim ifM (checkpid <&&> checkshim f) - ( liftIO $ openBrowser browser f Nothing Nothing - , startDaemon True True $ Just $ - \origout origerr _url htmlshim -> - openBrowser browser htmlshim origout origerr + ( 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 @@ -68,13 +81,20 @@ start' allowauto = do - 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 + [] -> firstRun listenhost (d:_) -> do changeWorkingDirectory d state <- Annex.new =<< Git.CurrentRepo.get - void $ Annex.eval state $ doCommand $ start' False + 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 @@ -89,8 +109,8 @@ startNoRepo = do - 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 +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 @@ -104,7 +124,7 @@ firstRun = do let callback a = Just $ a v runAssistant d $ do startNamedThread urlrenderer $ - webAppThread d urlrenderer True + webAppThread d urlrenderer True listenhost (callback signaler) (callback mainthread) waitNamedThreads @@ -112,15 +132,21 @@ firstRun = do signaler v = do putMVar v "" takeMVar v - mainthread v _url htmlshim = do - browser <- maybe Nothing webBrowser <$> Git.Config.global - openBrowser browser htmlshim Nothing Nothing - - _wait <- takeMVar v - - state <- Annex.new =<< Git.CurrentRepo.get - Annex.eval state $ - startDaemon True True $ Just $ sendurlback 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 () @@ -95,6 +95,8 @@ paramGroup :: String paramGroup = "GROUP" paramSize :: String paramSize = "SIZE" +paramAddress :: String +paramAddress = "ADDRESS" paramKeyValue :: String paramKeyValue = "K=V" paramNothing :: String diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index e7a43eade..029fa25de 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -37,7 +37,7 @@ import Data.Monoid import Control.Arrow ((***)) import Control.Concurrent -localhost :: String +localhost :: HostName localhost = "localhost" {- Command to use to run a web browser. -} @@ -48,14 +48,15 @@ browserCommand = "open" browserCommand = "xdg-open" #endif -{- Binds to a socket on localhost, and runs a webapp on it. +{- Binds to a socket on localhost, or possibly a different specified + - hostname or address, and runs a webapp on it. - - An IO action can also be run, to do something with the address, - such as start a web browser to view the webapp. -} -runWebApp :: Wai.Application -> (SockAddr -> IO ()) -> IO () -runWebApp app observer = do - sock <- localSocket +runWebApp :: Maybe HostName -> Wai.Application -> (SockAddr -> IO ()) -> IO () +runWebApp h app observer = do + sock <- getSocket h void $ forkIO $ runSettingsSocket webAppSettings sock app observer =<< getSocketName sock @@ -65,21 +66,23 @@ webAppSettings = defaultSettings { settingsTimeout = 30 * 60 } -{- Binds to a local socket, selecting any free port. +{- Binds to a local socket, or if specified, to a socket on the specified + - hostname or address. Selets any free port. - - Prefers to bind to the ipv4 address rather than the ipv6 address - of localhost, if it's available. - - - - As a (very weak) form of security, only connections from - - localhost are accepted. -} -localSocket :: IO Socket -localSocket = do - addrs <- getAddrInfo (Just hints) (Just localhost) Nothing + -} +getSocket :: Maybe HostName -> IO Socket +getSocket h = do + addrs <- getAddrInfo (Just hints) hostname Nothing case (partition (\a -> addrFamily a == AF_INET) addrs) of (v4addr:_, _) -> go v4addr (_, v6addr:_) -> go v6addr _ -> error "unable to bind to a local socket" where + hostname + | isJust h = h + | otherwise = Just localhost hints = defaultHints { addrFlags = [AI_ADDRCONFIG] , addrSocketType = Stream diff --git a/debian/changelog b/debian/changelog index 2650ba0ed..4a49f0672 100644 --- a/debian/changelog +++ b/debian/changelog @@ -10,6 +10,8 @@ git-annex (4.20130406) UNRELEASED; urgency=low directories is preferred until it has reached an archive or smallarchive repository. * Avoid using runghc when building the Debian package, as that needs ghci. + * webapp: New --listen= option allows running the webapp on one computer + and connecting to it from another. (Note: Does not yet use HTTPS.) -- Joey Hess <joeyh@debian.org> Sat, 06 Apr 2013 15:24:15 -0400 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 2f4bb5cdb..83ed78257 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -198,9 +198,18 @@ subdirectories). * webapp - Runs a web app, that allows easy setup of a git-annex repository, + Opens a web app, that allows easy setup of a git-annex repository, and control of the git-annex assistant. + By default, the webapp can only be accessed from localhost, and running + it opens a browser window. + + With the --listen= option, the webapp can be made to listen for + connections on the specified address. This disables running a + local web browser, and outputs the url you can use to open the webapp + from a remote computer. + Note that this does not yet use HTTPS for security, so use with caution! + # REPOSITORY SETUP COMMANDS * init [description] diff --git a/git-annex.cabal b/git-annex.cabal index 5e67fc96b..263f2f163 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 4.20130405 +Version: 4.20130406 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net> |