Added git-remote-tor-annex, which allows git pull and push to the tor hidden service.

Almost working, but there's a bug in the relaying.

Also, made tor hidden service setup pick a random port, to make it harder
to port scan.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
This commit is contained in:
Joey Hess 2016-11-21 17:27:38 -04:00
parent 9cf9ee73f5
commit 070fb9e624
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
17 changed files with 254 additions and 61 deletions

View file

@ -26,6 +26,12 @@ import qualified Data.ByteString.Lazy as L
newtype AuthToken = AuthToken String
deriving (Show)
mkAuthToken :: String -> Maybe AuthToken
mkAuthToken = fmap AuthToken . headMaybe . lines
nullAuthToken :: AuthToken
nullAuthToken = AuthToken ""
newtype Offset = Offset Integer
deriving (Show)
@ -157,6 +163,7 @@ type Net = Free NetF
data RelayData
= RelayData L.ByteString
| RelayMessage Message
deriving (Show)
newtype RelayHandle = RelayHandle Handle
@ -400,8 +407,8 @@ relayCallback hout (RelayMessage (DATA len)) = do
return Nothing
relayCallback _ (RelayMessage (CONNECTDONE exitcode)) =
return (Just exitcode)
relayCallback _ (RelayMessage _) = do
sendMessage (ERROR "expected DATA or CONNECTDONE")
relayCallback _ (RelayMessage m) = do
sendMessage $ ERROR $ "expected DATA or CONNECTDONE not " ++ unwords (Proto.formatMessage m)
return (Just (ExitFailure 1))
relayCallback _ (RelayData b) = do
let len = Len $ fromIntegral $ L.length b

View file

@ -19,6 +19,7 @@ import Git
import Git.Command
import Utility.SafeCommand
import Utility.SimpleProtocol
import Utility.Exception
import Control.Monad
import Control.Monad.Free
@ -30,7 +31,7 @@ import Control.Concurrent
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
type RunProto = forall a m. MonadIO m => Proto a -> m a
type RunProto = forall a m. (MonadIO m, MonadMask m) => Proto a -> m a
data S = S
{ repo :: Repo
@ -40,7 +41,7 @@ data S = S
-- Implementation of the protocol, communicating with a peer
-- over a Handle. No Local actions will be run.
runNetProtoHandle :: MonadIO m => Handle -> Handle -> Repo -> Proto a -> m a
runNetProtoHandle :: (MonadIO m, MonadMask m) => Handle -> Handle -> Repo -> Proto a -> m a
runNetProtoHandle i o r = go
where
go :: RunProto
@ -48,7 +49,7 @@ runNetProtoHandle i o r = go
go (Free (Net n)) = runNetHandle (S r i o) go n
go (Free (Local _)) = error "local actions not allowed"
runNetHandle :: MonadIO m => S -> RunProto -> NetF (Proto a) -> m a
runNetHandle :: (MonadIO m, MonadMask m) => S -> RunProto -> NetF (Proto a) -> m a
runNetHandle s runner f = case f of
SendMessage m next -> do
liftIO $ do
@ -57,10 +58,11 @@ runNetHandle s runner f = case f of
runner next
ReceiveMessage next -> do
l <- liftIO $ hGetLine (ihdl s)
-- liftIO $ hPutStrLn stderr ("< " ++ show l)
case parseMessage l of
Just m -> runner (next m)
Nothing -> runner $ do
let e = ERROR "protocol parse error"
let e = ERROR $ "protocol parse error: " ++ show l
net $ sendMessage e
next e
SendBytes _len b next -> do
@ -70,6 +72,7 @@ runNetHandle s runner f = case f of
runner next
ReceiveBytes (Len n) next -> do
b <- liftIO $ L.hGet (ihdl s) (fromIntegral n)
--liftIO $ hPutStrLn stderr $ "!!!" ++ show (L.length b)
runner (next b)
CheckAuthToken u t next -> do
authed <- return True -- TODO XXX FIXME really check
@ -80,7 +83,8 @@ runNetHandle s runner f = case f of
runRelayService s runner service callback >>= runner . next
WriteRelay (RelayHandle h) b next -> do
liftIO $ do
L.hPut h b
-- L.hPut h b
hPutStrLn h (show ("relay got:", b, L.length b))
hFlush h
runner next
@ -112,43 +116,57 @@ runRelay runner (RelayHandle hout) callback = do
drain v = do
d <- takeMVar v
liftIO $ hPutStrLn stderr (show d)
r <- runner $ net $ callback d
case r of
Nothing -> drain v
Just exitcode -> return exitcode
runRelayService
:: MonadIO m
:: (MonadIO m, MonadMask m)
=> S
-> RunProto
-> Service
-> (RelayHandle -> RelayData -> Net (Maybe ExitCode))
-> m ExitCode
runRelayService s runner service callback = do
v <- liftIO newEmptyMVar
(Just hin, Just hout, _, pid) <- liftIO $ createProcess serviceproc
{ std_out = CreatePipe
, std_in = CreatePipe
}
_ <- liftIO $ forkIO $ readout v hout
feeder <- liftIO $ forkIO $ feedin v
_ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid
exitcode <- liftIO $ drain v hin
liftIO $ killThread feeder
return exitcode
runRelayService s runner service callback = bracket setup cleanup go
where
cmd = case service of
UploadPack -> "upload-pack"
ReceivePack -> "receive-pack"
serviceproc = gitCreateProcess [Param cmd, File (repoPath (repo s))] (repo s)
serviceproc = gitCreateProcess
[ Param cmd
, File (repoPath (repo s))
] (repo s)
setup = do
v <- liftIO newEmptyMVar
(Just hin, Just hout, _, pid) <- liftIO $
createProcess serviceproc
{ std_out = CreatePipe
, std_in = CreatePipe
}
feeder <- liftIO $ forkIO $ feedin v
return (v, feeder, hin, hout, pid)
cleanup (_, feeder, hin, hout, pid) = liftIO $ do
hClose hin
hClose hout
liftIO $ killThread feeder
void $ waitForProcess pid
go (v, _, hin, hout, pid) = do
_ <- liftIO $ forkIO $ readout v hout
_ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid
liftIO $ drain v hin
drain v hin = do
d <- takeMVar v
case d of
Left exitcode -> do
hClose hin
return exitcode
Left exitcode -> return exitcode
Right relaydata -> do
liftIO $ hPutStrLn stderr ("> " ++ show relaydata)
_ <- runner $ net $
callback (RelayHandle hin) relaydata
drain v hin
@ -156,7 +174,7 @@ runRelayService s runner service callback = do
readout v hout = do
b <- B.hGetSome hout 65536
if B.null b
then hClose hout
then return ()
else do
putMVar v $ Right $
RelayData (L.fromChunks [b])

34
Remote/Helper/Tor.hs Normal file
View file

@ -0,0 +1,34 @@
{- Helpers for tor remotes.
-
- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Helper.Tor where
import Annex.Common
import Remote.Helper.P2P (mkAuthToken, AuthToken)
import Creds
import Utility.Tor
import Utility.Env
import Network.Socket
getTorAuthToken :: OnionAddress -> Annex (Maybe AuthToken)
getTorAuthToken (OnionAddress onionaddress) =
maybe Nothing mkAuthToken <$> getM id
[ liftIO $ getEnv torAuthTokenEnv
, readCacheCreds onionaddress
]
torAuthTokenEnv :: String
torAuthTokenEnv = "GIT_ANNEX_TOR_AUTHTOKEN"
torHandle :: Socket -> IO Handle
torHandle s = do
h <- socketToHandle s ReadWriteMode
hSetBuffering h LineBuffering
hSetBinaryMode h False
fileEncoding h
return h