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