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