3a05d53761
No behavior changes (hopefully), just adding SeekInput and plumbing it through to the JSON display code for later use. Over the course of 2 grueling days. withFilesNotInGit reimplemented in terms of seekHelper should be the only possible behavior change. It seems to test as behaving the same. Note that seekHelper dummies up the SeekInput in the case where segmentPaths' gives up on sorting the expanded paths because there are too many input paths. When SeekInput later gets exposed as a json field, that will result in it being a little bit wrong in the case where 100 or more paths are passed to a git-annex command. I think this is a subtle enough problem to not matter. If it does turn out to be a problem, fixing it would require splitting up the input parameters into groups of < 100, which would make git ls-files run perhaps more than is necessary. May want to revisit this, because that fix seems fairly low-impact.
140 lines
4 KiB
Haskell
140 lines
4 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2016 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Command.EnableTor where
|
|
|
|
import Command
|
|
import qualified Annex
|
|
import P2P.Address
|
|
import P2P.Annex
|
|
import Utility.Tor
|
|
import Annex.UUID
|
|
#ifndef mingw32_HOST_OS
|
|
import Annex.Path
|
|
#endif
|
|
import P2P.IO
|
|
import qualified P2P.Protocol as P2P
|
|
import Utility.ThreadScheduler
|
|
import RemoteDaemon.Transport.Tor
|
|
|
|
import Control.Concurrent.Async
|
|
import qualified Network.Socket as S
|
|
#ifndef mingw32_HOST_OS
|
|
import Utility.Su
|
|
import System.Posix.User
|
|
#endif
|
|
|
|
cmd :: Command
|
|
cmd = noCommit $ dontCheck repoExists $
|
|
command "enable-tor" SectionSetup "enable tor hidden service"
|
|
"uid" (withParams seek)
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek = withWords (commandAction . start)
|
|
|
|
-- This runs as root, so avoid making any commits or initializing
|
|
-- git-annex, or doing other things that create root-owned files.
|
|
start :: [String] -> CommandStart
|
|
#ifndef mingw32_HOST_OS
|
|
start os = do
|
|
#else
|
|
start _os = do
|
|
#endif
|
|
#ifndef mingw32_HOST_OS
|
|
let ai = ActionItemOther Nothing
|
|
let si = SeekInput []
|
|
curruserid <- liftIO getEffectiveUserID
|
|
if curruserid == 0
|
|
then case readish =<< headMaybe os of
|
|
Nothing -> giveup "Need user-id parameter."
|
|
Just userid -> go userid
|
|
else starting "enable-tor" ai si $ do
|
|
gitannex <- liftIO programPath
|
|
let ps = [Param (cmdname cmd), Param (show curruserid)]
|
|
sucommand <- liftIO $ mkSuCommand gitannex ps
|
|
maybe noop showLongNote
|
|
(describePasswordPrompt' sucommand)
|
|
ifM (liftIO $ runSuCommand sucommand)
|
|
( next checkHiddenService
|
|
, giveup $ unwords $
|
|
[ "Failed to run as root:" , gitannex ] ++ toCommand ps
|
|
)
|
|
#else
|
|
go 0
|
|
#endif
|
|
where
|
|
go userid = do
|
|
uuid <- getUUID
|
|
when (uuid == NoUUID) $
|
|
giveup "This can only be run in a git-annex repository."
|
|
(onionaddr, onionport) <- liftIO $
|
|
addHiddenService torAppName userid (fromUUID uuid)
|
|
storeP2PAddress $ TorAnnex onionaddr onionport
|
|
stop
|
|
|
|
checkHiddenService :: CommandCleanup
|
|
checkHiddenService = bracket setup cleanup go
|
|
where
|
|
setup = do
|
|
showLongNote "Tor hidden service is configured. Checking connection to it. This may take a few minutes."
|
|
startlistener
|
|
|
|
cleanup = liftIO . cancel
|
|
|
|
go _ = check (150 :: Int) =<< filter istoraddr <$> loadP2PAddresses
|
|
|
|
istoraddr (TorAnnex _ _) = True
|
|
|
|
check 0 _ = giveup "Still unable to connect to hidden service. It might not yet be usable by others. Please check Tor's logs for details."
|
|
check _ [] = giveup "Somehow didn't get an onion address."
|
|
check n addrs@(addr:_) = do
|
|
g <- Annex.gitRepo
|
|
-- Connect but don't bother trying to auth,
|
|
-- we just want to know if the tor circuit works.
|
|
liftIO (tryNonAsync $ connectPeer g addr) >>= \case
|
|
Left e -> do
|
|
warning $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.."
|
|
liftIO $ threadDelaySeconds (Seconds 2)
|
|
check (n-1) addrs
|
|
Right conn -> do
|
|
liftIO $ closeConnection conn
|
|
showLongNote "Tor hidden service is working."
|
|
return True
|
|
|
|
-- Unless the remotedaemon is already listening on the hidden
|
|
-- service's socket, start a listener. This is only run during the
|
|
-- check, and it refuses all auth attempts.
|
|
startlistener = do
|
|
r <- Annex.gitRepo
|
|
u <- getUUID
|
|
msock <- torSocketFile
|
|
case msock of
|
|
Just sockfile -> ifM (liftIO $ haslistener sockfile)
|
|
( liftIO $ async $ return ()
|
|
, liftIO $ async $ runlistener sockfile u r
|
|
)
|
|
Nothing -> giveup "Could not find socket file in Tor configuration!"
|
|
|
|
runlistener sockfile u r = serveUnixSocket sockfile $ \h -> do
|
|
let conn = P2PConnection
|
|
{ connRepo = r
|
|
, connCheckAuth = const False
|
|
, connIhdl = h
|
|
, connOhdl = h
|
|
, connIdent = ConnIdent Nothing
|
|
}
|
|
runst <- mkRunState Client
|
|
void $ runNetProto runst conn $ P2P.serveAuth u
|
|
hClose h
|
|
|
|
haslistener sockfile = catchBoolIO $ do
|
|
soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
|
|
S.connect soc (S.SockAddrUnix sockfile)
|
|
S.close soc
|
|
return True
|