{-# 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 VerUnknown = "unknown"
show Ver9P2000 = "9P2000"
readVersion :: String -> NineVersion
readVersion s = if isPrefixOf "9P2000" s then Ver9P2000 else VerUnknown
data Config m = Config {
root :: NineFile m,
addr :: String,
monadState :: Content m
}
data NineState m = NineState {
fidMap :: Map Word32 (NineFile m),
flushMap :: Map Word16 (IO ()),
msize :: Word32,
protoVersion :: NineVersion,
mState :: Content m
}
emptyState m = NineState {
fidMap = M.empty :: Map Word32 (NineFile m),
flushMap = M.empty :: Map Word16 (IO ()),
msize = 0,
protoVersion = VerUnknown,
mState = m
}
type Nine m x = MState (NineState m) (ReaderT (Config m) IO) x
instance MonadThrow m => MonadThrow (MState s m) where
throwM e = lift $ throwM e
instance (MonadCatch m, MonadPeelIO m) => MonadCatch (MState s m) where
catch = P.catch
call :: (EmbedIO m) => Word16 -> m a -> MState (NineState m) (ReaderT (Config m) IO) a
call tag x = do
s <- (return . mState) =<< get
thread <- liftIO $ async $ callback x s
flushable tag thread
lift $ lift $ wait thread
lookup :: Word32 -> Nine m (NineFile m)
lookup fid = do
m <- (return . fidMap) =<< get
case M.lookup fid m of
Nothing -> throw $ ENoFid fid
Just f -> return f
insert :: Word32 -> NineFile m -> Nine m ()
insert fid f = do
m <- (return . fidMap) =<< get
modifyM_ (\s -> s { fidMap = M.insert fid f $ fidMap s })
delete :: Word32 -> Nine m ()
delete fid = do
modifyM_ (\s -> s { fidMap = M.delete fid $ fidMap s })
iounit :: Nine m Word32
iounit = do
ms <- (return . msize) =<< get
return $ ms - 24
flushable :: Word16 -> Async a -> Nine m ()
flushable tag thread = modifyM_ (\s -> s { flushMap = M.insert tag (cancel thread) $ flushMap s })
flush :: Word16 -> Nine m ()
flush tag = do
m <- (return . flushMap) =<< get
case M.lookup tag m of
Nothing -> return ()
Just handler -> lift $ lift handler