-- |
-- 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.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 :: String -> Maybe a
maybeRead = ((a, String) -> a) -> Maybe (a, String) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, String) -> a
forall a b. (a, b) -> a
fst (Maybe (a, String) -> Maybe a)
-> (String -> Maybe (a, String)) -> String -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, String)] -> Maybe (a, String)
forall a. [a] -> Maybe a
listToMaybe ([(a, String)] -> Maybe (a, String))
-> (String -> [(a, String)]) -> String -> Maybe (a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(a, String)]
forall a. Read a => ReadS a
reads

listenOn :: SockAddr -> IO Socket
listenOn SockAddr
addr = do
	Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
defaultProtocol
	Socket -> SockAddr -> IO ()
bind Socket
sock SockAddr
addr
	Socket -> Int -> IO ()
listen Socket
sock Int
5
	Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

connection :: String -> IO Socket
connection :: String -> IO Socket
connection String
s = let	pat :: ByteString
pat = ByteString
"tcp!(.*)!([0-9]*)|unix!(.*)" :: ByteString
			wrongAddr :: IO a
wrongAddr = IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"wrong 9p connection address: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
			(String
bef, String
_, String
aft, [String]
grps) = String
s String -> ByteString -> (String, String, String, [String])
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ ByteString
pat :: (String, String, String, [String])
	in if (String
bef String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" Bool -> Bool -> Bool
|| String
aft String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" Bool -> Bool -> Bool
|| [String]
grps [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [])
		then IO Socket
forall a. IO a
wrongAddr
		else case [String]
grps of
			[String
addr, String
port, String
""] -> String -> PortNumber -> IO Socket
listen' String
addr (PortNumber -> IO Socket) -> PortNumber -> IO Socket
forall a b. (a -> b) -> a -> b
$ Int -> PortNumber
forall a. Enum a => Int -> a
toEnum (Int -> PortNumber) -> Int -> PortNumber
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
2358 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
maybeRead String
port :: Int)
			[String
"", String
"", String
addr]  -> SockAddr -> IO Socket
listenOn (SockAddr -> IO Socket) -> SockAddr -> IO Socket
forall a b. (a -> b) -> a -> b
$ String -> SockAddr
SockAddrUnix String
addr
			[String]
_ -> IO Socket
forall a. IO a
wrongAddr

listen' :: HostName -> PortNumber -> IO Socket
listen' :: String -> PortNumber -> IO Socket
listen' String
hostname PortNumber
port = do
	ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber String
"tcp"
	IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracketOnError (Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET SocketType
Stream ProtocolNumber
proto) Socket -> IO ()
close (\Socket
sock -> do
		Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
		HostEntry
he <- String -> IO HostEntry
getHostByName String
hostname
		Socket -> SockAddr -> IO ()
bind Socket
sock (PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
port (HostEntry -> HostAddress
hostAddress HostEntry
he))
		Socket -> Int -> IO ()
listen Socket
sock Int
maxListenQueue
		Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock)

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

serve :: (EmbedIO m) => Socket -> Config m -> IO ()
serve :: Socket -> Config m -> IO ()
serve Socket
s Config m
cfg = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> IO (Socket, SockAddr)
accept Socket
s IO (Socket, SockAddr) -> ((Socket, SockAddr) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (
		\(Socket
s, SockAddr
_) -> (Config m -> Handle -> IO ()
forall (m :: * -> *). EmbedIO m => Config m -> Handle -> IO ()
doClient Config m
cfg) (Handle -> IO ()) -> IO Handle -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO Handle -> IO Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> IO Handle) -> IO Handle -> IO Handle
forall a b. (a -> b) -> a -> b
$ Socket -> IOMode -> IO Handle
socketToHandle Socket
s IOMode
ReadWriteMode))

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

recvPacket :: Handle -> IO Msg
recvPacket :: Handle -> IO Msg
recvPacket Handle
h = do
	-- TODO error reporting
	ByteString
s <- Handle -> Int -> IO ByteString
B.hGet Handle
h Int
4
	let l :: Int
l = HostAddress -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HostAddress -> Int) -> HostAddress -> Int
forall a b. (a -> b) -> a -> b
$ Get HostAddress -> ByteString -> HostAddress
forall a. Get a -> ByteString -> a
runGet Get HostAddress
getWord32le (ByteString -> HostAddress) -> ByteString -> HostAddress
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (ByteString -> Int64
B.length ByteString
s Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
4) ByteString
s
	ByteString
p <- Handle -> Int -> IO ByteString
B.hGet Handle
h (Int -> IO ByteString) -> Int -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4
	let m :: Msg
m = Get Msg -> ByteString -> Msg
forall a. Get a -> ByteString -> a
runGet (Get Msg
forall a. Bin a => Get a
get :: Get Msg) (ByteString -> ByteString -> ByteString
B.append ByteString
s ByteString
p)
	String -> String -> IO ()
debugM String
"Network.NineP.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Msg -> String
forall a. Show a => a -> String
show Msg
m
	Msg -> IO Msg
forall (m :: * -> *) a. Monad m => a -> m a
return Msg
m

sender :: IO Msg -> (ByteString -> IO ()) -> IO ()
sender :: IO Msg -> (ByteString -> IO ()) -> IO ()
sender IO Msg
get ByteString -> IO ()
say = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
	Msg
msg <- IO Msg
get
	String -> String -> IO ()
debugM String
"Network.NineP.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Msg -> String
forall a. Show a => a -> String
show Msg
msg
	ByteString -> IO ()
say (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Msg -> Put
forall a. Bin a => a -> Put
put Msg
msg

receiver :: (EmbedIO m) => Config m -> Handle -> (Msg -> IO ()) -> IO ()
receiver :: Config m -> Handle -> (Msg -> IO ()) -> IO ()
receiver Config m
cfg Handle
h Msg -> IO ()
say = ReaderT (Config m) IO ((), NineState m)
-> Config m -> IO ((), NineState m)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (MState (NineState m) (ReaderT (Config m) IO) ()
-> NineState m -> ReaderT (Config m) IO ((), NineState m)
forall (m :: * -> *) t a.
MonadPeelIO m =>
MState t m a -> t -> m (a, t)
runMState ((Bool -> Bool)
-> MState (NineState m) (ReaderT (Config m) IO) Bool
-> MState (NineState m) (ReaderT (Config m) IO) Bool
forall (m :: * -> *) a. Monad m => (a -> Bool) -> m a -> m a
iterateUntil Bool -> Bool
forall a. a -> a
id (do
			Either SomeException Msg
mp <- IO (Either SomeException Msg)
-> MState
     (NineState m) (ReaderT (Config m) IO) (Either SomeException Msg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException Msg)
 -> MState
      (NineState m) (ReaderT (Config m) IO) (Either SomeException Msg))
-> IO (Either SomeException Msg)
-> MState
     (NineState m) (ReaderT (Config m) IO) (Either SomeException Msg)
forall a b. (a -> b) -> a -> b
$ IO Msg -> IO (Either SomeException Msg)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO Msg -> IO (Either SomeException Msg))
-> IO Msg -> IO (Either SomeException Msg)
forall a b. (a -> b) -> a -> b
$ Handle -> IO Msg
recvPacket Handle
h
			case Either SomeException Msg
mp of
				Left (SomeException
e :: SomeException) -> do
					IO () -> MState (NineState m) (ReaderT (Config m) IO) (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> MState (NineState m) (ReaderT (Config m) IO) (IO ()))
-> IO () -> MState (NineState m) (ReaderT (Config m) IO) (IO ())
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
errorM String
"Network.NineP.Server" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
					Bool -> MState (NineState m) (ReaderT (Config m) IO) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
				Right Msg
p -> do
					MState (NineState m) (ReaderT (Config m) IO) ()
-> MState (NineState m) (ReaderT (Config m) IO) ThreadId
forall (m :: * -> *) t.
MonadPeelIO m =>
MState t m () -> MState t m ThreadId
forkM (MState (NineState m) (ReaderT (Config m) IO) ()
 -> MState (NineState m) (ReaderT (Config m) IO) ThreadId)
-> MState (NineState m) (ReaderT (Config m) IO) ()
-> MState (NineState m) (ReaderT (Config m) IO) ThreadId
forall a b. (a -> b) -> a -> b
$ (Msg -> IO ())
-> Msg -> MState (NineState m) (ReaderT (Config m) IO) ()
forall (m :: * -> *).
EmbedIO m =>
(Msg -> IO ())
-> Msg -> MState (NineState m) (ReaderT (Config m) IO) ()
handleMsg Msg -> IO ()
say Msg
p
					Bool -> MState (NineState m) (ReaderT (Config m) IO) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
		) MState (NineState m) (ReaderT (Config m) IO) Bool
-> MState (NineState m) (ReaderT (Config m) IO) ()
-> MState (NineState m) (ReaderT (Config m) IO) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> MState (NineState m) (ReaderT (Config m) IO) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
	) (Content m -> NineState m
forall (m :: * -> *). Content m -> NineState m
emptyState (Content m -> NineState m) -> Content m -> NineState m
forall a b. (a -> b) -> a -> b
$ Config m -> Content m
forall (m :: * -> *). Config m -> Content m
monadState Config m
cfg)) Config m
cfg IO ((), NineState m) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

handleMsg :: (EmbedIO m) => (Msg -> IO ()) -> Msg -> MState (NineState m) (ReaderT (Config m) IO) ()
handleMsg :: (Msg -> IO ())
-> Msg -> MState (NineState m) (ReaderT (Config m) IO) ()
handleMsg Msg -> IO ()
say Msg
p = do
	let Msg Tag
typ Word16
t VarMsg
m = Msg
p
	Either SomeException [Msg]
r <- MState (NineState m) (ReaderT (Config m) IO) [Msg]
-> MState
     (NineState m) (ReaderT (Config m) IO) (Either SomeException [Msg])
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (case Tag
typ of
			Tag
TTversion -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m :: * -> *). Msg -> Nine m [Msg]
rversion Msg
p
			Tag
TTattach -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
(EmbedIO m1, Monad m2) =>
Msg -> MState (NineState m1) (ReaderT (Config m1) IO) (m2 Msg)
rattach Msg
p
			Tag
TTwalk -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
(EmbedIO m1, Monad m2) =>
Msg -> MState (NineState m1) (ReaderT (Config m1) IO) (m2 Msg)
rwalk Msg
p
			Tag
TTstat -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
(EmbedIO m1, Monad m2) =>
Msg -> MState (NineState m1) (ReaderT (Config m1) IO) (m2 Msg)
rstat Msg
p
			Tag
TTwstat -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
Monad m1 =>
Msg -> MState (NineState m2) (ReaderT (Config m2) IO) (m1 Msg)
rwstat Msg
p
			Tag
TTclunk -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
Monad m1 =>
Msg -> MState (NineState m2) (ReaderT (Config m2) IO) (m1 Msg)
rclunk Msg
p
			Tag
TTauth -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall a. Msg -> a
rauth Msg
p
			Tag
TTopen -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
(EmbedIO m1, Monad m2) =>
Msg -> MState (NineState m1) (ReaderT (Config m1) IO) (m2 Msg)
ropen Msg
p
			Tag
TTread -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m :: * -> *). (Monad m, EmbedIO m) => Msg -> Nine m [Msg]
rread Msg
p
			Tag
TTwrite -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
(EmbedIO m1, Monad m2) =>
Msg -> MState (NineState m1) (ReaderT (Config m1) IO) (m2 Msg)
rwrite Msg
p
			Tag
TTremove -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m :: * -> *) b.
Msg -> MState (NineState m) (ReaderT (Config m) IO) b
rremove Msg
p
			Tag
TTcreate -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
(EmbedIO m1, Monad m2) =>
Msg -> MState (NineState m1) (ReaderT (Config m1) IO) (m2 Msg)
rcreate Msg
p
			Tag
TTflush -> Msg -> MState (NineState m) (ReaderT (Config m) IO) [Msg]
forall (m1 :: * -> *) (m2 :: * -> *).
(Monad m1, Monad m2) =>
Msg -> m1 (m2 Msg)
rflush Msg
p
		)
	case Either SomeException [Msg]
r of
		(Right [Msg]
response) -> IO () -> MState (NineState m) (ReaderT (Config m) IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MState (NineState m) (ReaderT (Config m) IO) ())
-> IO () -> MState (NineState m) (ReaderT (Config m) IO) ()
forall a b. (a -> b) -> a -> b
$ (Msg -> IO ()) -> [Msg] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Msg -> IO ()
say ([Msg] -> IO ()) -> [Msg] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Msg]
response
		-- FIXME which exceptions should i catch?
		(Left SomeException
fail) -> IO () -> MState (NineState m) (ReaderT (Config m) IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MState (NineState m) (ReaderT (Config m) IO) ())
-> IO () -> MState (NineState m) (ReaderT (Config m) IO) ()
forall a b. (a -> b) -> a -> b
$ Msg -> IO ()
say (Msg -> IO ()) -> Msg -> IO ()
forall a b. (a -> b) -> a -> b
$ Tag -> Word16 -> VarMsg -> Msg
Msg Tag
TRerror Word16
t (VarMsg -> Msg) -> VarMsg -> Msg
forall a b. (a -> b) -> a -> b
$ String -> VarMsg
Rerror (String -> VarMsg) -> String -> VarMsg
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException -> String) -> SomeException -> String
forall a b. (a -> b) -> a -> b
$ (SomeException
fail :: SomeException)