blob: 9626eabeeab36a36136a2e79ef3748cb38ed6b13 (
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
103
104
105
106
107
|
{- 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 Types
import Types.Server
import Types.Storage
import Types.Cost
import Servant.API
import Servant.Client
import Data.Proxy
import Network.HTTP.Client hiding (port, host, Proxy)
import Network.HTTP.Client.Internal (Connection)
import Control.Exception
import Network.Socks5
import qualified Data.ByteString.UTF8 as BU8
import Data.List
import Data.Char
httpAPI :: Proxy HttpAPI
httpAPI = Proxy
motd :: ClientM Motd
getObject :: StorableObjectIdent -> Maybe ProofOfWork -> ClientM (POWGuarded StorableObject)
putObject :: StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> ClientM (POWGuarded StoreResult)
countObjects :: Maybe ProofOfWork -> ClientM (POWGuarded CountResult)
motd :<|> getObject :<|> putObject :<|> countObjects = client httpAPI
tryA :: IO a -> IO (Either SomeException a)
tryA = try
serverRequest
:: POWIdent p
=> Server
-> (String -> a)
-> (r -> a)
-> p
-> (Maybe ProofOfWork -> ClientM (POWGuarded r))
-> IO a
serverRequest srv onerr onsuccess p a = do
r <- tryA $ go Nothing maxProofOfWork
case r of
Left e -> return $ onerr (show e)
Right v -> return v
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)
-- 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).
serverRequest'
:: Server
-> (ClientM r)
-> IO (Either String r)
serverRequest' srv a = go Nothing (serverUrls srv)
where
go lasterr [] = return $ Left $
maybe "no known address" (\err -> "server failure: " ++ show err) lasterr
go _ (url:urls) = do
manager <- torableManager
res <- runClientM a (ClientEnv manager url)
case res of
Left err -> go (Just err) urls
Right r -> return (Right r)
-- | 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 :: String -> 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)
serverUrls :: Server -> [BaseUrl]
serverUrls srv = map go (serverAddress srv)
where
go (ServerAddress addr port) = BaseUrl Http addr port ""
|
