box-socket 0.1.1 → 0.1.2
raw patch · 5 files changed
+151/−124 lines, 5 filesdep ~boxdep ~bytestringdep ~concurrency
Dependency ranges changed: box, bytestring, concurrency, doctest, exceptions, generic-lens, lens, network, network-simple, numhask, optparse-generic, websockets
Files
- app/box-socket.hs +1/−2
- box-socket.cabal +18/−34
- src/Box/Socket.hs +59/−40
- src/Box/TCP.hs +70/−47
- test/test.hs +3/−1
app/box-socket.hs view
@@ -81,8 +81,7 @@ runClient defaultSocketConfig (\conn -> (\b -> clientApp b conn) <$.>- (Box <$>- pure c <*>+ (Box c <$> fromListE (xs <> ["q"]))) r
box-socket.cabal view
@@ -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
src/Box/Socket.hs view
@@ -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
src/Box/TCP.hs view
@@ -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!"]
test/test.hs view
@@ -8,5 +8,7 @@ main :: IO () main = doctest- [ "app/box-socket.hs"+ [ "app/box-socket.hs",+ "src/Box/Socket.hs",+ "src/Box/TCP.hs" ]