diff options
Diffstat (limited to 'HTTP/Server.hs')
-rw-r--r-- | HTTP/Server.hs | 125 |
1 files changed, 125 insertions, 0 deletions
diff --git a/HTTP/Server.hs b/HTTP/Server.hs new file mode 100644 index 0000000..6fd570d --- /dev/null +++ b/HTTP/Server.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module HTTP.Server (runServer, serverStorage) where + +import HTTP +import HTTP.ProofOfWork +import HTTP.RateLimit +import HTTP.Logger +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.Maybe +import Data.String +import qualified Data.ByteString as B + +data ServerState = ServerState + { obscurerRequest :: TMVar () + , storage :: Storage + , rateLimiter :: RateLimiter + , logger :: Logger + , serverConfig :: ServerConfig + } + +newServerState :: Maybe LocalStorageDirectory -> ServerConfig -> IO ServerState +newServerState d cfg = do + l <- newLogger + ServerState + <$> newEmptyTMVarIO + <*> pure (serverStorage d) + <*> newRateLimiter cfg d l + <*> pure l + <*> pure cfg + +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 :: Maybe LocalStorageDirectory -> Storage +serverStorage d = localStorage LocallyPreferred (storageDir d) "server" + +app :: ServerState -> Application +app st = serve userAPI (server st) + +userAPI :: Proxy HttpAPI +userAPI = Proxy + +server :: ServerState -> Server HttpAPI +server st = motd st + :<|> getObject st + :<|> putObject st + :<|> countObjects st + +motd :: ServerState -> Handler Motd +motd = return . Motd . fromMaybe "Hello World!" . serverMotd . serverConfig + +getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (POWGuarded StorableObject) +getObject st i pow = rateLimit (rateLimiter st) (logger st) pow i $ do + r <- liftIO $ retrieveShare (storage 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) (logger st) pow i $ do + if validObjectsize o + then do + r <- liftIO $ storeShare (storage 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) (logger st) pow NoPOWIdent $ do + v <- liftIO $ countShares $ storage st + case v of + CountResult n -> return $ + -- Round down to avoid leaking too much detail. + CountResult ((n `div` 1000) * 1000) + CountFailure s -> return (CountFailure s) + +-- | 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 (storage st) + logStdout (logger st) "obscured shares" + delay (1000000*60*30) + _ <- atomically $ takeTMVar (obscurerRequest st) + obscurerThread st + +requestObscure :: ServerState -> IO () +requestObscure st = do + _ <- atomically $ tryPutTMVar (obscurerRequest st) () + return () |