webapp: Added --port option, and annex.port config

The getSocket comment that mentioned using ":port"
in the hostname seems to have been incorrect or be out of date.
After all, the bug report came when the user first tried doing that,
and it didn't work.

Sponsored-by: the NIH-funded NICEMAN (ReproNim TR&D3) project

Assistant.hs

@@ -59,7 +59,7 @@ import System.Environment (getArgs)
 #endif
 import qualified Utility.Debug as Debug
 
-import Network.Socket (HostName)
+import Network.Socket (HostName, PortNumber)
 
 stopDaemon :: Annex ()
 stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath
@@ -70,8 +70,8 @@ stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath
  -
  - startbrowser is passed the url and html shim file, as well as the original
  - stdout and stderr descriptors. -}
-startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
-startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do
+startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()
+startDaemon assistant foreground startdelay cannotrun listenhost listenport startbrowser = do
 	Annex.changeState $ \s -> s { Annex.daemon = True }
 	enableInteractiveBranchAccess
 	pidfile <- fromRepo gitAnnexPidFile
@@ -141,7 +141,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 #endif
 		urlrenderer <- liftIO newUrlRenderer
 #ifdef WITH_WEBAPP
-		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost webappwaiter ]
+		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost listenport webappwaiter ]
 #else
 		let webappthread = []
 #endif

Assistant/Threads/WebApp.hs

@@ -45,7 +45,7 @@ import Git
 import qualified Annex
 
 import Yesod
-import Network.Socket (SockAddr, HostName)
+import Network.Socket (SockAddr, HostName, PortNumber)
 import Data.Text (pack, unpack)
 import qualified Network.Wai.Handler.WarpTLS as TLS
 import Network.Wai.Middleware.RequestLogger
@@ -61,12 +61,16 @@ webAppThread
 	-> Maybe String
 	-> Maybe (IO Url)
 	-> Maybe HostName
+	-> Maybe PortNumber
 	-> Maybe (Url -> FilePath -> IO ())
 	-> NamedThread
-webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost onstartup = thread $ liftIO $ do
+webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do
 	listenhost' <- if isJust listenhost
 		then pure listenhost
 		else getAnnex $ annexListen <$> Annex.getGitConfig
+	listenport' <- if isJust listenport
+		then pure listenport
+		else getAnnex $ annexPort <$> Annex.getGitConfig
 	tlssettings <- getAnnex getTlsSettings
 	webapp <- WebApp
 		<$> pure assistantdata
@@ -84,7 +88,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
 		( return $ logStdout app
 		, return app
 		)
-	runWebApp tlssettings listenhost' app' $ \addr -> if noannex
+	runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex
 		then withTmpFile "webapp.html" $ \tmpfile h -> do
 			hClose h
 			go tlssettings addr webapp tmpfile Nothing

CHANGELOG

@@ -22,6 +22,7 @@ git-annex (10.20231228) UNRELEASED; urgency=medium
     annex.bwlimit-download, annex.bwlimit-upload,
     and similar per-remote configs.
   * Added --expected-present file matching option.
+  * webapp: Added --port option, and annex.port config.
 
  -- Joey Hess <id@joeyh.name>  Fri, 29 Dec 2023 11:52:06 -0400
 

Command/Watch.hs

@@ -24,5 +24,12 @@ start :: Bool -> DaemonOptions -> Maybe Duration -> CommandStart
 start assistant o startdelay = do
 	if stopDaemonOption o
 		then stopDaemon
-		else startDaemon assistant (foregroundDaemonOption o) startdelay Nothing Nothing Nothing -- does not return
+		else startDaemon assistant 
+			(foregroundDaemonOption o)
+			startdelay
+			Nothing 
+			Nothing
+			Nothing
+			Nothing
+			-- does not return
 	stop

Command/WebApp.hs

@@ -36,6 +36,7 @@ import Utility.Android
 
 import Control.Concurrent
 import Control.Concurrent.STM
+import Network.Socket (PortNumber)
 
 cmd :: Command
 cmd = noCommit $ dontCheck repoExists $ notBareRepo $
@@ -45,6 +46,7 @@ cmd = noCommit $ dontCheck repoExists $ notBareRepo $
 
 data WebAppOptions = WebAppOptions
 	{ listenAddress :: Maybe String
+	, listenPort :: Maybe PortNumber
 	}
 
 optParser :: CmdParamsDesc -> Parser WebAppOptions
@@ -53,6 +55,10 @@ optParser _ = WebAppOptions
 		( long "listen" <> metavar paramAddress
 		<> help "accept connections to this address"
 		))
+	<*> optional (option auto
+		( long "port" <> metavar paramNumber
+		<> help "specify port to listen on"
+		))
 
 seek :: WebAppOptions -> CommandSeek
 seek = commandAction . start
@@ -77,9 +83,12 @@ start' allowauto o = do
 		listenAddress' <- if isJust (listenAddress o)
 			then pure (listenAddress o)
 			else annexListen <$> Annex.getGitConfig
+		listenPort' <- if isJust (listenPort o)
+			then pure (listenPort o)
+			else annexPort <$> Annex.getGitConfig
 		ifM (checkpid <&&> checkshim (fromRawFilePath f))
-			( if isJust (listenAddress o)
-				then giveup "The assistant is already running, so --listen cannot be used."
+			( if isJust (listenAddress o) || isJust (listenPort o)
+				then giveup "The assistant is already running, so --listen and --port cannot be used."
 				else do
 					url <- liftIO . readFile . fromRawFilePath
 						=<< fromRepo gitAnnexUrlFile
@@ -87,7 +96,7 @@ start' allowauto o = do
 						then putStrLn url
 						else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing
 			, do
-				startDaemon True True Nothing cannotrun listenAddress' $ Just $ 
+				startDaemon True True Nothing cannotrun listenAddress' listenPort' $ Just $ 
 					\origout origerr url htmlshim ->
 						if isJust listenAddress'
 							then maybe noop (`hPutStrLn` url) origout
@@ -168,6 +177,7 @@ firstRun o = do
 			webAppThread d urlrenderer True Nothing
 				(callback signaler)
 				(listenAddress o)
+				(listenPort o)
 				(callback mainthread)
 		waitNamedThreads
   where
@@ -189,8 +199,8 @@ firstRun o = do
 			_wait <- takeMVar v
 			state <- Annex.new =<< Git.CurrentRepo.get
 			Annex.eval state $
-				startDaemon True True Nothing Nothing (listenAddress o) $ Just $
-					sendurlback v
+				startDaemon True True Nothing Nothing (listenAddress o) (listenPort o) 
+					(Just $ sendurlback v)
 	sendurlback v _origout _origerr url _htmlshim = putMVar v url
 
 openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()

Types/GitConfig.hs

@@ -50,6 +50,7 @@ import Utility.Gpg (GpgCmd, mkGpgCmd)
 import Utility.StatelessOpenPGP (SOPCmd(..), SOPProfile(..))
 import Utility.ThreadScheduler (Seconds(..))
 import Utility.Url (Scheme, mkScheme)
+import Network.Socket (PortNumber)
 
 import Control.Concurrent.STM
 import qualified Data.Set as S
@@ -115,6 +116,7 @@ data GitConfig = GitConfig
 	, annexSecureEraseCommand :: Maybe String
 	, annexGenMetaData :: Bool
 	, annexListen :: Maybe String
+	, annexPort :: Maybe PortNumber
 	, annexStartupScan :: Bool
 	, annexHardLink :: Bool
 	, annexThin :: Bool
@@ -210,6 +212,7 @@ extractGitConfig configsource r = GitConfig
 	, annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command")
 	, annexGenMetaData = getbool (annexConfig "genmetadata") False
 	, annexListen = getmaybe (annexConfig "listen")
+	, annexPort = getmayberead (annexConfig "port")
 	, annexStartupScan = getbool (annexConfig "startupscan") True
 	, annexHardLink = getbool (annexConfig "hardlink") False
 	, annexThin = getbool (annexConfig "thin") False

Utility/WebApp.hs

@@ -58,9 +58,9 @@ browserProc url = proc "xdg-open" [url]
  - An IO action can also be run, to do something with the address,
  - such as start a web browser to view the webapp.
  -}
-runWebApp :: Maybe TLSSettings -> Maybe HostName -> Wai.Application -> (SockAddr -> IO ()) -> IO ()
-runWebApp tlssettings h app observer = withSocketsDo $ do
-	sock <- getSocket h
+runWebApp :: Maybe TLSSettings -> Maybe HostName -> Maybe PortNumber -> Wai.Application -> (SockAddr -> IO ()) -> IO ()
+runWebApp tlssettings h p app observer = withSocketsDo $ do
+	sock <- getSocket h p
 	void $ forkIO $ go webAppSettings sock app	
 	sockaddr <- getSocketName sock
 	observer sockaddr
@@ -74,14 +74,13 @@ webAppSettings = setTimeout halfhour defaultSettings
 	halfhour = 30 * 60
 
 {- Binds to a local socket, or if specified, to a socket on the specified
- - hostname or address. Selects any free port, unless the hostname ends with
- - ":port"
+ - hostname or address. Selects any free port, unless a port is specified.
  -
  - Prefers to bind to the ipv4 address rather than the ipv6 address
  - of localhost, if it's available.
  -}
-getSocket :: Maybe HostName -> IO Socket
-getSocket h = do
+getSocket :: Maybe HostName -> Maybe PortNumber -> IO Socket
+getSocket h p = do
 #if defined (mingw32_HOST_OS)
 	-- The HostName is ignored by this code.
 	-- getAddrInfo didn't used to work on windows; current status
@@ -91,11 +90,11 @@ getSocket h = do
 	let addr = tupleToHostAddress (127,0,0,1)
 	sock <- socket AF_INET Stream defaultProtocol
 	preparesocket sock
-	bind sock (SockAddrInet defaultPort addr)
+	bind sock (SockAddrInet (fromMaybe defaultPort p) addr)
 	use sock
   where
 #else
-	addrs <- getAddrInfo (Just hints) (Just hostname) Nothing
+	addrs <- getAddrInfo (Just hints) (Just hostname) (fmap show p)
 	case (partition (\a -> addrFamily a == AF_INET) addrs) of
 		(v4addr:_, _) -> go v4addr
 		(_, v6addr:_) -> go v6addr

doc/bugs/webapp_--listen_port_is_not_used__63__.mdwn

@@ -19,3 +19,5 @@ git-annex version: 10.20230126
 
 [[!meta author=yoh]]
 [[!tag projects/repronim]]
+
+> [[done]] --[[Joey]]

doc/bugs/webapp_--listen_port_is_not_used__63__/comment_4_ba217465bfa738b77ea9417a33810d75._comment

@@ -0,0 +1,22 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2024-01-25T17:29:08Z"
+ content="""
+I found an old todo about the same thing,
+[[todo/Make_webapp_port_configurable]].
+
+The idea there was, they were using docker and wanted to open only a
+specific port selected for the webapp. So basically the same kind of thing.
+
+I think that this should be a separate --port option, to avoid needing to
+try to parse something that may be an ipv6 address or hostname, or
+whatever.
+
+I don't think that using --port should prevent the webapp from needing
+the `?auth=' part of the url, as output when using --listen.
+
+Probably it does not make sense to use --port without also using --listen,
+but if the user does use it, I don't think --port needs to output the url
+the way --listen does.
+"""]]

doc/bugs/webapp_--listen_port_is_not_used__63__/comment_5_99a6933f30649bc33ee5c74b33fc7046._comment

@@ -0,0 +1,7 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 5"""
+ date="2024-01-25T18:06:15Z"
+ content="""
+Implemented --port.
+"""]]

doc/git-annex-webapp.mdwn

@@ -21,7 +21,8 @@ it opens a browser window.
 * `--listen=address`
 
   Useful for using the webapp on a remote computer. This makes the webapp
-  listen on the specified IP address.
+  listen on the specified IP address. (Or on the address that a specified
+  hostname resolves to.)
 
   This disables running a local web browser, and outputs the url you
   can use to open the webapp.
@@ -29,6 +30,11 @@ it opens a browser window.
   Set annex.listen in the git config to make the webapp always
   listen on an IP address.
 
+* `--port=number`
+
+  Use this option to specify a port for the webapp.
+  By default, the webapp picks an unused port.
+
 * Also the [[git-annex-common-options]](1) can be used.
 
 # USING HTTPS

doc/git-annex.mdwn

@@ -2040,6 +2040,11 @@ Remotes are configured using these settings in `.git/config`.
   The default is localhost. Can be either an IP address, 
   or a hostname that resolves to the desired address.
 
+* `annex.port`
+
+  Configures which port address the webapp listens on. 
+  The default is to pick an unused port.
+
 # CONFIGURATION VIA .gitattributes
 
 The key-value backend used when adding a new file to the annex can be

doc/todo/Make_webapp_port_configurable.mdwn

@@ -39,9 +39,4 @@ dependency versions: aws-0.20 bloomfilter-2.0.1.0 cryptonite-0.25 DAV-1.3.3 feed
 ### Have you had any luck using git-annex before? (Sometimes we get tired of reading bug reports all day and a lil' positive end note does wonders)
 git annex seems awesome with the little bit of testing I've done. It seems like the perfect tool for what I want to accomplish. Thanks!
 
-> I don't think this necessarily makes sense, but there is an active bug
-> report about the same thing at
-> [[bugs/webapp_--listen_port_is_not_used__63__]]
-> 
-> So, closing this old todo to keep discussion in one place. [[done]]
-> --[[Joey]]
+> [[done]] via --port option --[[Joey]]