blob: cce91cd168f944d057005e5583305edd75306925 (
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
|
{-# 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 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
r <- liftIO $ storeShare serverStorage i (Share dummyShareNum o)
liftIO $ requestObscure st
return (Result r)
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 ()
|
