{-# 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 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.
		forall (m :: * -> *). 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.
		forall (m :: * -> *). Config m -> String
addr :: String,
		-- |The initial state for the user-supplied monad. Use 'Void' for 'IO'.
		forall (m :: * -> *). Config m -> Content m
monadState :: Content m
	}

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

emptyState :: Content m -> NineState m
emptyState Content m
m = NineState {
	fidMap :: Map Word32 (NineFile m)
fidMap = forall k a. Map k a
M.empty :: Map Word32 (NineFile m),
	flushMap :: Map Word16 (IO ())
flushMap = 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 :: forall e a. Exception e => e -> MState s m a
throwM e
e = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 :: forall e a.
Exception e =>
MState s m a -> (e -> MState s m a) -> MState s m a
catch = 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 :: forall (m :: * -> *) a.
EmbedIO m =>
Word16 -> m a -> MState (NineState m) (ReaderT (Config m) IO) a
call Word16
tag m a
x = do
	Content m
s <- (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). NineState m -> Content m
mState) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get
	Async a
thread <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (o :: * -> *) a. EmbedIO o => o a -> Content o -> IO a
callback m a
x Content m
s
	forall a (m :: * -> *). Word16 -> Async a -> Nine m ()
flushable Word16
tag Async a
thread
	forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO a
wait Async a
thread

lookup :: Word32 -> Nine m (NineFile m)
lookup :: forall (m :: * -> *). Word32 -> Nine m (NineFile m)
lookup Word32
fid = do
	Map Word32 (NineFile m)
m <- (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). NineState m -> Map Word32 (NineFile m)
fidMap) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get 
	case 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 -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ Word32 -> NineError
ENoFid Word32
fid
		Just NineFile m
f -> forall (m :: * -> *) a. Monad m => a -> m a
return NineFile m
f

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

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

iounit :: Nine m Word32
iounit :: forall (m :: * -> *). Nine m Word32
iounit = do
	Word32
ms <- (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). NineState m -> Word32
msize) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
	forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word32
ms forall a. Num a => a -> a -> a
- Word32
24

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

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