-- |
-- Stability   :  Ultra-Violence
-- Portability :  I'm too young to die
-- Listening on sockets for the incoming requests.
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}

module Network.NineP.Server
	( module Network.NineP.Internal.File
	, Config(..)
	, run9PServer
	) where

import Control.Concurrent
import Control.Concurrent.MState hiding (get, put)
import Control.Exception (assert)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.EmbedIO
import Control.Monad.Loops
import Control.Monad.Reader
import Control.Monad.Trans
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import qualified Data.ByteString as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.NineP
import Data.Word
import Network hiding (accept)
import Network.BSD
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import System.IO
import System.Log.Logger
import Text.Regex.Posix ((=~))

import Network.NineP.Error
import Network.NineP.Internal.File
import Network.NineP.Internal.Msg
import Network.NineP.Internal.State

maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads

connection :: String -> IO Socket
connection s = let	pat = "tcp!(.*)!([0-9]*)|unix!(.*)" :: ByteString
			wrongAddr = ioError $ userError $ "wrong 9p connection address: " ++ s
			(bef, _, aft, grps) = s =~ pat :: (String, String, String, [String])
	in if (bef /= "" || aft /= "" || grps == [])
		then wrongAddr
		else case grps of
			[addr, port, ""] -> listen' addr $ toEnum $ (fromMaybe 2358 $ maybeRead port :: Int)
			["", "", addr]  -> listenOn $ UnixSocket addr
			_ -> wrongAddr

listen' :: HostName -> PortNumber -> IO Socket
listen' hostname port = do
	proto <- getProtocolNumber "tcp"
	bracketOnError (socket AF_INET Stream proto) close (\sock -> do
		setSocketOption sock ReuseAddr 1
		he <- getHostByName hostname
		bind sock (SockAddrInet port (hostAddress he))
		listen sock maxListenQueue
		return sock)

-- |Run the actual server using the supplied configuration.
run9PServer :: (EmbedIO m) => Config m -> IO ()
run9PServer cfg = do
	s <- connection $ addr cfg
	serve s cfg

serve :: (EmbedIO m) => Socket -> Config m -> IO ()
serve s cfg = forever $ accept s >>= (
		\(s, _) -> (doClient cfg) =<< (liftIO $ socketToHandle s ReadWriteMode))

doClient :: (EmbedIO m) => Config m -> Handle -> IO ()
doClient cfg h = do
	hSetBuffering h NoBuffering
	chan <- (newChan :: IO (Chan Msg))
	st <- forkIO $ sender (readChan chan) (BS.hPut h . BS.concat . B.toChunks) -- make a strict bytestring
	receiver cfg h (writeChan chan)
	killThread st
	hClose h

recvPacket :: Handle -> IO Msg
recvPacket h = do
	-- TODO error reporting
	s <- B.hGet h 4
	let l = fromIntegral $ runGet getWord32le $ assert (B.length s == 4) s
	p <- B.hGet h $ l - 4
	let m = runGet (get :: Get Msg) (B.append s p)
	debugM "Network.NineP.Server" $ show m
	return m

sender :: IO Msg -> (ByteString -> IO ()) -> IO ()
sender get say = forever $ do
	msg <- get
	debugM "Network.NineP.Server" $ show msg
	say $ runPut $ put msg

receiver :: (EmbedIO m) => Config m -> Handle -> (Msg -> IO ()) -> IO ()
receiver cfg h say = runReaderT (runMState (iterateUntil id (do
			mp <- liftIO $ try $ recvPacket h
			case mp of
				Left (e :: SomeException) -> do
					return $ putStrLn $ show e
					return True
				Right p -> do
					forkM $ handleMsg say p
					return False
		) >> return ()
	) (emptyState $ monadState cfg)) cfg >> return ()

handleMsg :: (EmbedIO m) => (Msg -> IO ()) -> Msg -> MState (NineState m) (ReaderT (Config m) IO) ()
handleMsg say p = do
	let Msg typ t m = p
	r <- try (case typ of
			TTversion -> rversion p
			TTattach -> rattach p
			TTwalk -> rwalk p
			TTstat -> rstat p
			TTwstat -> rwstat p
			TTclunk -> rclunk p
			TTauth -> rauth p
			TTopen -> ropen p
			TTread -> rread p
			TTwrite -> rwrite p
			TTremove -> rremove p
			TTcreate -> rcreate p
			TTflush -> rflush p
		)
	case r of
		(Right response) -> liftIO $ mapM_ say $ response
		-- FIXME which exceptions should i catch?
		(Left fail) -> liftIO $ say $ Msg TRerror t $ Rerror $ show $ (fail :: SomeException)