{-# 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 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 System.IO
import Control.Exception
import Data.Time.Clock.POSIX

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

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
	print ("new connection" :: String)
	conn <- WS.acceptRequest pending_conn
	sendWireVersions conn
	print ("new connection open" :: String)
	-- wv <- negotiateWireVersion conn
	-- print ("version negotiated" :: String, wv)
	theirmode <- getMode conn
	print ("Connected" :: String, theirmode)
	case theirmode of
		InitMode _ -> user o ssv conn
		ConnectMode t -> case mkSessionID 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) ->
	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 ()
	
	-- Read from logchan and store each value 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
	
	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
	
	relayfromuser bchan = relayFromSocket conn $ \msg -> do
		l <- mkLog (User msg) <$> getPOSIXTime
		atomically $ writeTMChan bchan l

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 logchan) = relayToSocket conn $ do
		v <- atomically $ readTMChan logchan
		return $ case v of
			Just l -> case loggedMessage l of
				User m -> Just m
				Developer _ -> Nothing
			Nothing -> Nothing