add ReaderT, unliftio

package.yaml

@@ -13,13 +13,16 @@ extra-source-files:
 
 dependencies:
   - base >= 4.7 && < 5
-  - async
+  # - async
   - bytestring
   - containers
+  - mtl
   - network
   - polysemy
   - singletons
   - stm
+  - unliftio-core
+  - unliftio
 
 executables:
   simplex-messaging:

src/EnvStm.hs

@@ -1,17 +1,18 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
-module EnvStm where
+module EnvSTM where
 
 import Control.Concurrent.STM
 import qualified Data.Map as M
 import qualified Data.Set as S
+import Network.Socket (ServiceName)
 import Store
 import System.IO
 import Transmission
 
 data Env = Env
-  { port :: String,
+  { tcpPort :: ServiceName,
     server :: TVar Server,
     connStore :: TVar ConnStoreData
   }
@@ -30,8 +31,13 @@ data Client = Client
 newServer :: STM (TVar Server)
 newServer = newTVar $ Server {clients = S.empty, connections = M.empty}
 
+newClient :: Handle -> STM Client
+newClient h = do
+  c <- newTChan
+  return Client {handle = h, connections = S.empty, channel = c}
+
 newEnv :: String -> STM Env
-newEnv port = do
+newEnv tcpPort = do
   srv <- newServer
   st <- newConnStore
-  return Env {port, server = srv, connStore = st}
+  return Env {tcpPort, server = srv, connStore = st}

src/Main.hs

@@ -5,65 +5,54 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 
 module Main where
 
-import Control.Concurrent
-import Control.Concurrent.Async
-import Control.Concurrent.STM
-import qualified Control.Exception as E
 import Control.Monad
-import Data.Function ((&))
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Set (Set)
-import qualified Data.Set as S
-import EnvStm
+import Control.Monad.IO.Unlift
+import Control.Monad.Reader
+import EnvSTM
 import Network.Socket
-import Polysemy
-import Polysemy.Embed
-import Polysemy.Resource
+-- import Polysemy
 import Store
-import System.IO
 import Transmission
 import Transport
+import UnliftIO.Async
+import UnliftIO.Concurrent
+import qualified UnliftIO.Exception as E
+import UnliftIO.IO
+import UnliftIO.STM
 
-newClient :: Handle -> IO Client
-newClient h = do
-  c <- newTChanIO @SomeSigned
-  return Client {handle = h, connections = S.empty, channel = c}
+port :: ServiceName
+port = "5223"
 
 main :: IO ()
 main = do
-  server <- atomically newServer
-  putStrLn $ "Listening on port " ++ port'
-  runTCPServer port' $ runClient server
+  env <- atomically $ newEnv port
+  putStrLn $ "Listening on port " ++ port
+  runReaderT (runTCPServer runClient) env
 
-port' :: String
-port' = "5223"
-
-runTCPServer :: ServiceName -> (Handle -> IO ()) -> IO ()
-runTCPServer port server =
-  E.bracket (startTCPServer port) close $ \sock -> forever $ do
+runTCPServer :: (MonadReader Env m, MonadUnliftIO m) => (Handle -> m ()) -> m ()
+runTCPServer server =
+  E.bracket startTCPServer (liftIO . close) $ \sock -> forever $ do
     h <- acceptTCPConn sock
-    hPutStrLn h "Welcome\r"
+    putLn h "Welcome"
     forkFinally (server h) (const $ hClose h)
 
-runClient :: TVar Server -> Handle -> IO ()
-runClient server h = do
-  c <- newClient h
-  void $ race (client server c) (receive c)
+runClient :: MonadUnliftIO m => Handle -> m ()
+runClient h = do
+  c <- atomically $ newClient h
+  void $ race (client c) (receive c)
 
-receive :: Client -> IO ()
+receive :: MonadIO m => Client -> m ()
 receive Client {handle, channel} = forever $ do
-  signature <- hGetLine handle
-  connId <- hGetLine handle
-  command <- hGetLine handle
+  signature <- getLn handle
+  connId <- getLn handle
+  command <- getLn handle
   cmdOrError <- parseVerifyTransmission signature connId command
   atomically $ writeTChan channel cmdOrError
 
-parseVerifyTransmission :: String -> String -> String -> IO SomeSigned
+parseVerifyTransmission :: Monad m => String -> String -> String -> m SomeSigned
 parseVerifyTransmission _ connId command = do
   return (Just connId, parseCommand command)
 
@@ -76,27 +65,26 @@ parseCommand command = case words command of
   ["SUSPEND"] -> rCmd SUSPEND
   ["DELETE"] -> rCmd DELETE
   ["SEND", msgBody] -> SomeCom SSender $ SEND msgBody
-  "CREATE" : _ -> error SYNTAX
-  "SUB" : _ -> error SYNTAX
-  "SECURE" : _ -> error SYNTAX
-  "DELMSG" : _ -> error SYNTAX
-  "SUSPEND" : _ -> error SYNTAX
-  "DELETE" : _ -> error SYNTAX
-  "SEND" : _ -> error SYNTAX
-  _ -> error CMD
+  "CREATE" : _ -> err SYNTAX
+  "SUB" : _ -> err SYNTAX
+  "SECURE" : _ -> err SYNTAX
+  "DELMSG" : _ -> err SYNTAX
+  "SUSPEND" : _ -> err SYNTAX
+  "DELETE" : _ -> err SYNTAX
+  "SEND" : _ -> err SYNTAX
+  _ -> err CMD
   where
     rCmd = SomeCom SRecipient
-    error t = SomeCom SBroker $ ERROR t
+    err t = SomeCom SBroker $ ERROR t
 
-client :: TVar Server -> Client -> IO ()
-client server Client {handle, channel} = loop
+client :: MonadIO m => Client -> m ()
+client Client {handle, channel} = loop
   where
-    loop = do
+    loop = forever $ do
       (_, cmdOrErr) <- atomically $ readTChan channel
       let response = case cmdOrErr of
             SomeCom SRecipient _ -> "OK"
             SomeCom SSender _ -> "OK"
             SomeCom SBroker (ERROR t) -> "ERROR " ++ show t
             _ -> "ERROR INTERNAL"
-      hPutStrLn handle response
-      loop
+      putLn handle response

src/Transport.hs

@@ -1,42 +1,28 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Transport where
 
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import EnvSTM
 import Network.Socket
-import Polysemy
-import Polysemy.Reader
-import Polysemy.Resource
 import System.IO
 
-data Transport h m a where
-  TReadLn :: h -> Transport h m String
-  TWriteLn :: h -> String -> Transport h m ()
+startTCPServer :: (MonadReader Env m, MonadIO m) => m Socket
+startTCPServer = do
+  port <- asks tcpPort
+  liftIO . withSocketsDo $ do
+    let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
+    addr <- head <$> getAddrInfo (Just hints) Nothing (Just port)
+    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+    setSocketOption sock ReuseAddr 1
+    withFdSocket sock setCloseOnExecIfNeeded
+    bind sock $ addrAddress addr
+    listen sock 1024
+    return sock
 
-makeSem ''Transport
-
-type TCPTransport = Transport Handle
-
-startTCPServer :: String -> IO Socket
-startTCPServer port = withSocketsDo $ do
-  let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
-  addr <- head <$> getAddrInfo (Just hints) Nothing (Just port)
-  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-  setSocketOption sock ReuseAddr 1
-  withFdSocket sock setCloseOnExecIfNeeded
-  bind sock $ addrAddress addr
-  listen sock 1024
-  return sock
-
-acceptTCPConn :: Socket -> IO Handle
-acceptTCPConn sock = do
+acceptTCPConn :: MonadIO m => Socket -> m Handle
+acceptTCPConn sock = liftIO $ do
   (conn, peer) <- accept sock
   putStrLn $ "Accepted connection from " ++ show peer
   h <- socketToHandle conn ReadWriteMode
@@ -45,7 +31,8 @@ acceptTCPConn sock = do
   hSetBuffering h LineBuffering
   return h
 
-runTCPTransportIO :: Member (Embed IO) r => Sem (TCPTransport ': r) a -> Sem r a
-runTCPTransportIO = interpret $ \case
-  TReadLn h -> embed $ hGetLine h
-  TWriteLn h str -> embed $ hPutStr h $ str ++ "\r\n"
+putLn :: MonadIO m => Handle -> String -> m ()
+putLn h = liftIO . hPutStrLn h
+
+getLn :: MonadIO m => Handle -> m String
+getLn = liftIO . hGetLine