blob: f98d06277879b6ef0c2fea5a928b48ab7935fe27 (
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
|
{-# 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
import System.IO.Unsafe (unsafePerformIO)
data ServerState = ServerState
{ obscurerRequest :: TMVar ()
}
{-# NOINLINE serverState #-}
serverState :: ServerState
serverState = unsafePerformIO $ ServerState
<$> newEmptyTMVarIO
runServer :: Port -> IO ()
runServer port = do
_ <- forkIO obscurerThread
run port app
serverStorage :: Storage
serverStorage = localStorage "server"
app :: Application
app = serve userAPI server
userAPI :: Proxy HttpAPI
userAPI = Proxy
server :: Server HttpAPI
server = apiVersion
:<|> motd
:<|> getObject
:<|> putObject
:<|> countObjects
apiVersion :: Handler APIVersion
apiVersion = return (APIVersion 1)
motd :: Handler Motd
motd = return $ Motd "Hello World!"
getObject :: StorableObjectIdent -> Maybe ProofOfWork -> Handler (ProofOfWorkRequirement StorableObject)
getObject i _pow = do
r <- liftIO $ retrieveShare serverStorage dummyShareNum i
liftIO requestObscure
case r of
RetrieveSuccess (Share _n o) -> return $ Result o
RetrieveFailure _ -> throwError err404
putObject :: StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Handler (ProofOfWorkRequirement StoreResult)
putObject i _pow o = do
r <- liftIO $ storeShare serverStorage i (Share dummyShareNum o)
liftIO requestObscure
return (Result r)
countObjects :: Maybe ProofOfWork -> Handler (ProofOfWorkRequirement CountResult)
countObjects _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 :: IO ()
obscurerThread = do
_ <- obscureShares serverStorage
putStrLn "obscured shares"
threadDelay (1000000*60*30)
_ <- atomically $ takeTMVar (obscurerRequest serverState)
obscurerThread
requestObscure :: IO ()
requestObscure = do
_ <- atomically $ tryPutTMVar (obscurerRequest serverState) ()
return ()
|
