{-# LANGUAGE FlexibleContexts #-}

module Network.NineP.Internal.State
	( Nine
	, NineVersion(..)
	, readVersion
	, Config(..)
	, NineState(..)
	, emptyState
	, lookup
	, insert
	, delete
	, iounit
	, call
	) where

import Control.Concurrent.Async
import Control.Concurrent.MState
import Control.Exception (throw)
import Control.Exception.Peel as P
import Control.Monad.Catch
import Control.Monad.EmbedIO
import Control.Monad.IO.Peel
import Control.Monad.Reader
import Control.Monad.State.Class
import Data.List (isPrefixOf)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Word
import Prelude hiding (lookup)

import Network.NineP.Error
import Network.NineP.Internal.File

data NineVersion = VerUnknown | Ver9P2000

instance Show NineVersion where
	show :: NineVersion -> String
show NineVersion
VerUnknown = String
"unknown"
	show NineVersion
Ver9P2000 = String
"9P2000"

readVersion :: String -> NineVersion
readVersion :: String -> NineVersion
readVersion String
s = if String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"9P2000" String
s then NineVersion
Ver9P2000 else NineVersion
VerUnknown

-- |Server configuration.
data Config m = Config {
		-- |The @/@ directory of the hosted filesystem.
		Config m -> NineFile m
root :: NineFile m,
		-- |The listening address. The syntax is taken from @Plan 9@ operating system and has the form @unix!\/path\/to\/socket@ for unix socket files, and @tcp!hostname!port@ for tcp sockets.
		Config m -> String
addr :: String,
		-- |The initial state for the user-supplied monad. Use 'Void' for 'IO'.
		Config m -> Content m
monadState :: Content m
	}

data NineState m = NineState {
		NineState m -> Map Word32 (NineFile m)
fidMap :: Map Word32 (NineFile m),
		NineState m -> Map Word16 (IO ())
flushMap :: Map Word16 (IO ()),
		NineState m -> Word32
msize :: Word32,
		NineState m -> NineVersion
protoVersion :: NineVersion,
		NineState m -> Content m
mState :: Content m
	}

emptyState :: Content m -> NineState m
emptyState Content m
m = NineState :: forall (m :: * -> *).
Map Word32 (NineFile m)
-> Map Word16 (IO ())
-> Word32
-> NineVersion
-> Content m
-> NineState m
NineState {
	fidMap :: Map Word32 (NineFile m)
fidMap = forall k a. Map k a
forall (m :: * -> *). Map Word32 (NineFile m)
M.empty :: Map Word32 (NineFile m),
	flushMap :: Map Word16 (IO ())
flushMap = Map Word16 (IO ())
forall k a. Map k a
M.empty :: Map Word16 (IO ()),
	msize :: Word32
msize = Word32
0,
	protoVersion :: NineVersion
protoVersion = NineVersion
VerUnknown,
	mState :: Content m
mState = Content m
m
}

type Nine m x = MState (NineState m) (ReaderT (Config m) IO) x

instance MonadThrow m => MonadThrow (MState s m) where
	throwM :: e -> MState s m a
throwM e
e = m a -> MState s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> MState s m a) -> m a -> MState s m a
forall a b. (a -> b) -> a -> b
$ e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e
instance (MonadCatch m, MonadPeelIO m) => MonadCatch (MState s m) where
	catch :: MState s m a -> (e -> MState s m a) -> MState s m a
catch = MState s m a -> (e -> MState s m a) -> MState s m a
forall (m :: * -> *) e a.
(MonadPeelIO m, Exception e) =>
m a -> (e -> m a) -> m a
P.catch

call :: (EmbedIO m) => Word16 -> m a -> MState (NineState m) (ReaderT (Config m) IO) a
call :: Word16 -> m a -> MState (NineState m) (ReaderT (Config m) IO) a
call Word16
tag m a
x = do
	Content m
s <- (Content m
-> MState (NineState m) (ReaderT (Config m) IO) (Content m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Content m
 -> MState (NineState m) (ReaderT (Config m) IO) (Content m))
-> (NineState m -> Content m)
-> NineState m
-> MState (NineState m) (ReaderT (Config m) IO) (Content m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NineState m -> Content m
forall (m :: * -> *). NineState m -> Content m
mState) (NineState m
 -> MState (NineState m) (ReaderT (Config m) IO) (Content m))
-> MState (NineState m) (ReaderT (Config m) IO) (NineState m)
-> MState (NineState m) (ReaderT (Config m) IO) (Content m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MState (NineState m) (ReaderT (Config m) IO) (NineState m)
forall s (m :: * -> *). MonadState s m => m s
get
	Async a
thread <- IO (Async a)
-> MState (NineState m) (ReaderT (Config m) IO) (Async a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async a)
 -> MState (NineState m) (ReaderT (Config m) IO) (Async a))
-> IO (Async a)
-> MState (NineState m) (ReaderT (Config m) IO) (Async a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async (IO a -> IO (Async a)) -> IO a -> IO (Async a)
forall a b. (a -> b) -> a -> b
$ m a -> Content m -> IO a
forall (o :: * -> *) a. EmbedIO o => o a -> Content o -> IO a
callback m a
x Content m
s
	Word16 -> Async a -> Nine m ()
forall a (m :: * -> *). Word16 -> Async a -> Nine m ()
flushable Word16
tag Async a
thread
	ReaderT (Config m) IO a
-> MState (NineState m) (ReaderT (Config m) IO) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Config m) IO a
 -> MState (NineState m) (ReaderT (Config m) IO) a)
-> ReaderT (Config m) IO a
-> MState (NineState m) (ReaderT (Config m) IO) a
forall a b. (a -> b) -> a -> b
$ IO a -> ReaderT (Config m) IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT (Config m) IO a)
-> IO a -> ReaderT (Config m) IO a
forall a b. (a -> b) -> a -> b
$ Async a -> IO a
forall a. Async a -> IO a
wait Async a
thread

lookup :: Word32 -> Nine m (NineFile m)
lookup :: Word32 -> Nine m (NineFile m)
lookup Word32
fid = do
	Map Word32 (NineFile m)
m <- (Map Word32 (NineFile m)
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Word32 (NineFile m)
 -> MState
      (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m)))
-> (NineState m -> Map Word32 (NineFile m))
-> NineState m
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NineState m -> Map Word32 (NineFile m)
forall (m :: * -> *). NineState m -> Map Word32 (NineFile m)
fidMap) (NineState m
 -> MState
      (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m)))
-> MState (NineState m) (ReaderT (Config m) IO) (NineState m)
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MState (NineState m) (ReaderT (Config m) IO) (NineState m)
forall s (m :: * -> *). MonadState s m => m s
get 
	case Word32 -> Map Word32 (NineFile m) -> Maybe (NineFile m)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word32
fid Map Word32 (NineFile m)
m of
		Maybe (NineFile m)
Nothing -> NineError -> Nine m (NineFile m)
forall a e. Exception e => e -> a
throw (NineError -> Nine m (NineFile m))
-> NineError -> Nine m (NineFile m)
forall a b. (a -> b) -> a -> b
$ Word32 -> NineError
ENoFid Word32
fid
		Just NineFile m
f -> NineFile m -> Nine m (NineFile m)
forall (m :: * -> *) a. Monad m => a -> m a
return NineFile m
f

insert :: Word32 -> NineFile m -> Nine m ()
insert :: Word32 -> NineFile m -> Nine m ()
insert Word32
fid NineFile m
f = do
	Map Word32 (NineFile m)
m <- (Map Word32 (NineFile m)
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Word32 (NineFile m)
 -> MState
      (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m)))
-> (NineState m -> Map Word32 (NineFile m))
-> NineState m
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NineState m -> Map Word32 (NineFile m)
forall (m :: * -> *). NineState m -> Map Word32 (NineFile m)
fidMap) (NineState m
 -> MState
      (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m)))
-> MState (NineState m) (ReaderT (Config m) IO) (NineState m)
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word32 (NineFile m))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MState (NineState m) (ReaderT (Config m) IO) (NineState m)
forall s (m :: * -> *). MonadState s m => m s
get 
	(NineState m -> NineState m) -> Nine m ()
forall (m :: * -> *) t. MonadIO m => (t -> t) -> MState t m ()
modifyM_ (\NineState m
s -> NineState m
s { fidMap :: Map Word32 (NineFile m)
fidMap = Word32
-> NineFile m -> Map Word32 (NineFile m) -> Map Word32 (NineFile m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Word32
fid NineFile m
f (Map Word32 (NineFile m) -> Map Word32 (NineFile m))
-> Map Word32 (NineFile m) -> Map Word32 (NineFile m)
forall a b. (a -> b) -> a -> b
$ NineState m -> Map Word32 (NineFile m)
forall (m :: * -> *). NineState m -> Map Word32 (NineFile m)
fidMap NineState m
s })

delete :: Word32 -> Nine m ()
delete :: Word32 -> Nine m ()
delete Word32
fid = do
	(NineState m -> NineState m) -> Nine m ()
forall (m :: * -> *) t. MonadIO m => (t -> t) -> MState t m ()
modifyM_ (\NineState m
s -> NineState m
s { fidMap :: Map Word32 (NineFile m)
fidMap = Word32 -> Map Word32 (NineFile m) -> Map Word32 (NineFile m)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Word32
fid (Map Word32 (NineFile m) -> Map Word32 (NineFile m))
-> Map Word32 (NineFile m) -> Map Word32 (NineFile m)
forall a b. (a -> b) -> a -> b
$ NineState m -> Map Word32 (NineFile m)
forall (m :: * -> *). NineState m -> Map Word32 (NineFile m)
fidMap NineState m
s })

iounit :: Nine m Word32
iounit :: Nine m Word32
iounit = do
	Word32
ms <- (Word32 -> Nine m Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Nine m Word32)
-> (NineState m -> Word32) -> NineState m -> Nine m Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NineState m -> Word32
forall (m :: * -> *). NineState m -> Word32
msize) (NineState m -> Nine m Word32)
-> MState (NineState m) (ReaderT (Config m) IO) (NineState m)
-> Nine m Word32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MState (NineState m) (ReaderT (Config m) IO) (NineState m)
forall s (m :: * -> *). MonadState s m => m s
get
	-- 23 is the biggest size of a message (write), but libixp uses 24, so we do too to stay safe
	Word32 -> Nine m Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Nine m Word32) -> Word32 -> Nine m Word32
forall a b. (a -> b) -> a -> b
$ Word32
ms Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
24

flushable :: Word16 -> Async a -> Nine m ()
flushable :: Word16 -> Async a -> Nine m ()
flushable Word16
tag Async a
thread = (NineState m -> NineState m) -> Nine m ()
forall (m :: * -> *) t. MonadIO m => (t -> t) -> MState t m ()
modifyM_ (\NineState m
s -> NineState m
s { flushMap :: Map Word16 (IO ())
flushMap = Word16 -> IO () -> Map Word16 (IO ()) -> Map Word16 (IO ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Word16
tag (Async a -> IO ()
forall a. Async a -> IO ()
cancel Async a
thread) (Map Word16 (IO ()) -> Map Word16 (IO ()))
-> Map Word16 (IO ()) -> Map Word16 (IO ())
forall a b. (a -> b) -> a -> b
$ NineState m -> Map Word16 (IO ())
forall (m :: * -> *). NineState m -> Map Word16 (IO ())
flushMap NineState m
s })

flush :: Word16 -> Nine m ()
flush :: Word16 -> Nine m ()
flush Word16
tag = do
	Map Word16 (IO ())
m <- (Map Word16 (IO ())
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word16 (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Word16 (IO ())
 -> MState
      (NineState m) (ReaderT (Config m) IO) (Map Word16 (IO ())))
-> (NineState m -> Map Word16 (IO ()))
-> NineState m
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word16 (IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NineState m -> Map Word16 (IO ())
forall (m :: * -> *). NineState m -> Map Word16 (IO ())
flushMap) (NineState m
 -> MState
      (NineState m) (ReaderT (Config m) IO) (Map Word16 (IO ())))
-> MState (NineState m) (ReaderT (Config m) IO) (NineState m)
-> MState
     (NineState m) (ReaderT (Config m) IO) (Map Word16 (IO ()))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MState (NineState m) (ReaderT (Config m) IO) (NineState m)
forall s (m :: * -> *). MonadState s m => m s
get
	case Word16 -> Map Word16 (IO ()) -> Maybe (IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word16
tag Map Word16 (IO ())
m of
		Maybe (IO ())
Nothing -> () -> Nine m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
		Just IO ()
handler -> ReaderT (Config m) IO () -> Nine m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Config m) IO () -> Nine m ())
-> ReaderT (Config m) IO () -> Nine m ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT (Config m) IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO ()
handler