summaryrefslogtreecommitdiffhomepage
path: root/HTTP/Client.hs
blob: 19cfe9b2eb8fd086fc2228e0562ff94e5cb0d15b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
{- Copyright 2016 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module HTTP.Client where

import HTTP
import HTTP.ProofOfWork
import Servers
import Types
import Types.Storage
import Types.Cost
import Servant.API
import Servant.Client
import Data.Proxy
import Network.Wai.Handler.Warp (Port)
import Network.HTTP.Client hiding (port, host, Proxy)
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
import Data.List
import Data.Char

httpAPI :: Proxy HttpAPI
httpAPI = Proxy

motd :: Manager -> BaseUrl -> ClientM Motd
getObject :: StorableObjectIdent -> Maybe ProofOfWork -> Manager -> BaseUrl -> ClientM (POWGuarded StorableObject)
putObject :: StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Manager -> BaseUrl -> ClientM (POWGuarded StoreResult)
countObjects :: Maybe ProofOfWork -> Manager -> BaseUrl -> ClientM (POWGuarded CountResult)
motd :<|> getObject :<|> putObject :<|> countObjects = client httpAPI

serverRequest
	:: POWIdent p
	=> Server
	-> (String -> a)
	-> (r -> a)
	-> p
	-> (Maybe ProofOfWork -> Manager -> BaseUrl -> ExceptT ServantError IO (POWGuarded r))
	-> IO a
serverRequest srv onerr onsuccess p a = go Nothing maxProofOfWork
  where
	go pow (Seconds timeleft)
		| timeleft <= 0 = return $ onerr "server asked for too much proof of work; gave up"
		| otherwise = do
			res <- serverRequest' srv (a pow)
			case res of
				Left err -> return $ onerr err
				Right (Result r) -> return $ onsuccess r
				Right (NeedProofOfWork req) -> go
					(Just $ genProofOfWork req p)
					(Seconds timeleft - generationTime req)

serverRequest'
	:: Server
	-> (Manager -> BaseUrl -> ExceptT ServantError IO r)
	-> IO (Either String r)
serverRequest' srv a = do
	-- A new Manager is allocated for each request, rather than reusing
	-- any connection. This is a feature; it makes correlation attacks
	-- harder because the server can't tell if two connections
	-- accessing different objects came from the same user, except by
	-- comparing IP addresses (which are masked somewhat by using tor).
	manager <- torableManager
	res <- runExceptT $ a manager url
	return $ case res of
		Left err -> Left $ "server failure: " ++ show err
		Right r -> Right r
  where
	url = serverUrl srv

-- | HTTP Manager supporting tor .onion and regular hosts
torableManager :: IO Manager
torableManager = newManager $ 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)