From 97e1e2f09c2c6e8ac5c7eb2637596dfceab3b788 Mon Sep 17 00:00:00 2001 From: firest Date: Wed, 13 Oct 2021 08:51:59 +0800 Subject: [PATCH] feat(TCP): enhanced TCP module --- lib/Data/Term.hm | 10 +- lib/Data/Timeout.hm | 6 ++ lib/Foreign.hm | 3 + lib/Foreign.hrl | 3 + lib/Network/Inet.hm | 25 ++++- lib/Network/TCP.erl | 34 ++++--- lib/Network/TCP.hm | 191 +++++++++++++++++++++++++++++++++++--- lib/System/File.hm | 20 ++++ lib/Unsafe/Coerce.erl | 21 +++++ lib/Unsafe/Coerce.hm | 18 ++++ tests/Test.hm | 2 + tests/Test/Network/TCP.hm | 60 ++++++++++++ 12 files changed, 361 insertions(+), 32 deletions(-) create mode 100644 lib/Unsafe/Coerce.erl create mode 100644 lib/Unsafe/Coerce.hm create mode 100644 tests/Test/Network/TCP.hm diff --git a/lib/Data/Term.hm b/lib/Data/Term.hm index 6b947d17..d7eade26 100644 --- a/lib/Data/Term.hm +++ b/lib/Data/Term.hm @@ -14,8 +14,14 @@ ----------------------------------------------------------------------------- module Data.Term where +import Unsafe.Coerce (unsafeCoerce) + -- | A piece of data of any datatype is called a Term in Erlang. +-- we use Term as top type of Hamler foreign import data Term :: Type -class ToTerm a where - toTerm :: a -> Term +toTerm :: forall a. a -> Term +toTerm = unsafeCoerce + +fromTerm :: forall a. Term -> a +fromTerm = unsafeCoerce diff --git a/lib/Data/Timeout.hm b/lib/Data/Timeout.hm index 29d68042..56af60a7 100644 --- a/lib/Data/Timeout.hm +++ b/lib/Data/Timeout.hm @@ -21,10 +21,16 @@ import Data.Show (class Show, show) import Data.Read (class Read, read) import Data.Function (error) import Data.List ((++)) +import Foreign (class IsFFI) +import Data.Term (Term, toTerm) -- | The Erlang Timeout. data Timeout = Infinity | Timeout Integer +instance IsFFI Timeout Term where + toFFI Infinity = toTerm :infinity + toFFI (Timeout num) = toTerm num + instance Show Timeout where show Infinity = "Infinity" show (Timeout x) = "Timeout " ++ show x diff --git a/lib/Foreign.hm b/lib/Foreign.hm index 92c7fc7f..4a36ad47 100644 --- a/lib/Foreign.hm +++ b/lib/Foreign.hm @@ -41,3 +41,6 @@ foreign import ffiIO4 :: forall a b c d e. Mod -> Fun -> a -> b -> c -> d -> IO foreign import ffiIO5 :: forall a b c d e f. Mod -> Fun -> a -> b -> c -> d -> e IO f foreign import ffiIO6 :: forall a b c d e f g. Mod -> Fun -> a -> b -> c -> d -> e -> f -> IO g foreign import ffiIO7 :: forall a b c d e f g h. Mod -> Fun -> a -> b -> c -> d -> e -> f -> g -> IO h + +class IsFFI a b | a -> b where + toFFI :: a -> b \ No newline at end of file diff --git a/lib/Foreign.hrl b/lib/Foreign.hrl index 024f4648..25f7b6f6 100644 --- a/lib/Foreign.hrl +++ b/lib/Foreign.hrl @@ -21,6 +21,9 @@ -define(EvalIO(IO), 'Control.Monad':pureImpl(?RunIO(IO))). +-define(TOFFI(M, I, F), ('Foreign':toFFI(M:I()))(F)). +-define(TOFFIs(M, I, L), begin FFI = 'Foreign':toFFI(M:I()), [FFI(F) || F <- L] end). + -include("./Foreign/Maybe.hrl"). -endif. diff --git a/lib/Network/Inet.hm b/lib/Network/Inet.hm index 115788c1..8372a148 100644 --- a/lib/Network/Inet.hm +++ b/lib/Network/Inet.hm @@ -17,7 +17,8 @@ module Network.Inet where import Control.Monad (IO) import Data.Int (UInt8, UInt16) import Data.Unit (Unit) -import Foreign (ffiIO1) +import Foreign (ffiIO1, class IsFFI) +import Data.Term(toTerm, Term) -- | Host name type Hostname = String @@ -30,6 +31,10 @@ data IpAddress = Ip4Address (UInt8, UInt8, UInt8, UInt8) | Ip6Address (UInt16, UInt16, UInt16, UInt16, UInt16, UInt16, UInt16, UInt16) +instance IsFFI IpAddress Term where + toFFI (Ip4Address addr) = toTerm addr + toFFI (Ip6Address addr) = toTerm addr + data StatOption = RecvCnt | RecvMax @@ -42,6 +47,24 @@ data StatOption | SendOct | SendPend +data Family + = Inet + | Inet6 + | Local + +instance IsFFI Family Atom where + toFFI Inet = :inet + toFFI Inet6 = :inet6 + toFFI Local = :local + +data Backend + = InetBackend + | SocketBackend + +instance IsFFI Backend Atom where + toFFI InetBackend = :inet + toFFI SocketBackend = :socket + -- | The inet Socket. foreign import data Socket :: Type diff --git a/lib/Network/TCP.erl b/lib/Network/TCP.erl index d2153a44..3e207b12 100644 --- a/lib/Network/TCP.erl +++ b/lib/Network/TCP.erl @@ -21,38 +21,44 @@ , connect/3 , connectTimeout/4 , listen/2 - , recv/2 + , recv/3 , recvTimeout/3 - , send/2 + , send/3 , shutdown/2 ]). +-define(HMod, 'Network.TCP'). + accept(LSocket) -> - ?IO(return(gen_tcp:accept(LSocket))). + ?IO(return(gen_tcp:accept(LSocket))). acceptTimeout(LSocket, Timeout) -> - ?IO(return(gen_tcp:accept(LSocket, Timeout))). + ?IO(return(gen_tcp:accept(LSocket, Timeout))). connect(Address, Port, Options) -> - ?IO(return(gen_tcp:connect(unwrap(Address), Port, Options))). + Opts = ?TOFFIs(?HMod, isffiTcpOptionTerm, Options), + ?IO(return(gen_tcp:connect(unwrap(Address), Port, Opts))). connectTimeout(Address, Port, Options, Timeout) -> - ?IO(return(gen_tcp:connect(unwrap(Address), Port, Options, Timeout))). + Opts = ?TOFFIs(?HMod, isffiTcpOptionTerm, Options), + ?IO(return(gen_tcp:connect(unwrap(Address), Port, Opts, Timeout))). listen(Port, Options) -> - ?IO(return(gen_tcp:listen(Port, Options))). + Opts = ?TOFFIs(?HMod, isffiListenOptionTerm, Options), + ?IO(return(gen_tcp:listen(Port, Opts))). -recv(Socket, Length) -> - ?IO(return(gen_tcp:recv(Socket, Length))). +recv(_, Socket, Length) -> + ?IO(return(gen_tcp:recv(Socket, Length))). recvTimeout(Socket, Length, Timeout) -> - ?IO(return(gen_tcp:recv(Socket, Length, Timeout))). + ?IO(return(gen_tcp:recv(Socket, Length, Timeout))). -send(Socket, Packet) -> - ?IO(return(gen_tcp:send(Socket, Packet))). +send(_, Socket, Packet) -> + ?IO(return(gen_tcp:send(Socket, Packet))). -shutdown(Socket, How) -> - ?IO(return(gen_tcp:shutdown(Socket, How))). +shutdown(Socket, Method) -> + How = ?TOFFI(?HMod, isffiShutdownMethodAtom, Method), + ?IO(return(gen_tcp:shutdown(Socket, How))). unwrap({'Ip4Address', Addr}) -> Addr; unwrap({'Ip6Address', Addr}) -> Addr. diff --git a/lib/Network/TCP.hm b/lib/Network/TCP.hm index 790aee15..720107c3 100644 --- a/lib/Network/TCP.hm +++ b/lib/Network/TCP.hm @@ -14,17 +14,178 @@ ----------------------------------------------------------------------------- module Network.TCP where -import Control.Monad (IO) -import Network.Inet (IpAddress, PortNumber, Socket) -import Data.Unit (Unit) -import Foreign (ffiIO1) +import Prelude +import Network.Inet (IpAddress, PortNumber, Socket, Family, Backend) +import Foreign (ffiIO1, class IsFFI, toFFI) +import Data.Int (Int16, UInt16) +import System.File (FileName) +import Data.Timeout (Timeout) +import Data.Term (Term, toTerm) type Length = Integer -type Timeout = Integer --- TODO: Fixme later -foreign import data Options :: Type -foreign import data Packet :: Type +data Option + = Active Bool + | ActiveN Int16 + | Buffer Integer + | DelaySend Bool + | Deliver Term + | DontRoute Bool + | ExitOnClose Bool + | Header Integer + | HighMsgqWatermark Integer + | HighWatermark Integer + | Keepalive Bool + | Linger Bool Integer + | LowMsgqWatermark Integer + | LowWatermark Integer + | Mode Mode + | NoDelay Bool + | Packet PacketHeader + | PacketSize Integer + | Priority Integer + | Raw Integer Integer Binary + | RecBuf Integer + | Reuseaddr Bool + | SendTimeout Timeout + | SendTimeoutClose Bool + | ShowEConnReset Bool + | SndBuf Integer + | TOS Integer + | TClass Integer + | TTL Integer + | RecvTOS Bool + | RecvTClass Bool + | RecvTTL Bool + | Ipv6Only Bool + | Backend Backend + +instance IsFFI Option Term where + toFFI (Active val) = toTerm (:active, val) + toFFI (ActiveN num) = toTerm (:active, num) + toFFI (Buffer num) = toTerm (:buffer, num) + toFFI (DelaySend val) = toTerm (:delay_send, val) + toFFI (Deliver term) = toTerm (:deliver, term) + toFFI (DontRoute val) = toTerm (:dontroute, val) + toFFI (ExitOnClose val) = toTerm (:exit_on_close, val) + toFFI (Header val) = toTerm val + toFFI (HighMsgqWatermark num) = toTerm (:high_msgq_watermark, num) + toFFI (HighWatermark num) = toTerm (:hight_watermark, num) + toFFI (Keepalive val) = toTerm (:keepalive, val) + toFFI (Linger val num) = toTerm (:linger, (val, num)) + toFFI (LowMsgqWatermark num) = toTerm (:low_msgq_watermark, num) + toFFI (LowWatermark num) = toTerm (:low_watermark, num) + toFFI (Mode m) = toTerm $ toFFI m + toFFI (NoDelay val) = toTerm (:nodelay, val) + toFFI (Packet p) = toTerm (:packet, toFFI p) + toFFI (PacketSize num) = toTerm (:packet_size, num) + toFFI (Priority num) = toTerm (:priority, num) + toFFI (Raw proto option val) = toTerm (:raw, proto, option, val) + toFFI (RecBuf num) = toTerm (:recbuf, num) + toFFI (Reuseaddr val) = toTerm (:reuseaddr, val) + toFFI (SendTimeout val) = toTerm (:send_timeout, toFFI val) + toFFI (SendTimeoutClose val) = toTerm (:send_timeout_close, val) + toFFI (ShowEConnReset val) = toTerm (:show_econnreset, val) + toFFI (SndBuf num) = toTerm (:sndbuf, num) + toFFI (TOS num) = toTerm (:tos, num) + toFFI (TClass num) = toTerm (:tclas, num) + toFFI (TTL num) = toTerm (:ttl, num) + toFFI (RecvTOS val) = toTerm (:recvtos, val) + toFFI (RecvTClass val) = toTerm (:recvtclass, val) + toFFI (RecvTTL val) = toTerm (:recvttl, val) + toFFI (Ipv6Only val) = toTerm (:ipv6_v6only, val) + toFFI (Backend backend) = toTerm $ toFFI backend + +data PacketHeader + = Header0 + | Header1 + | Header2 + | Header4 + | RawHeader + | Sunrm + | ASN1 + | CDR + | FCGI + | Line + | TPKT + | HTTP + | HTTPH + | HTTPBin + | HTTPHBin + +instance IsFFI PacketHeader Term where + toFFI Header0 = toTerm 0 + toFFI Header1 = toTerm 1 + toFFI Header2 = toTerm 2 + toFFI Header4 = toTerm 4 + toFFI RawHeader = toTerm :raw + toFFI Sunrm = toTerm :sumrm + toFFI ASN1 = toTerm :asn1 + toFFI CDR = toTerm :cdr + toFFI FCGI = toTerm :fcgi + toFFI Line = toTerm :line + toFFI TPKT = toTerm :tpkt + toFFI HTTP = toTerm :http + toFFI HTTPH = toTerm :httph + toFFI HTTPBin = toTerm :http_bin + toFFI HTTPHBin = toTerm :httph_bin + +data Mode + = List + | Binary + +instance IsFFI Mode Atom where + toFFI List = :list + toFFI Binary = :binary + +data TcpOption + = Option Option + | IP IpAddress + | FD Integer + | IfAddr IpAddress + | Family Family + | Port UInt16 + | TcpModule Atom + | Netns FileName + | BindToDevice Binary + +instance IsFFI TcpOption Term where + toFFI (Option opt) = toFFI opt + toFFI (IP addr) = toTerm (:ip, toFFI addr) + toFFI (FD num) = toTerm (:fd, num) + toFFI (IfAddr addr) = toTerm (:ifadr, toFFI addr) + toFFI (Family family) = toTerm (toFFI family) + toFFI (Port port) = toTerm (:port, port) + toFFI (TcpModule mod) = toTerm (:tcp_module, mod) + toFFI (Netns fileName) = toFFI fileName + toFFI (BindToDevice bin) = toTerm (:bind_to_device, bin) + +data ListenOption + = TcpOption TcpOption + | Backlog Integer + +instance IsFFI ListenOption Term where + toFFI (TcpOption opt) = toFFI opt + toFFI (Backlog num) = toTerm (:backlog, num) + +data ShutdownMethod + = Read + | Write + | ReadWrite + +instance IsFFI ShutdownMethod Atom where + toFFI Read = :read + toFFI Write = :write + toFFI ReadWrite = :read_write + +type ConnectOptions = [TcpOption] +type ListenOptions = [ListenOption] + +class IsPacket a + +instance IsPacket [Char] + +instance IsPacket Binary foreign import accept :: Socket -> IO (Socket) @@ -34,18 +195,18 @@ close :: Socket -> IO () close = ffiIO1 :gen_tcp :close foreign import connect - :: IpAddress -> PortNumber -> Options -> IO Socket + :: IpAddress -> PortNumber -> ConnectOptions -> IO Socket foreign import connectTimeout - :: IpAddress -> PortNumber -> Options -> Timeout -> IO Socket + :: IpAddress -> PortNumber -> ConnectOptions -> Timeout -> IO Socket -foreign import listen :: PortNumber -> Options -> IO Socket +foreign import listen :: PortNumber -> ListenOptions -> IO Socket -foreign import recv :: Socket -> Length -> IO Packet +foreign import recv :: forall a. IsPacket a => Socket -> Length -> IO a foreign import recvTimeout - :: Socket -> Length -> Timeout -> IO Packet + :: forall a. IsPacket a => Socket -> Length -> Timeout -> IO a -foreign import send :: Socket -> Packet -> IO () +foreign import send :: forall a. (IsPacket a) => Socket -> a -> IO () -foreign import shutdown :: Socket -> Atom -> IO () +foreign import shutdown :: Socket -> ShutdownMethod -> IO () \ No newline at end of file diff --git a/lib/System/File.hm b/lib/System/File.hm index 5cac71ec..9315c688 100644 --- a/lib/System/File.hm +++ b/lib/System/File.hm @@ -23,6 +23,9 @@ module System.File , close , sync , module System.IO.Types + , class IsFileName + , toFileName + , FileName ) where import Control.Monad (IO) @@ -33,6 +36,23 @@ import System.IO.Types , IOMode(..) , SeekMode(..) ) +import Unsafe.Coerce (unsafeCoerce) +import Foreign (class IsFFI) +import Data.Term (toTerm, Term) + +class IsFileName a where + toFileName :: a -> FileName + +instance IsFileName [Char] where + toFileName = unsafeCoerce + +instance IsFileName Binary where + toFileName = unsafeCoerce + +instance IsFFI FileName Term where + toFFI = toTerm + +foreign import data FileName :: Type foreign import open :: FilePath -> IOMode -> IO IODevice diff --git a/lib/Unsafe/Coerce.erl b/lib/Unsafe/Coerce.erl new file mode 100644 index 00000000..ddaec61e --- /dev/null +++ b/lib/Unsafe/Coerce.erl @@ -0,0 +1,21 @@ +%%--------------------------------------------------------------------------- +%% | +%% Module : TCP +%% Copyright : (c) 2020-2021 EMQ Technologies Co., Ltd. +%% License : BSD-style (see the LICENSE file) +%% +%% Maintainer : Feng Lee, feng@emqx.io +%% Yang M, yangm@emqx.io +%% firest, shuai.wen@emqx.io +%% Stability : experimental +%% Portability : portable +%% +%% The TCP FFI module. +%% +%%--------------------------------------------------------------------------- +-module('Coerce'). + +-export([unsafeCoerce/1]). + +unsafeCoerce(X) -> + X. diff --git a/lib/Unsafe/Coerce.hm b/lib/Unsafe/Coerce.hm new file mode 100644 index 00000000..65cf4c9b --- /dev/null +++ b/lib/Unsafe/Coerce.hm @@ -0,0 +1,18 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.File +-- Copyright : (c) 2020-2021 EMQ Technologies Co., Ltd. +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : Feng Lee, feng@emqx.io +-- Yang M, yangm@emqx.io +-- firest, shuai.wen@emqx.io +-- Stability : experimental +-- Portability : portable +-- +-- The Coerce module. +-- +----------------------------------------------------------------------------- +module Unsafe.Coerce (unsafeCoerce) where + +foreign import unsafeCoerce :: forall a b. a -> b \ No newline at end of file diff --git a/tests/Test.hm b/tests/Test.hm index 270ac474..bfaffd30 100644 --- a/tests/Test.hm +++ b/tests/Test.hm @@ -42,6 +42,7 @@ import Test.System.Error as Error import Test.Control.Process as Proc import Test.Database.ETS as ETS import Test.Network.UDP as UDP +import Test.Network.TCP as TCP import Test.Database.Mnesia as Mnesia import Test.System.IO as IO @@ -117,6 +118,7 @@ main = runTest $ TxG "lib" , TxG "Mnesia" [Mnesia.test] ], TxG "Network" [ TxG "UDP" [UDP.test] + , TxG "TCP" [TCP.test] ], TxG "Text" [ TxG "Parsec" [Parsec.test] , TxG "Json" [Json.test] diff --git a/tests/Test/Network/TCP.hm b/tests/Test/Network/TCP.hm new file mode 100644 index 00000000..d9424bc0 --- /dev/null +++ b/tests/Test/Network/TCP.hm @@ -0,0 +1,60 @@ +module Test.Network.TCP where + +import Prelude (IO, Unit, bind, discard, pure, spawn, unit, ($), (==), (>>=)) +import Network.TCP ( listen, ListenOption(..), accept, connect + , send, recv, close, Option(..), TcpOption(..), Mode(..), PacketHeader(..)) +import Test.QuickCheck (TestGroup(..), TestResult, quickCheck1) +import Network.Inet (IpAddress(..)) +import Control.Process (timerSleep) +import Data.Timeout (Timeout(..)) +--import Foreign + +echoSvr :: Integer -> IO () +echoSvr port = do + --ffiIO2 :io :format ">>>> start server ~n" [] + listenSock <- listen port [ TcpOption $ Option $ Active false + , TcpOption $ Option $ Mode List + , TcpOption $ Option $ Packet $ RawHeader + , Backlog 100 ] + sock <- accept listenSock + --ffiIO2 :io :format ">>>> accept socket ~p ~n" [sock] + recvLoop listenSock sock + where + recvLoop lisSock sock = do + packet <- recv sock 0 + --ffiIO2 :io :format ">>>> server received: ~ts ~n" [packet] + case packet of + "close" -> do + close sock + close lisSock + otherwise -> do + send sock packet + --ffiIO2 :io :format ">>>> server echo: ~ts ~n" [packet] + recvLoop lisSock sock + +start :: IO () +start = do + spawn $ echoSvr 8000 + timerSleep 100 + pure () + +client :: IO Boolean +client = do + --ffiIO2 :io :format ">>>> start client ~n" [] + sock <- connect (Ip4Address (127, 0, 0, 1)) 8000 + [ Option $ Active false + , Option $ Packet $ RawHeader + , Option $ Mode List + , Option $ SendTimeout $ Timeout 5000] + send sock "hello" + --ffiIO2 :io :format ">>>> client send hello ~n" [] + recvPacket <- recv sock 0 + --ffiIO2 :io :format ">>>> client received: ~ts ~n" [recvPacket] + send sock "close" + timerSleep 100 + close sock + pure $ recvPacket == "hello" + +test :: TestGroup (Integer -> IO TestResult) +test = Exe [ quickCheck1 "TCP: simple echo server" (start >>= \_ -> client) + ]