blob: a26cd5ed1beb809e8094f52b2677f8f6f6687fa4 (
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
|
{-# 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 Types
import Types.Storage
import Tunables
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.STM
data ServerState = ServerState
{ obscurerRequest :: TMVar ()
}
newServerState :: IO ServerState
newServerState = ServerState
<$> newEmptyTMVarIO
runServer :: Port -> IO ()
runServer port = do
st <- newServerState
_ <- forkIO $ obscurerThread st
run port (app st)
serverStorage :: Storage
serverStorage = localStorage "server"
app :: ServerState -> Application
app st = serve userAPI (server st)
userAPI :: Proxy HttpAPI
userAPI = Proxy
server :: ServerState -> Server HttpAPI
server st = apiVersion
:<|> motd
:<|> getObject st
:<|> putObject st
:<|> countObjects st
apiVersion :: Handler APIVersion
apiVersion = return (APIVersion 1)
motd :: Handler Motd
motd = return $ Motd "Hello World!"
getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (ProofOfWorkRequirement StorableObject)
getObject st i _pow = do
r <- liftIO $ retrieveShare serverStorage dummyShareNum i
liftIO $ requestObscure st
case r of
RetrieveSuccess (Share _n o) -> return $ Result o
RetrieveFailure _ -> throwError err404
putObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Handler (ProofOfWorkRequirement StoreResult)
putObject st i _pow o = do
if validObjectsize o
then do
r <- liftIO $ storeShare serverStorage i (Share dummyShareNum o)
liftIO $ requestObscure st
return (Result r)
else throwError err413 -- Request Entity Too Large
countObjects :: ServerState -> Maybe ProofOfWork -> Handler (ProofOfWorkRequirement CountResult)
countObjects _st _pow = liftIO $ Result <$> countShares serverStorage
-- | 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
putStrLn "obscured shares"
threadDelay (1000000*60*30)
_ <- atomically $ takeTMVar (obscurerRequest st)
obscurerThread st
requestObscure :: ServerState -> IO ()
requestObscure st = do
_ <- atomically $ tryPutTMVar (obscurerRequest st) ()
return ()
|
