diff options
author | Joey Hess <joeyh@joeyh.name> | 2016-08-29 18:46:48 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2016-08-29 18:47:22 -0400 |
commit | 6eab061c26ba8652063eaab6a04d710a8cf6be90 (patch) | |
tree | f3aade6828bdf2b04e86173c7caf94f3aec1d408 /Storage | |
parent | cf872ac1cc8f52de5da5035b6bf04bd8d5b37d22 (diff) | |
download | keysafe-6eab061c26ba8652063eaab6a04d710a8cf6be90.tar.gz |
support .onion addresses for servers
Diffstat (limited to 'Storage')
-rw-r--r-- | Storage/Network.hs | 51 |
1 files changed, 46 insertions, 5 deletions
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) |