diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright 2018 Yuji Yamamoto + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +# wss-client + +A-little-higher-level WebSocket client library. +Thanks to [http-client](https://hackage.haskell.org/package/http-client) and [http-client-tls](https://hackage.haskell.org/package/http-client-tls), this package supports `HTTP_PROXY` environment variable and TLS. + +## TODO + +- Support non-TLS connection via an HTTP proxy server (I have to modify the [websockets](https://hackage.haskell.org/package/websockets) package to do that). +- Add APIs to modify config of both http-client and websockets. +- Test with a mock server. + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/sample.hs b/app/sample.hs new file mode 100644 --- /dev/null +++ b/app/sample.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +-- | Sample application of wss-client. +-- A simple command like wscat. + + +import Control.Monad (forever, unless) +import Control.Concurrent (forkIO, killThread) +import qualified Data.ByteString.Char8 as B +import System.Environment (getArgs) +import qualified Network.WebSockets.Client as WS + + +main :: IO () +main = do + url <- head <$> getArgs + WS.withClient url $ \conn -> do + tid <- forkIO $ forever $ do + msg <- WS.receiveData conn + B.putStrLn msg + + let loop = do + line <- B.getLine + unless (B.null line || line == "\r") + $ WS.sendTextData conn line + >> loop + + loop + WS.sendClose conn $ B.pack "Bye!" + killThread tid diff --git a/src/Network/WebSockets/Client.hs b/src/Network/WebSockets/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Client.hs @@ -0,0 +1,122 @@ +-- | A-little-bit-higher-level WebSocket client library. +-- +-- Thanks to [http-client](https://hackage.haskell.org/package/http-client) and [http-client-tls](https://hackage.haskell.org/package/http-client-tls), functions in this module support @HTTP_PROXY@ environment variable and TLS. +-- +-- __NOTE__: Currently, non-TLS connection via an HTTP proxy server +-- is NOT supported. + +module Network.WebSockets.Client + ( withClient + + -- * Re-export from Network.WebSockets + , WS.Connection + + -- ** Sending and receiving messages + , WS.receive + , WS.receiveDataMessage + , WS.receiveData + , WS.send + , WS.sendDataMessage + , WS.sendDataMessages + , WS.sendTextData + , WS.sendTextDatas + , WS.sendBinaryData + , WS.sendBinaryDatas + , WS.sendClose + , WS.sendCloseCode + , WS.sendPing + + -- ** WebSocket message types + , WS.Message (..) + , WS.ControlMessage (..) + , WS.DataMessage (..) + , WS.WebSocketsData (..) + + -- ** Exceptions + , WS.HandshakeException (..) + , WS.ConnectionException (..) + + -- ** Utilities + , WS.forkPingThread + ) where + + +import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Network.HTTP.Client as Http +import qualified Network.HTTP.Client.Internal as Http +import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Network.WebSockets as WS +import qualified Network.WebSockets.Stream as WS +import Network.URI (parseURI, URI(..), URIAuth(..)) + +-- | The main entrypoint to connect by the WebSocket protocol. +-- This function automatically closes the created connection +-- after exiting the action. +-- +-- If @HTTP_PROXY@ environment variable is set, +-- The connection is automatically made via the HTTP proxy server +-- specified by the variable. +-- +-- __NOTE__: Currently, non-TLS connection via an HTTP proxy server +-- is NOT supported. +withClient + :: String -- ^ Endpoint URL (e.g. wss:\/\/example.com\/path). + -> (WS.Connection -> IO a) -- ^ Action using the 'WS.Connection' + -> IO a +withClient url action = do + man <- Http.newManager tlsManagerSettings + withWsClientFromManager man url action + + +withWsClientFromManager + :: Http.Manager -> String -> (WS.Connection -> IO a) -> IO a +withWsClientFromManager man rawUrl action = do + (isSecure, host, path) <- parseWsUrl rawUrl + + let httpUrl = (if isSecure then "https://" else "http://") ++ host ++ path + req <- Http.parseRequest $ "GET " ++ httpUrl + + Http.withConnection req man $ \httpConn -> do + E.bracket + ( do + let r = do + bs <- Http.connectionRead httpConn + return $ if BS.null bs then Nothing else Just bs + + w = maybe (Http.connectionClose httpConn) + (Http.connectionWrite httpConn . BSL.toStrict) + WS.makeStream r w + ) + WS.close + ( \stream -> do + -- TODO: configure WS.ConnectionOptions + WS.runClientWithStream stream + host + path + WS.defaultConnectionOptions + [] + action + ) + + +parseWsUrl :: String -> IO (Bool, String, String) +parseWsUrl raw = do + uri <- noteInvalidUrl "Invalid URL given" $ parseURI raw + auth <- noteInvalidUrl "No authroity specified" $ uriAuthority uri + host <- dieWhenEmpty "No host specified" $ uriRegName auth + let wss = "wss:" + scheme' = uriScheme uri + scheme = if null scheme' then wss else scheme' + isSecure = scheme == wss + path = uriPath uri ++ uriQuery uri ++ uriFragment uri + return (isSecure, host, if null path then "/" else path) + where + noteInvalidUrl :: String -> Maybe a -> IO a + noteInvalidUrl msg = + maybe (E.throwIO $ Http.InvalidUrlException raw msg) return + + dieWhenEmpty :: String -> String -> IO String + dieWhenEmpty msg "" = E.throwIO $ Http.InvalidUrlException raw msg + dieWhenEmpty _ s = return s diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/wss-client.cabal b/wss-client.cabal new file mode 100644 --- /dev/null +++ b/wss-client.cabal @@ -0,0 +1,58 @@ +name: wss-client +version: 0.1.0.0 +synopsis: A-little-higher-level WebSockets client. +description: A-little-higher-level WebSockets client. Based on http-client and http-client-tls. +homepage: https://github.com/iij-ii/wss-client +license: Apache-2.0 +license-file: LICENSE +author: Yuji Yamamoto +maintainer: yuji-yamamoto@iij.ad.jp +copyright: 2018 Yuji Yamamoto +category: Network +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +flag build-sample + description: Build sample file. + default: False + manual: True + +library + hs-source-dirs: src + exposed-modules: Network.WebSockets.Client + build-depends: base >= 4.7 && < 5 + , bytestring + , http-client >= 0.5.13 + , http-client-tls + , network-uri + , websockets >= 0.12.0 && < 0.13 + default-language: Haskell2010 + +executable wss-client-sample + if flag(build-sample) + buildable: True + else + buildable: False + hs-source-dirs: app + main-is: sample.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , wss-client + , bytestring + default-language: Haskell2010 + +test-suite wss-client-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , wss-client + , hspec + , QuickCheck + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/iij-ii/wss-client