diff --git a/app/box-socket.hs b/app/box-socket.hs --- a/app/box-socket.hs +++ b/app/box-socket.hs @@ -81,8 +81,7 @@ runClient defaultSocketConfig (\conn -> (\b -> clientApp b conn) <$.> - (Box <$> - pure c <*> + (Box c <$> fromListE (xs <> ["q"]))) r diff --git a/box-socket.cabal b/box-socket.cabal --- a/box-socket.cabal +++ b/box-socket.cabal @@ -1,8 +1,8 @@ cabal-version: 2.4 name: box-socket -version: 0.1.1 -synopsis: See readme.md -description: See readme.md for description. +version: 0.1.2 +synopsis: Box websockets +description: Websockets built with the box library. category: project author: Tony Day maintainer: tonyday567@gmail.com @@ -24,21 +24,16 @@ build-depends: base >= 4.12 && <5, box >= 0.6 && < 0.7, - concurrency >= 1.11, - exceptions >= 0.10, + bytestring >= 0.10 && < 0.11, + concurrency >= 1.11 && < 1.12, + exceptions >= 0.10 && < 0.11, generic-lens >= 1.1.0 && < 3.0, lens >= 4.17.1 && < 4.20, - network, - bytestring, - numhask >= 0.6, - websockets >= 0.12, - network-simple, + network >= 3.1 && < 3.2, + network-simple >= 0.4 && < 0.5, + numhask >= 0.7 && < 0.8, + websockets >= 0.12 && < 0.13, default-language: Haskell2010 - default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax ghc-options: -Wall -Wcompat @@ -51,19 +46,14 @@ hs-source-dirs: app build-depends: base >= 4.7 && < 5, - box, + box >= 0.6 && < 0.7, box-socket, - concurrency >= 1.11, - generic-lens >= 2.0, - lens >= 4.19, - numhask >= 0.6, - optparse-generic >= 1.3, + concurrency >= 1.11 && < 1.12, + generic-lens >= 2.0 && < 3, + lens >= 4.19 && < 4.20, + numhask >= 0.7 && < 0.8, + optparse-generic >= 1.3 && < 1.4, default-language: Haskell2010 - default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax ghc-options: -funbox-strict-fields -fforce-recomp @@ -79,18 +69,12 @@ build-depends: base >=4.7 && <5, box-socket, - doctest >= 0.16, - numhask >= 0.6, + doctest >= 0.16 && < 0.18, + numhask >= 0.7 && < 0.8, default-language: Haskell2010 - default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints - -funbox-strict-fields diff --git a/src/Box/Socket.hs b/src/Box/Socket.hs --- a/src/Box/Socket.hs +++ b/src/Box/Socket.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} +-- | Websocket components built with 'Box'es. module Box.Socket - ( SocketConfig(..), + ( SocketConfig (..), defaultSocketConfig, runClient, runServer, @@ -21,43 +21,53 @@ ) where -import qualified Network.WebSockets as WS import Box +import qualified Control.Concurrent.Classy.Async as C import Control.Lens -import NumHask.Prelude hiding (bracket) -import Data.Generics.Labels () -import Control.Monad.Conc.Class as C import Control.Monad.Catch -import qualified Control.Concurrent.Classy.Async as C +import Control.Monad.Conc.Class as C +import Data.Generics.Labels () +import qualified Network.WebSockets as WS +import NumHask.Prelude hiding (bracket) -data SocketConfig - = SocketConfig - { host :: Text, - port :: Int, - path :: Text - } +-- | Socket configuration +-- +-- >>> defaultSocketConfig +-- SocketConfig {host = "127.0.0.1", port = 9160, path = "/"} +data SocketConfig = SocketConfig + { host :: Text, + port :: Int, + path :: Text + } deriving (Show, Eq, Generic) +-- | official default defaultSocketConfig :: SocketConfig defaultSocketConfig = SocketConfig "127.0.0.1" 9160 "/" +-- | Run a client app. runClient :: (MonadIO m) => SocketConfig -> WS.ClientApp () -> m () runClient c app = liftIO $ WS.runClient (unpack $ c ^. #host) (c ^. #port) (unpack $ c ^. #path) app +-- | Run a server app. runServer :: (MonadIO m) => SocketConfig -> WS.ServerApp -> m () runServer c app = liftIO $ WS.runServer (unpack $ c ^. #host) (c ^. #port) app +-- | Connection continuation. connect :: (MonadIO m, MonadConc m) => WS.PendingConnection -> Cont m WS.Connection connect p = Cont $ \action -> - bracket - (liftIO $ WS.acceptRequest p) - (\conn -> liftIO $ WS.sendClose conn ("Bye from connect!" :: Text)) - (\conn -> - C.withAsync - (liftIO $ forever $ WS.sendPing conn ("ping" :: ByteString) >> sleep 30) - (\_ -> action conn)) + bracket + (liftIO $ WS.acceptRequest p) + (\conn -> liftIO $ WS.sendClose conn ("Bye from connect!" :: Text)) + ( \conn -> + C.withAsync + (liftIO $ forever $ WS.sendPing conn ("ping" :: ByteString) >> sleep 30) + (\_ -> action conn) + ) -clientApp :: (MonadIO m, MonadConc m) => +-- | A simple client app for a box with Left debug messages. +clientApp :: + (MonadIO m, MonadConc m) => Box m (Either Text Text) Text -> WS.Connection -> m () @@ -67,25 +77,33 @@ (receiver' c conn) (sender (Box mempty e) conn) +-- | Canned response function. responderApp :: (Text -> Either Text Text) -> WS.PendingConnection -> IO () responderApp f p = with (connect p) (responder f mempty) +-- | Standard server app for a box. serverApp :: (MonadConc m, MonadIO m) => Box m Text Text -> WS.PendingConnection -> m () -serverApp (Box c e) p = void $ with (connect p) - (\conn -> C.race - (receiver c conn) - (sender (Box mempty e) conn)) +serverApp (Box c e) p = + void $ + with + (connect p) + ( \conn -> + C.race + (receiver c conn) + (sender (Box mempty e) conn) + ) --- | default websocket receiver +-- | default websocket receiver with messages -- Lefts are info/debug -receiver' :: (MonadIO m) => +receiver' :: + (MonadIO m) => Committer m (Either Text Text) -> WS.Connection -> m Bool @@ -103,13 +121,13 @@ ) WS.ControlMessage _ -> go WS.DataMessage _ _ _ msg' -> do - commit c $ Left $ "receiver: received: " <> (WS.fromDataMessage msg' :: Text) + _ <- commit c $ Left $ "receiver: received: " <> (WS.fromDataMessage msg' :: Text) _ <- commit c (Right (WS.fromDataMessage msg')) go --- | default websocket receiver --- Lefts are info/debug -receiver :: (MonadIO m) => +-- | Receiver that only commits. +receiver :: + (MonadIO m) => Committer m Text -> WS.Connection -> m () @@ -122,7 +140,7 @@ WS.ControlMessage _ -> go WS.DataMessage _ _ _ msg' -> commit c (WS.fromDataMessage msg') >> go --- | default websocket sender +-- | Sender that only emits. sender :: (MonadIO m, WS.WebSocketsData a, Show a) => Box m Text a -> @@ -133,12 +151,13 @@ case msg of Nothing -> pure () Just msg' -> do - commit c $ "sender: sending: " <> (show msg' :: Text) + _ <- commit c $ "sender: sending: " <> (show msg' :: Text) liftIO $ WS.sendTextData conn msg' --- | a receiver that responds based on received Text. +-- | A receiver that responds based on received Text. -- lefts are quit signals. Rights are response text. -responder :: (MonadIO m) => +responder :: + (MonadIO m) => (Text -> Either Text Text) -> Committer m Text -> WS.Connection -> @@ -149,15 +168,15 @@ msg <- liftIO $ WS.receive conn case msg of WS.ControlMessage (WS.Close _ _) -> do - commit c "responder: normal close" + _ <- commit c "responder: normal close" liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text) WS.ControlMessage _ -> go WS.DataMessage _ _ _ msg' -> do - case (f $ WS.fromDataMessage msg') of + case f $ WS.fromDataMessage msg' of Left _ -> do - commit c "responder: sender initiated close" + _ <- commit c "responder: sender initiated close" liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text) Right r -> do - commit c ("responder: sending" <> r) + _ <- commit c ("responder: sending" <> r) liftIO $ WS.sendTextData conn r go diff --git a/src/Box/TCP.hs b/src/Box/TCP.hs --- a/src/Box/TCP.hs +++ b/src/Box/TCP.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} +{-# OPTIONS_GHC -Wall #-} +-- | TCP Boxes. module Box.TCP - ( TCPConfig(..), + ( TCPConfig (..), defaultTCPConfig, - Env(..), - defaultVersion, + Env (..), new, close, tcpEmitter, @@ -18,37 +21,39 @@ testHarness, testResponder, testServerSender, - ) where + ) +where import Box -import NumHask.Prelude hiding (handle, check) -import Network.Simple.TCP import Control.Lens +import Network.Simple.TCP +import NumHask.Prelude hiding (check, handle) -data TCPConfig - = TCPConfig - { host :: Text, - port :: Text - } +-- | TCP configuration +-- +-- >>> defaultTCPConfig +-- TCPConfig {host = "127.0.0.1", port = "3566"} +data TCPConfig = TCPConfig + { host :: Text, + port :: Text + } deriving (Show, Eq, Generic) +-- | default defaultTCPConfig :: TCPConfig defaultTCPConfig = TCPConfig "127.0.0.1" "3566" --- ib 7496 --- | an active -data Env - = Env - { socket :: Socket, - sockaddr :: SockAddr, - ascreendump :: Maybe (Async ()), - afiledump :: Maybe (Async ()) - } - -defaultVersion :: Text -defaultVersion = "11" +-- | An active TCP environment +data Env = Env + { socket :: Socket, + sockaddr :: SockAddr, + -- | A screen dump thread + ascreendump :: Maybe (Async ()), + -- | A file dump thread + afiledump :: Maybe (Async ()) + } --- | Connects to a server +-- | Connects to a server with no screen or file dump. new :: -- | Configuration TCPConfig -> @@ -64,54 +69,73 @@ maybe (pure ()) cancel (ascreendump env) maybe (pure ()) cancel (afiledump env) +-- | Emits from a 'Socket' tcpEmitter :: Socket -> Emitter IO ByteString tcpEmitter s = Emitter $ recv s 2048 +-- | Commits to a 'Socket' tcpCommitter :: Socket -> Committer IO ByteString -tcpCommitter s = Committer $ \bs -> send s bs *> pure True +tcpCommitter s = Committer $ \bs -> send s bs $> True +-- | 'Box' connection for a 'Socket' tcpBox :: Socket -> Box IO ByteString ByteString tcpBox s = Box (tcpCommitter s) (tcpEmitter s) +-- | TCP server 'Box' tcpServer :: TCPConfig -> Box IO ByteString ByteString -> IO () tcpServer cfg (Box c e) = - serve HostAny (unpack $ port cfg) - (\(s,_) -> void $ do + serve + HostAny + (unpack $ port cfg) + ( \(s, _) -> + void $ race (glue (tcpCommitter s) e) - (glue c (tcpEmitter s))) + (glue c (tcpEmitter s)) + ) +-- | Response function. responder :: (ByteString -> IO ByteString) -> Box IO ByteString ByteString -> IO () responder f (Box c e) = - glue c (mapE (\bs -> Just <$> f bs) e) + glue c (mapE (fmap Just . f) e) --- A server that explicitly responds to client messages. +-- | A server that explicitly responds to client messages. tcpResponder :: TCPConfig -> (ByteString -> IO ByteString) -> IO () tcpResponder cfg f = - serve HostAny (unpack $ port cfg) - (\(s,_) -> responder f (Box (tcpCommitter s) (tcpEmitter s))) + serve + HostAny + (unpack $ port cfg) + (\(s, _) -> responder f (Box (tcpCommitter s) (tcpEmitter s))) +-- | A server independent of incoming messages. tcpSender :: TCPConfig -> Emitter IO ByteString -> IO () tcpSender cfg e = - serve HostAny (unpack $ port cfg) - (\(s,_) -> glue (tcpCommitter s) e) + serve + HostAny + (unpack $ port cfg) + (\(s, _) -> glue (tcpCommitter s) e) +-- | A TCP client connected to stdin tcpStdClient :: TCPConfig -> IO () tcpStdClient cfg = do (Env s _ _ _) <- new cfg - void $ concurrently - (glue o (tcpEmitter s)) - (glue (tcpCommitter s) i) + void $ + concurrently + (glue o (tcpEmitter s)) + (glue (tcpCommitter s) i) where o = contramap decodeUtf8 toStdout i = fmap encodeUtf8 fromStdin +-- | test harness wrapping an action with a "q" escape. testHarness :: IO () -> IO () testHarness io = - void $ race - io - (cancelQ fromStdin) + void $ + race + io + (cancelQ fromStdin) +-- | Cancel with a "q". cancelQ :: Emitter IO Text -> IO () cancelQ e = do e' <- emit e @@ -120,13 +144,12 @@ Just x -> putStrLn ("badly handled: " <> x) Nothing -> pure () +-- | @"echo: " <>@ Responder testResponder :: IO () testResponder = testHarness (tcpResponder defaultTCPConfig (pure . ("echo: " <>))) +-- | Test server. testServerSender :: IO () -testServerSender = testHarness $ - tcpSender defaultTCPConfig <$.> (fromListE ["hi!"]) - - - - +testServerSender = + testHarness $ + tcpSender defaultTCPConfig <$.> fromListE ["hi!"] diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -8,5 +8,7 @@ main :: IO () main = doctest - [ "app/box-socket.hs" + [ "app/box-socket.hs", + "src/Box/Socket.hs", + "src/Box/TCP.hs" ]