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:
parent
9cf9ee73f5
commit
070fb9e624
17 changed files with 254 additions and 61 deletions
|
@ -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
|
||||
|
|
|
@ -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
34
Remote/Helper/Tor.hs
Normal 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
|
Loading…
Add table
Add a link
Reference in a new issue