packages feed

box-socket (empty) → 0.0.1

raw patch · 4 files changed

+372/−0 lines, 4 filesdep +basedep +boxdep +box-socket

Dependencies added: base, box, box-socket, concurrency, doctest, exceptions, generic-lens, lens, numhask, optparse-generic, websockets

Files

+ app/box-socket.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}++{-++It's a box. It's a socket.++-}++module Main where++import Box+import Box.Socket+import Control.Lens hiding (Wrapped, Unwrapped)+import Data.Generics.Labels ()+import NumHask.Prelude hiding (STM, bracket)+import Options.Generic+import Control.Concurrent.Classy.Async as C++data SocketType = Client | Responder | TestRun deriving (Eq, Read, Show, Generic)++instance ParseField SocketType++instance ParseRecord SocketType++instance ParseFields SocketType++data Opts w+  = Opts+      { apptype :: w ::: SocketType <?> "type of websocket app"+      }+  deriving (Generic)++instance ParseRecord (Opts Wrapped)++main :: IO ()+main = do+  o :: Opts Unwrapped <- unwrapRecord "example websocket apps"+  r :: Text <- case apptype o of+    Client -> show <$> clientIO+    Responder -> show <$> q' serverIO+    TestRun -> show <$> testRun+  putStrLn r++-- * older stuff+serverIO :: IO ()+serverIO = runServer defaultSocketConfig+  (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x=="q")))++clientIO :: IO ()+clientIO =+  (runClient defaultSocketConfig . clientApp)+  (Box (contramap show toStdout) fromStdin)++q' :: IO a -> IO (Either () a)+q' f = C.race (cancelQ fromStdin) f++cancelQ :: Emitter IO Text -> IO ()+cancelQ e = do+  e' <- emit e+  case e' of+    Just "q" -> pure ()+    _ -> do+      putStrLn ("nothing happens" :: Text)+      cancelQ e++-- | test of clientApp via a cRef committer and a canned list of Text+tClient :: [Text] -> IO [Either Text Text]+tClient xs = do+  (c,r) <- cRef+  runClient defaultSocketConfig+    (\conn ->+       (\b -> clientApp b conn) <$.>+       (Box <$>+        pure c <*>+        fromListE (xs <> ["q"])))+  r++tClientIO :: [Text] -> IO ()+tClientIO xs =+  (runClient defaultSocketConfig . clientApp) <$.>+  (Box (contramap show toStdout) <$> (fromListE (xs <> ["q"])))++-- | main test run of client-server functionality+-- the code starts a server in a thread, starts the client in the main thread, and cancels the server on completion.+-- >>> testRun+-- [Left "receiver: received: echo:1",Right "echo:1",Left "receiver: received: echo:2",Right "echo:2",Left "receiver: received: echo:3",Right "echo:3",Left "receiver: received: close: 1000 \"received close signal: responder closed.\""]+testRun :: IO [Either Text Text]+testRun = do+  a <- C.async (runServer defaultSocketConfig (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x=="q"))))+  sleep 0.1+  r <- tClient (show <$> [1..3::Int])+  C.cancel a+  pure r+
+ box-socket.cabal view
@@ -0,0 +1,92 @@+cabal-version: 2.4+name:          box-socket+version:       0.0.1+synopsis: See readme.md+description: See readme.md for description.+category: project+author: Tony Day+maintainer: tonyday567@gmail.com+copyright: Tony Day (c) AfterTimes+license: BSD-3-Clause+homepage: https://github.com/tonyday567/box-socket#readme+bug-reports: https://github.com/tonyday567/box-socket/issues+build-type: Simple+source-repository head+  type: git+  location: https://github.com/tonyday567/box-socket++library+  exposed-modules:+    Box.Socket+  hs-source-dirs:+    src+  build-depends:+    base >= 4.12 && <5,+    box >= 0.5,+    concurrency >= 1.11,+    exceptions >= 0.10,+    generic-lens >= 1.1.0 && < 3.0,+    lens >= 4.17.1 && < 4.20,+    numhask >= 0.6,+    websockets >= 0.12,+  default-language: Haskell2010+  default-extensions:+    NegativeLiterals+    NoImplicitPrelude+    OverloadedStrings+    UnicodeSyntax+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints++executable box-socket+  main-is: box-socket.hs+  hs-source-dirs: app+  build-depends:+    base >= 4.7 && < 5,+    box,+    box-socket,+    concurrency >= 1.11,+    generic-lens >= 2.0,+    lens >= 4.19,+    numhask >= 0.6,+    optparse-generic >= 1.3,+  default-language: Haskell2010+  default-extensions:+    NegativeLiterals+    NoImplicitPrelude+    OverloadedStrings+    UnicodeSyntax+  ghc-options:+    -funbox-strict-fields+    -fforce-recomp+    -threaded+    -rtsopts+    -with-rtsopts=-N++test-suite test+  type: exitcode-stdio-1.0+  main-is: test.hs+  hs-source-dirs:+    test+  build-depends:+    base >=4.7 && <5,+    box-socket,+    doctest >= 0.16,+    numhask >= 0.6,+  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
@@ -0,0 +1,163 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}++module Box.Socket+  ( SocketConfig(..),+    defaultSocketConfig,+    runClient,+    runServer,+    connect,+    clientApp,+    responderApp,+    serverApp,+    receiver',+    receiver,+    sender,+    responder,+  )+where++import qualified Network.WebSockets as WS+import Box+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++data SocketConfig+  = SocketConfig+      { host :: Text,+        port :: Int,+        path :: Text+      }+  deriving (Show, Eq, Generic)++defaultSocketConfig :: SocketConfig+defaultSocketConfig = SocketConfig "127.0.0.1" 9160 "/"++runClient :: (MonadIO m) => SocketConfig -> WS.ClientApp () -> m ()+runClient c app = liftIO $ WS.runClient (unpack $ c ^. #host) (c ^. #port) (unpack $ c ^. #path) app++runServer :: (MonadIO m) => SocketConfig -> WS.ServerApp -> m ()+runServer c app = liftIO $ WS.runServer (unpack $ c ^. #host) (c ^. #port) app++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))++clientApp :: (MonadIO m, MonadConc m) =>+  Box m (Either Text Text) Text ->+  WS.Connection ->+  m ()+clientApp (Box c e) conn =+  void $+    C.race+      (receiver' c conn)+      (sender (Box mempty e) conn)++responderApp ::+  (Text -> Either Text Text) ->+  WS.PendingConnection ->+  IO ()+responderApp f p = with (connect p) (responder f mempty)++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))++-- | default websocket receiver+-- Lefts are info/debug+receiver' :: (MonadIO m) =>+  Committer m (Either Text Text) ->+  WS.Connection ->+  m Bool+receiver' c conn = go+  where+    go = do+      msg <- liftIO $ WS.receive conn+      case msg of+        WS.ControlMessage (WS.Close w b) ->+          commit+            c+            ( Left+                ( "receiver: received: close: " <> show w <> " " <> show b+                )+            )+        WS.ControlMessage _ -> go+        WS.DataMessage _ _ _ msg' -> do+          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) =>+  Committer m Text ->+  WS.Connection ->+  m ()+receiver c conn = go+  where+    go = do+      msg <- liftIO $ WS.receive conn+      case msg of+        WS.ControlMessage (WS.Close _ _) -> pure ()+        WS.ControlMessage _ -> go+        WS.DataMessage _ _ _ msg' -> commit c (WS.fromDataMessage msg') >> go++-- | default websocket sender+sender ::+  (MonadIO m, WS.WebSocketsData a, Show a) =>+  Box m Text a ->+  WS.Connection ->+  m ()+sender (Box c e) conn = forever $ do+  msg <- emit e+  case msg of+    Nothing -> pure ()+    Just msg' -> do+      commit c $ "sender: sending: " <> (show msg' :: Text)+      liftIO $ WS.sendTextData conn msg'++-- | a receiver that responds based on received Text.+-- lefts are quit signals. Rights are response text.+responder :: (MonadIO m) =>+  (Text -> Either Text Text) ->+  Committer m Text ->+  WS.Connection ->+  m ()+responder f c conn = go+  where+    go = do+      msg <- liftIO $ WS.receive conn+      case msg of+        WS.ControlMessage (WS.Close _ _) -> do+          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+            Left _ -> do+              commit c "responder: sender initiated close"+              liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text)+            Right r -> do+              commit c ("responder: sending" <> r)+              liftIO $ WS.sendTextData conn r+              go
+ test/test.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++module Main where++import NumHask.Prelude+import Test.DocTest++main :: IO ()+main = doctest+  [ "app/box-socket.hs"+  ]