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 ()