{-# LANGUAGE OverloadedStrings #-}

module Server where

import CmdLine
import WebSockets
import SessionID
import Log

import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.WebSockets
import Network.WebSockets hiding (Message)
import qualified Network.WebSockets as WS
import Network.HTTP.Types
import Control.Concurrent.STM
import Control.Concurrent.STM.TMChan
import Control.Concurrent.Async
import qualified Data.Map as M
import qualified Data.Text as T
import Control.Exception
import Data.Time.Clock.POSIX

server :: ServerOpts -> IO ()
server o = run (serverPort o) . app o =<< newServerState

-- | A server is a map of sessions, each of which consists of a broadcast
-- TMChan, which both users and developers write messages to.
type ServerState = M.Map SessionID (TMChan Log)

newServerState :: IO (TVar ServerState)
newServerState = newTVarIO M.empty

app :: ServerOpts -> TVar ServerState -> Application
app o ssv = websocketsOr WS.defaultConnectionOptions (websocketApp o ssv) webapp
  where
	webapp _ respond = respond $
		responseLBS status400 [] "Not a WebSocket request"

websocketApp :: ServerOpts -> TVar ServerState -> WS.ServerApp
websocketApp o ssv pending_conn = do
	conn <- WS.acceptRequest pending_conn
	_v <- negotiateWireVersion conn
	theirmode <- getMode conn
	case theirmode of
		InitMode _ -> user o ssv conn
		ConnectMode t -> case mkSessionID (T.unpack t) of
			Nothing -> error "Invalid session id!"
			Just sid -> developer o ssv sid conn

user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO ()
user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) -> do
	sendTextData conn sid
	bracket (setup sid) (cleanup sid) (go logh)
  where
	setup sid = do
		bchan <- newBroadcastTMChanIO
		atomically $ modifyTVar' ssv $ M.insert sid bchan
		return bchan

	cleanup sid bchan = atomically $ do
		closeTMChan bchan
		modifyTVar' ssv $ M.delete sid

	go logh bchan = do
		logchan <- atomically $ dupTMChan bchan
		userchan <- atomically $ dupTMChan bchan
		_ <- storelog logh logchan
			`concurrently` relaytouser userchan
			`concurrently` relayfromuser bchan
		return ()
	
	-- Relay all messages from the user's websocket to the
	-- broadcast channel.
	relayfromuser bchan = relayFromSocket conn $ \msg -> do
		print ("got from user", msg)
		l <- mkLog (User msg) <$> getPOSIXTime
		atomically $ writeTMChan bchan l
	
	-- Read from logchan and store each message to the log file.
	storelog logh logchan = do
		v <- atomically $ readTMChan logchan
		case v of
			Nothing -> return ()
			Just l -> do
				writeLogHandle l logh
				storelog logh logchan
	
	-- Relay developer messages from the channel to the user's websocket.
	relaytouser userchan = relayToSocket conn $ do
		v <- atomically $ readTMChan userchan
		return $ case v of
			Just l -> case loggedMessage l of
				Developer m -> Just m
				User _ -> Nothing
			Nothing -> Nothing

developer ::  ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO ()
developer o ssv sid conn = bracket setup cleanup go
  where
	setup = atomically $ M.lookup sid <$> readTVar ssv
	cleanup _ = return ()
	go Nothing = error "Invalid session id!"
	go (Just bchan) = do
		sendTextData conn sid
		-- TODO replay backlog
		devchan <- atomically $ dupTMChan bchan
		_ <- relayfromdeveloper bchan
			`concurrently` relaytodeveloper devchan
		return ()
	
	-- Relay all messages from the developer's websocket to the
	-- broadcast channel.
	relayfromdeveloper bchan = relayFromSocket conn $ \msg -> do
		print ("got from developer", msg)
		l <- mkLog (Developer msg) <$> getPOSIXTime
		atomically $ writeTMChan bchan l
	
	-- Relay user messages from the channel to the developer's websocket.
	relaytodeveloper devchan = relayToSocket conn $ do
		v <- atomically $ readTMChan devchan
		return $ case v of
			Just l -> case loggedMessage l of
				User m -> Just m
				Developer _ -> Nothing
			Nothing -> Nothing