webapp: New --listen= option allows running the webapp on one computer and connecting to it from another.

Does not yet use HTTPS. I'd need to generate a certificate, and I'm not
sure what's the best way to do that.

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 :: Bool -> Bool -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
-startDaemon assistant foreground startbrowser = do
+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

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

Assistant/WebApp/Types.hs

@@ -26,6 +26,7 @@ import Yesod
 import Yesod.Static
 import Text.Hamlet
 import Data.Text (Text, pack, unpack)
+import Network.Socket (HostName)
 
 publicFiles "static"
 
@@ -38,6 +39,7 @@ data WebApp = WebApp
 	, getStatic :: Static
 	, postFirstRun :: Maybe (IO String)
 	, noAnnex :: Bool
+	, listenHost ::Maybe HostName
 	}
 
 instance Yesod WebApp where

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

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"]
 
-seek :: [CommandSeek]
+listenOption :: Option
-seek = [withNothing start]
+listenOption = Option.field [] "listen" paramAddress
+	"accept connections to this address"
 
-start :: CommandStart
+seek :: [CommandSeek]
+seek = [withField listenOption return $ \listenhost ->
+	withNothing $ start listenhost]
+
+start :: Maybe HostName -> CommandStart
 start = start' True
 
-start' :: Bool -> CommandStart
+start' :: Bool -> Maybe HostName -> CommandStart
-start' allowauto = do
+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
+			( if isJust listenhost
-			, startDaemon True True $ Just $ 
+				then error "The assistant is already running, so --listen cannot be used."
-				\origout origerr _url htmlshim ->
+				else liftIO $ openBrowser browser f Nothing Nothing
-					openBrowser browser htmlshim origout origerr
+			, 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 :: Maybe HostName -> IO ()
-firstRun = do
+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
+	mainthread v url htmlshim
-		browser <- maybe Nothing webBrowser <$> Git.Config.global
+		| isJust listenhost = do
-		openBrowser browser htmlshim Nothing Nothing
+			putStrLn url
-
+			go
-		_wait <- takeMVar v
+		| otherwise = do
-
+			browser <- maybe Nothing webBrowser <$> Git.Config.global
-		state <- Annex.new =<< Git.CurrentRepo.get
+			openBrowser browser htmlshim Nothing Nothing
-		Annex.eval state $
+			go
-			startDaemon True True $ Just $ sendurlback v
+	  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 ()

Usage.hs

@@ -95,6 +95,8 @@ paramGroup :: String
 paramGroup = "GROUP"
 paramSize :: String
 paramSize = "SIZE"
+paramAddress :: String
+paramAddress = "ADDRESS"
 paramKeyValue :: String
 paramKeyValue = "K=V"
 paramNothing :: String

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 :: Maybe HostName -> Wai.Application -> (SockAddr -> IO ()) -> IO ()
-runWebApp app observer = do
+runWebApp h app observer = do
-	sock <- localSocket
+	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 
+getSocket :: Maybe HostName -> IO Socket
- - localhost are accepted. -}
+getSocket h = do
-localSocket :: IO Socket
+	addrs <- getAddrInfo (Just hints) hostname Nothing
-localSocket = do
-	addrs <- getAddrInfo (Just hints) (Just localhost) 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

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
 

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]

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>