diff --git a/metro.cabal b/metro.cabal --- a/metro.cabal +++ b/metro.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: cff32aadbb54ab06abb8cf6fdb73517cd18298a9730b7018798ee65d56321d11 +-- hash: 091d5108d142d16f7ceef8cc4670d202f181d28a52188b006c87fab5ec895f24 name: metro -version: 0.1.0.4 +version: 0.1.0.5 synopsis: A simple tcp and udp socket server framework description: Please see the README on GitHub at category: Network,Framework @@ -32,7 +32,6 @@ Metro Metro.Class Metro.Conn - Metro.IOHashMap Metro.Lock Metro.Node Metro.Server @@ -49,10 +48,10 @@ , binary , bytestring , hashable + , hashmap-io , hslogger , mtl , transformers , unix-time , unliftio - , unordered-containers default-language: Haskell2010 diff --git a/src/Metro/IOHashMap.hs b/src/Metro/IOHashMap.hs deleted file mode 100644 --- a/src/Metro/IOHashMap.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Metro.IOHashMap - ( IOHashMap - , newIOHashMap - , insert - , delete - , lookup - , update - , adjust - , alter - , null - , size - , member - , keys - , elems - , clear - , toList - - , insertSTM - , lookupSTM - , foldrWithKeySTM - , deleteSTM - ) where - -import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import Prelude hiding (lookup, null) -import UnliftIO (MonadIO (..), STM, TVar, atomically, - modifyTVar', newTVarIO, readTVar, - readTVarIO) - -newtype IOHashMap a b = IOHashMap (TVar (HashMap a b)) - -newIOHashMap :: MonadIO m => m (IOHashMap a b) -newIOHashMap = IOHashMap <$> newTVarIO HM.empty - -insert :: (Eq a, Hashable a, MonadIO m) => IOHashMap a b -> a -> b -> m () -insert (IOHashMap h) k v = atomically . modifyTVar' h $ HM.insert k v - -delete :: (Eq a, Hashable a, MonadIO m) => IOHashMap a b -> a -> m () -delete (IOHashMap h) k = atomically . modifyTVar' h $ HM.delete k - -lookup :: (Eq a, Hashable a, MonadIO m) => IOHashMap a b -> a -> m (Maybe b) -lookup (IOHashMap h) k = HM.lookup k <$> readTVarIO h - -adjust :: (Eq a, Hashable a, MonadIO m) => IOHashMap a b -> (b -> b) -> a -> m () -adjust (IOHashMap h) f k = atomically . modifyTVar' h $ HM.adjust f k - -update :: (Eq a, Hashable a, MonadIO m) => IOHashMap a b -> (b -> Maybe b) -> a -> m () -update (IOHashMap h) f k = atomically . modifyTVar' h $ HM.update f k - -alter :: (Eq a, Hashable a, MonadIO m) => IOHashMap a b -> (Maybe b -> Maybe b) -> a -> m () -alter (IOHashMap h) f k = atomically . modifyTVar' h $ HM.alter f k - -null :: MonadIO m => IOHashMap a b -> m Bool -null (IOHashMap h) = HM.null <$> readTVarIO h - -size :: MonadIO m => IOHashMap a b -> m Int -size (IOHashMap h) = HM.size <$> readTVarIO h - -member :: (Eq a, Hashable a, MonadIO m) => IOHashMap a b -> a -> m Bool -member (IOHashMap h) k = HM.member k <$> readTVarIO h - -keys :: MonadIO m => IOHashMap a b -> m [a] -keys (IOHashMap h) = HM.keys <$> readTVarIO h - -elems :: MonadIO m => IOHashMap a b -> m [b] -elems (IOHashMap h) = HM.elems <$> readTVarIO h - -clear :: MonadIO m => IOHashMap a b -> m () -clear (IOHashMap h) = atomically . modifyTVar' h $ const HM.empty - -toList :: MonadIO m => IOHashMap a b -> m [(a, b)] -toList (IOHashMap h) = HM.toList <$> readTVarIO h - -insertSTM :: (Eq a, Hashable a) => IOHashMap a b -> a -> b -> STM () -insertSTM (IOHashMap h) k v = modifyTVar' h $ HM.insert k v - -lookupSTM :: (Eq a, Hashable a) => IOHashMap a b -> a -> STM (Maybe b) -lookupSTM (IOHashMap h) k = HM.lookup k <$> readTVar h - -foldrWithKeySTM :: IOHashMap a b -> (a -> b -> c -> c) -> c -> STM c -foldrWithKeySTM (IOHashMap h) f acc = HM.foldrWithKey f acc <$> readTVar h - -deleteSTM :: (Eq a, Hashable a) => IOHashMap a b -> a -> STM () -deleteSTM (IOHashMap h) k = modifyTVar' h $ HM.delete k diff --git a/src/Metro/Node.hs b/src/Metro/Node.hs --- a/src/Metro/Node.hs +++ b/src/Metro/Node.hs @@ -49,12 +49,15 @@ , getSessionSize1 ) where -import Control.Monad (forM, forever, mzero, void, when) +import Control.Monad (forM, forever, void, when) +import Control.Monad.Cont (callCC, runContT) import Control.Monad.Reader.Class (MonadReader (ask), asks) import Control.Monad.Trans.Class (MonadTrans (..)) -import Control.Monad.Trans.Maybe (runMaybeT) import Control.Monad.Trans.Reader (ReaderT (..), runReaderT) import Data.Hashable +import Data.IOHashMap (IOHashMap) +import qualified Data.IOHashMap as HM (delete, elems, empty, insert, + lookup, size) import Data.Int (Int64) import Data.Maybe (fromMaybe, isJust) import Metro.Class (GetPacketId, RecvPacket, @@ -62,9 +65,6 @@ getPacketId) import Metro.Conn (ConnEnv, ConnT, FromConn (..), close, receive, runConnT) -import Metro.IOHashMap (IOHashMap, newIOHashMap) -import qualified Metro.IOHashMap as HM (delete, elems, insert, - lookup, size) import Metro.Session (SessionEnv (sessionId), SessionT, feed, isTimeout, runSessionT) import qualified Metro.Session as S (newSessionEnv, receive, send) @@ -132,7 +132,7 @@ initEnv uEnv nodeId sessionGen = do nodeStatus <- newTVarIO True nodeSession <- newTVarIO Nothing - sessionList <- newIOHashMap + sessionList <- HM.empty nodeTimer <- newTVarIO =<< getEpochTime onNodeLeave <- newTVarIO Nothing sessTimeout <- newTVarIO 300 @@ -200,7 +200,7 @@ Just _ -> do state <- readTVar nodeStatus when state retrySTM - Multi -> HM.insert sessionList sid sEnv + Multi -> HM.insert sid sEnv sessionList return sEnv nextSessionId :: MonadIO m => NodeT u nid k rpkt tp m k @@ -211,7 +211,7 @@ NodeEnv{..} <- ask case nodeMode of Single -> atomically $ writeTVar nodeSession Nothing - Multi -> HM.delete sessionList mid + Multi -> HM.delete mid sessionList busy :: MonadIO m => NodeT u nid k rpkt tp m Bool busy = do @@ -255,7 +255,7 @@ NodeEnv{..} <- ask v <- case nodeMode of Single -> readTVarIO nodeSession - Multi -> HM.lookup sessionList $ getPacketId rpkt + Multi -> HM.lookup (getPacketId rpkt) sessionList case v of Just aEnv -> runSessionT_ aEnv $ feed $ Just rpkt @@ -266,7 +266,7 @@ when (sessionMode == MultiAction) $ case nodeMode of Single -> atomically $ writeTVar nodeSession $ Just sEnv - Multi -> HM.insert sessionList sid sEnv + Multi -> HM.insert sid sEnv sessionList bracket (return sid) removeSession $ \_ -> runSessionT_ sEnv sessionHandler @@ -280,10 +280,10 @@ => (rpkt -> m Bool) -> SessionT u nid k rpkt tp m () -> NodeT u nid k rpkt tp m () startNodeT_ preprocess sessionHandler = do sess <- runCheckSessionState - void . runMaybeT . forever $ do + (`runContT` pure) $ callCC $ \exit -> forever $ do alive <- lift nodeState if alive then lift $ tryMainLoop preprocess sessionHandler - else mzero + else exit () cancel sess doFeedError @@ -356,7 +356,7 @@ to <- isTimeout when to $ do feed Nothing - HM.delete sessList (sessionId sessEnv) + HM.delete (sessionId sessEnv) sessList getSessionSize :: MonadIO m => NodeEnv u nid k rpkt -> m Int getSessionSize NodeEnv {..} = HM.size sessionList diff --git a/src/Metro/Server.hs b/src/Metro/Server.hs --- a/src/Metro/Server.hs +++ b/src/Metro/Server.hs @@ -31,22 +31,21 @@ , handleConn ) where -import Control.Monad (forM_, forever, mzero, unless, - void, when) +import Control.Monad (forM_, forever, unless, void, when) +import Control.Monad.Cont (callCC, runContT) import Control.Monad.Reader.Class (MonadReader (ask), asks) import Control.Monad.Trans.Class (MonadTrans, lift) -import Control.Monad.Trans.Maybe (runMaybeT) import Control.Monad.Trans.Reader (ReaderT (..), runReaderT) import Data.Either (isLeft) import Data.Hashable +import Data.IOHashMap (IOHashMap) +import qualified Data.IOHashMap as HM (delete, elems, empty) +import qualified Data.IOHashMap.STM as HMS (insert, lookup) import Data.Int (Int64) import Metro.Class (GetPacketId, RecvPacket, Servable (..), Transport, TransportConfig) import Metro.Conn hiding (close) -import Metro.IOHashMap (IOHashMap, newIOHashMap) -import qualified Metro.IOHashMap as HM (delete, elems, insertSTM, - lookupSTM) import Metro.Node (NodeEnv1, NodeMode (..), SessionMode (..), getNodeId, getTimer, initEnv1, runNodeT1, @@ -104,7 +103,7 @@ initServerEnv sc gen mapTransport prepare = do serveServ <- newServer sc serveState <- newTVarIO True - nodeEnvList <- newIOHashMap + nodeEnvList <- HM.empty onNodeLeave <- newTVarIO Nothing keepalive <- newTVarIO 0 defSessTout <- newTVarIO 300 @@ -149,11 +148,11 @@ name <- asks serveName liftIO $ infoM "Metro.Server" $ name ++ "Server started" state <- asks serveState - void . runMaybeT . forever $ do + (`runContT` pure) $ callCC $ \exit -> forever $ do e <- lift $ tryServeOnce preprocess sess - when (isLeft e) mzero + when (isLeft e) $ exit () alive <- readTVarIO state - unless alive mzero + unless alive $ exit () liftIO $ infoM "Metro.Server" $ name ++ "Server closed" tryServeOnce @@ -218,8 +217,8 @@ . Node.setDefaultSessionTimeout defSessTout) connEnv uEnv nid gen env1 <- atomically $ do - v <- HM.lookupSTM nodeEnvList nid - HM.insertSTM nodeEnvList nid env0 + v <- HMS.lookup nid nodeEnvList + HMS.insert nid env0 nodeEnvList pure v mapM_ (`runNodeT1` stopNodeT) env1 @@ -280,7 +279,7 @@ when (now > expiredAt) $ do nid <- getNodeId stopNodeT - HM.delete ref nid + HM.delete nid ref serverEnv :: Monad m => ServerT serv u nid k rpkt tp m (ServerEnv serv u nid k rpkt tp) serverEnv = ask