blob: aab3dab08690b766f13121423f4fe9c564c5a964 (
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
108
109
110
111
112
|
{-# LANGUAGE OverloadedStrings #-}
{- Copyright 2016 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module HTTP.Server (runServer) where
import HTTP
import HTTP.ProofOfWork
import HTTP.RateLimit
import Types
import Types.Storage
import Tunables
import CmdLine (ServerConfig(..))
import Storage.Local
import Serialization ()
import Servant
import Network.Wai
import Network.Wai.Handler.Warp
import Control.Monad.IO.Class
import Control.Concurrent
import Control.Concurrent.Thread.Delay
import Control.Concurrent.STM
import Data.String
import qualified Data.ByteString as B
data ServerState = ServerState
{ obscurerRequest :: TMVar ()
, storageDirectory :: Maybe LocalStorageDirectory
, rateLimiter :: RateLimiter
}
newServerState :: Maybe LocalStorageDirectory -> ServerConfig -> IO ServerState
newServerState d cfg = ServerState
<$> newEmptyTMVarIO
<*> pure d
<*> newRateLimiter cfg d
runServer :: Maybe LocalStorageDirectory -> ServerConfig -> IO ()
runServer d cfg = do
st <- newServerState d cfg
_ <- forkIO $ obscurerThread st
runSettings settings (app st)
where
settings = setHost host $ setPort (serverPort cfg) $ defaultSettings
host = fromString (serverAddress cfg)
serverStorage :: ServerState -> Storage
serverStorage st = localStorage (storageDir $ storageDirectory st) "server"
app :: ServerState -> Application
app st = serve userAPI (server st)
userAPI :: Proxy HttpAPI
userAPI = Proxy
server :: ServerState -> Server HttpAPI
server st = motd
:<|> getObject st
:<|> putObject st
:<|> countObjects st
motd :: Handler Motd
motd = return $ Motd "Hello World!"
getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (POWGuarded StorableObject)
getObject st i pow = rateLimit (rateLimiter st) pow i $ do
r <- liftIO $ retrieveShare (serverStorage st) dummyShareNum i
liftIO $ requestObscure st
case r of
RetrieveSuccess (Share _n o) -> return o
RetrieveFailure _ -> throwError err404
putObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Handler (POWGuarded StoreResult)
putObject st i pow o = rateLimit (rateLimiter st) pow i $ do
if validObjectsize o
then do
r <- liftIO $ storeShare (serverStorage st) i (Share dummyShareNum o)
liftIO $ requestObscure st
return r
else return $ StoreFailure "invalid object size"
validObjectsize :: StorableObject -> Bool
validObjectsize o = any (sz ==) knownObjectSizes
where
sz = B.length (fromStorableObject o)
countObjects :: ServerState -> Maybe ProofOfWork -> Handler (POWGuarded CountResult)
countObjects st pow = rateLimit (rateLimiter st) pow NoPOWIdent $
liftIO $ countShares $ serverStorage st
-- | 1 is a dummy value; the server does not know the actual share numbers.
dummyShareNum :: ShareNum
dummyShareNum = 1
-- | This thread handles obscuring the shares after put and get operations.
-- Since obscuring can be an expensive process when there are many shares,
-- the thread runs a maximum of once per half-hour.
obscurerThread :: ServerState -> IO ()
obscurerThread st = do
_ <- obscureShares (serverStorage st)
putStrLn "obscured shares"
delay (1000000*60*30)
_ <- atomically $ takeTMVar (obscurerRequest st)
obscurerThread st
requestObscure :: ServerState -> IO ()
requestObscure st = do
_ <- atomically $ tryPutTMVar (obscurerRequest st) ()
return ()
|