From 6eab061c26ba8652063eaab6a04d710a8cf6be90 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 29 Aug 2016 18:46:48 -0400
Subject: support .onion addresses for servers

---
 Storage/Network.hs | 51 ++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 46 insertions(+), 5 deletions(-)

(limited to 'Storage')

diff --git a/Storage/Network.hs b/Storage/Network.hs
index 96aa1c0..c124761 100644
--- a/Storage/Network.hs
+++ b/Storage/Network.hs
@@ -5,19 +5,33 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 
-module Storage.Network (Server(..), networkServers, networkStorage) where
+module Storage.Network (
+	Server(..),
+	networkServers,
+	networkStorage,
+	torableManager
+) where
 
 import Types
 import Types.Storage
+import Data.List
+import Data.Char
 import HTTP
 import HTTP.Client
 import Servant.Client
 import Network.Wai.Handler.Warp (Port)
-import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
+import Network.HTTP.Client hiding (port, host)
+import Network.HTTP.Client.Internal (Connection, makeConnection)
 import Control.Monad.Trans.Except (ExceptT, runExceptT)
+import qualified Network.Socket
+import Network.Socket.ByteString (sendAll, recv)
+import Network.Socks5
+import qualified Data.ByteString.UTF8 as BU8
+
+type HostName = String
 
 data Server = Server
-	{ serverName :: String
+	{ serverName :: HostName
 	, serverPort :: Port
 	}
 
@@ -68,8 +82,7 @@ serverRequest
 	-> (r -> a)
 	-> (Maybe ProofOfWork -> Manager -> BaseUrl -> ExceptT ServantError IO (ProofOfWorkRequirement r))
 	-> IO a
-serverRequest srv onerr onsuccess a =
-	go Nothing =<< newManager defaultManagerSettings
+serverRequest srv onerr onsuccess a = go Nothing =<< newManager torableManager
   where
 	url = serverUrl srv
 	go pow manager = do
@@ -79,3 +92,31 @@ serverRequest srv onerr onsuccess a =
 				"server failure: " ++ show err
 			Right (Result r) -> return $ onsuccess r
 			Right needpow -> error "NEEDPOW" -- loop with pow
+
+-- | HTTP Manager supporting tor .onion and regular hosts
+torableManager :: ManagerSettings
+torableManager = defaultManagerSettings
+	{ managerRawConnection = return conn
+	}
+  where
+	conn addr host port
+		| ".onion" `isSuffixOf` map toLower host = torConnection host port
+		| otherwise = do
+			regular <- managerRawConnection defaultManagerSettings
+			regular addr host port
+
+torConnection :: HostName -> Port -> IO Connection
+torConnection onionaddress p = do
+	(socket, _) <- socksConnect torsockconf socksaddr
+	socketConnection socket 8192
+  where
+	torsocksport = 9050
+	torsockconf = defaultSocksConf "127.0.0.1" torsocksport
+	socksdomain = SocksAddrDomainName (BU8.fromString onionaddress)
+	socksaddr = SocksAddress socksdomain (fromIntegral p)
+
+socketConnection :: Network.Socket.Socket -> Int -> IO Connection
+socketConnection socket chunksize = makeConnection
+	(recv socket chunksize)
+	(sendAll socket)
+	(Network.Socket.close socket)
-- 
cgit v1.2.3