diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,13 @@ +Copyright 2021 Mission Valley Software LLC + +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/sockets-and-pipes.cabal b/sockets-and-pipes.cabal new file mode 100644 --- /dev/null +++ b/sockets-and-pipes.cabal @@ -0,0 +1,278 @@ +cabal-version: 2.0 +build-type: Simple + +name: sockets-and-pipes +version: 0.1 +synopsis: Support for the Sockets and Pipes book +category: HTTP, Network, Streaming, Text +license: Apache-2.0 +license-file: license.txt +author: Chris Martin, Julie Moronuki +maintainer: Joy of Haskell + +-- GHC 9.0 support is held back by the 'base' version; see comments below. +tested-with: GHC == 8.10.3, GHC == 8.8.4, GHC == 8.6.5 + +description: + This package contains some utilities that support /Sockets and Pipes/ + (available on ), + as well as re-exports from all the libraries mentioned in the book. + . + == Code in this package + . + Original contributions from this package: + . + * "SocketsAndPipes.Serve" + . + == Chapters + . + List of modules that make a significant appearance in each chapter: + . + +----+----------------------+----------------------------------+---------------------------------------+ + | | Chapter | Module | Purpose | + +====+======================+==================================+=======================================+ + | 1 | __Handles__ | "System.IO" | Writing to a file | + | | +----------------------------------+---------------------------------------+ + | | | "Control.Exception.Safe" | Using `bracket` to ensure | + | | | | the file handle is closed | + +----+----------------------+----------------------------------+---------------------------------------+ + | 2 | __Chunks__ | "Data.Text" | `Text` is a chunk of characters | + | | +----------------------------------+---------------------------------------+ + | | | "Data.Text.IO" | Reading and writing files using | + | | | | `Text` instead of `String` | + +----+----------------------+----------------------------------+---------------------------------------+ + | 3 | __Bytes__ | "Data.Word" | What a byte is | + | | +----------------------------------+---------------------------------------+ + | | | "Data.ByteString" | `ByteString` is a chunk of bytes | + | | +----------------------------------+---------------------------------------+ + | | | "Data.Text.Encoding" | Conversions between `ByteString` | + | | | | and `Text` | + | | +----------------------------------+---------------------------------------+ + | | | "Data.String" | How `ByteString` works with | + | | +----------------------------------+ `OverloadedStrings` | + | | | "Data.ByteString.Char8" | | + | | +----------------------------------+---------------------------------------+ + | | | "System.IO" | Putting `Handle`s into binary mode | + +----+----------------------+----------------------------------+---------------------------------------+ + | 4 | __Sockets__ | "Network.Socket" | Opening and closing sockets | + | | +----------------------------------+---------------------------------------+ + | | | "Network.Socket.ByteString" | Writing to and reading from sockets | + | | +----------------------------------+---------------------------------------+ + | | | "System.Timeout" | Giving up quickly when a service | + | | | | does not respond | + +----+----------------------+----------------------------------+---------------------------------------+ + | 5 | __HTTP__ | "ASCII" | Expressing HTTP messages as strings | + | | +----------------------------------+ | + | | | "ASCII.Char" | | + | | +----------------------------------+---------------------------------------+ + | | | "SocketsAndPipes.Serve" | Our first rudimentary web server | + +----+----------------------+----------------------------------+---------------------------------------+ + | 6 | __HTTP types__ | "Data.ByteString" | Defining datatypes for the | + | | +----------------------------------+ parts of an HTTP message | + | | | "Data.ByteString.Lazy" | | + +----+----------------------+----------------------------------+---------------------------------------+ + | 7 | __Encoding__ | "Data.Text.Lazy" | Efficient string concatenations | + | | +----------------------------------+ | + | | | "Data.Text.Lazy.Builder" | | + | | +----------------------------------+ | + | | | "Data.ByteString.Builder" | | + | | +----------------------------------+---------------------------------------+ + | | | "Data.Time" | Simple performance testing | + | | +----------------------------------+---------------------------------------+ + | | | "Data.Foldable" | Encoding repetitions with `foldMap` | + +----+----------------------+----------------------------------+---------------------------------------+ + | 8 | __Responding__ | "Network.Socket.ByteString.Lazy" | Sending responses constructed by | + | | | | bytestring `Builder` | + | | +----------------------------------+---------------------------------------+ + | | | "SocketsAndPipes.Serve" | New web server using the | + | | | | encoding functions | + | | +----------------------------------+---------------------------------------+ + | | | "Data.Int" | Contrasting `Integer`, `Int`, | + | | | | and `Int64` | + +----+----------------------+----------------------------------+---------------------------------------+ + | 9 | __Content types__ | "Data.Text.Lazy.Builder.Int" | Building a text response body | + | | +----------------------------------+---------------------------------------+ + | | | "Text.Blaze.Html" | Building an HTML response body | + | | +----------------------------------+ | + | | | "Text.Blaze.Html5" | | + | | +----------------------------------+ | + | | | "Text.Blaze.Html.Renderer.Utf8" | | + | | +----------------------------------+---------------------------------------+ + | | | "Data.Aeson" | Building a JSON response body | + +----+----------------------+----------------------------------+---------------------------------------+ + | 10 | __Change__ | "Control.Concurrent.STM.TVar" | Shared state for request-handling | + | | +----------------------------------+ threads | + | | | "Control.Monad.STM" | | + +----+----------------------+--------------------------------+-----------------------------------------+ + | 11 | __Chunked bodies__ | | + +----+----------------------+ | + | 12 | __Request parsing__ | | + +----+----------------------+ | + | 13 | __Reading headers__ | | + +----+----------------------+ The remaining chapters are in progress. | + | 14 | __Body parsing__ | | + +----+----------------------+ | + | 15 | __Connection reuse__ | | + +----+----------------------+ | + | 16 | __Pipes__ | | + +----+----------------------+--------------------------------------------------------------------------+ + . + == Libraries + . + Re-exported modules, grouped by the package that each module originally comes from: + . + __ascii__ - "ASCII", "ASCII.Char" + . + __aeson__ - "Data.Aeson" + . + __async__ - "Control.Concurrent.Async" + . + __base__ + . + * File handles - "System.IO" + * Fundamental data types - "Data.Word", "Data.Int", "Data.Char" + * Miscellania - "System.Timeout", "Control.Monad", + "Data.Foldable", "Data.List" + . + __blaze-html__ - "Text.Blaze.Html", "Text.Blaze.Html5", + "Text.Blaze.Html5.Attributes", "Text.Blaze.Html.Renderer.Utf8" + . + __bytestring__ + . + * Strict - "Data.ByteString" + * Lazy - "Data.ByteString.Lazy" + * Builder - "Data.ByteString.Builder" + * "Data.ByteString.Char8" - + This is included mostly to discuss why we don't use it. + . + __network__ + . + * "Network.Socket" - + The Socket type, operations for opening and closing sockets + * "Network.Socket.ByteString" - + Socket read/write operations with strict byte strings + * "Network.Socket.ByteString.Lazy" - + Socket read/write operations with lazy byte strings + . + __safe-exceptions__ - "Control.Exception.Safe" + . + __stm__ - "Control.Monad.STM", "Control.Concurrent.STM.TVar" + . + __text__ + . + * Strict - "Data.Text", "Data.Text.Encoding", "Data.Text.IO" + * Lazy - "Data.Text.Lazy", "Data.Text.Lazy.Encoding", "Data.Text.Lazy.IO" + * Builder - "Data.Text.Lazy.Builder", "Data.Text.Lazy.Builder.Int" + . + __time__ - "Data.Time" + +source-repository head + type: git + location: git://github.com/joyofhaskell/sockets-and-pipes.git + +library + default-language: Haskell2010 + default-extensions: GADTs, NamedFieldPuns, NumericUnderscores + ghc-options: -Wall + hs-source-dirs: src + + exposed-modules: SocketsAndPipes.Serve + other-modules: + SocketsAndPipes.Serve.Setup + SocketsAndPipes.Serve.Loop + SocketsAndPipes.Serve.Sockets + SocketsAndPipes.Serve.ForkBracket + SocketsAndPipes.Serve.Exceptions + + build-depends: ascii ^>= 1.0 + reexported-modules: ASCII, ASCII.Char + + build-depends: aeson ^>= 1.3 || ^>= 1.4 || ^>= 1.5 + reexported-modules: Data.Aeson + + build-depends: async ^>= 2.2 + reexported-modules: Control.Concurrent.Async + + build-depends: base ^>= 4.12 || ^>= 4.13 || ^>= 4.14 + -- + -- Update to 4.15 is held back by: + -- + -- * network-3.1.2 introduced a dependency on the 'directory' + -- package, which does not yet support base-4.15. + -- + reexported-modules: + Control.Monad, + Data.Char, + Data.Foldable, + Data.Int, + Data.List, + Data.Word, + System.IO, + System.Timeout + + build-depends: blaze-html ^>= 0.9 + reexported-modules: + Text.Blaze.Html, + Text.Blaze.Html5, + Text.Blaze.Html5.Attributes, + Text.Blaze.Html.Renderer.Utf8 + + build-depends: bytestring ^>= 0.10 + -- + -- Update to 0.11 is held back by: + -- + -- * https://github.com/jaspervdj/blaze-html/issues/135 + -- + reexported-modules: + Data.ByteString, + Data.ByteString.Builder, + Data.ByteString.Char8, + Data.ByteString.Lazy + + build-depends: containers ^>= 0.5.7 || ^>= 0.6 + + build-depends: network ^>= 3.1.2 + -- + -- Reasons for lower bounds: + -- + -- * 3.1.1 introduced the 'gracefulClose' function. + -- * 3.1.1 series is deprecated due to flaw in 'gracefulClose'. + -- * 3.1.2 introduced the 'openSocket' function. + -- + reexported-modules: + Network.Socket, + Network.Socket.ByteString, + Network.Socket.ByteString.Lazy + + build-depends: safe-exceptions ^>= 0.1 + reexported-modules: Control.Exception.Safe + + build-depends: stm ^>= 2.5 + reexported-modules: + Control.Concurrent.STM, + Control.Concurrent.STM.TVar, + Control.Monad.STM + + build-depends: text ^>= 1.2.3 + -- + -- Reasons for lower bounds: + -- + -- * 1.2.3 is the first version that works with base-4.12. + -- + reexported-modules: + Data.Text, + Data.Text.Encoding, + Data.Text.Lazy, + Data.Text.Lazy.Builder, + Data.Text.Lazy.Builder.Int, + Data.Text.Lazy.Encoding, + Data.Text.Lazy.IO, + Data.Text.IO + + build-depends: time ^>= 1.9 || ^>= 1.10 + -- + -- Update to 1.11 is held back by: + -- + -- * https://github.com/haskell/directory/issues/115 + -- + reexported-modules: Data.Time diff --git a/src/SocketsAndPipes/Serve.hs b/src/SocketsAndPipes/Serve.hs new file mode 100644 --- /dev/null +++ b/src/SocketsAndPipes/Serve.hs @@ -0,0 +1,92 @@ +module SocketsAndPipes.Serve + ( {- * Serve -} serve, + {- * Example -} {- $example -} + {- * Options -} ServeOptions, port + {- * Alternatives -} {- $alternatives -} + ) where + +import SocketsAndPipes.Serve.Exceptions ( displayBindFailed ) +import SocketsAndPipes.Serve.Sockets ( Socket, PortNumber, PassiveSocket, + passiveSocketAddress, peerSocket ) +import SocketsAndPipes.Serve.Setup ( withSocketOnPort ) +import SocketsAndPipes.Serve.Loop ( run ) + +import Control.Exception.Safe ( catch ) + +import qualified Data.Text.Lazy.IO as LT +import qualified Data.Text.Lazy.Builder as TB +import qualified System.IO as IO + +import Prelude hiding (print) + +-- | The first argument to 'serve'. +data ServeOptions = + ServeOnPort PortNumber +{- This type is abstract so that we might add more options in + the future without disturbing the users of this library. -} + +port :: PortNumber -- ^ The port number that your server will listen on + -> ServeOptions +port = ServeOnPort + +serve :: + ServeOptions + -> (Socket -> IO ()) + {- ^ What to do each time a new client connects to your server. + These actions run concurrently in separate threads. -} + -> IO () + {- ^ Perpetually listens for incoming connections and runs + the @(Socket -> IO ())@ function each time a new client + opens a connection. -} +serve (ServeOnPort p) f = + go `catch` ifBindFailed + + where + go = withSocketOnPort p $ \s -> + do + print =<< displayBindSuccess s + run (f . peerSocket) s + + ifBindFailed = print . displayBindFailed + +print :: TB.Builder -> IO () +print = LT.hPutStrLn IO.stderr . TB.toLazyText + +displayBindSuccess :: PassiveSocket -> IO TB.Builder +displayBindSuccess s = + passiveSocketAddress s >>= \a -> + return $ + TB.fromString "The server is listening on address " + <> TB.fromString (show a) + +{- $example + +Suppose you have a function that reads an HTTP request from a +socket and then writes an HTTP response back to the socket. + +@handleHttpRequest :: 'Socket' -> IO ()@ + +Then you might start a server by running the following in GHCi: + +@ +λ> import "SocketsAndPipes.Serve" +λ> 'serve' ('port' 8000) handleHttpRequest +@ + +And while the server is still running, test it on the command line +like so: + +> $ curl http://localhost:8000 + +-} + +{- $alternatives + +The 'serve' function here is somewhat narrowly tailored +to fit our purposes in /Sockets and Pipes/. +Some other packages have more expansive offerings: + + * + * + +-} diff --git a/src/SocketsAndPipes/Serve/Exceptions.hs b/src/SocketsAndPipes/Serve/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/SocketsAndPipes/Serve/Exceptions.hs @@ -0,0 +1,103 @@ +module SocketsAndPipes.Serve.Exceptions + ( + -- * Types + BindFailed (..), AddrTried (..), + + -- * Functions related to the types + displayBindFailed, displayAddrTried, + + -- * General functions for working with exceptions + overException, firstSuccessOrAllExceptions + + ) where + +import Control.Exception.Safe + ( Exception (displayException), SomeException, catch, throw ) + +import Data.Foldable ( fold ) + +import qualified Data.Sequence as Seq +import qualified Data.Foldable as Seq ( toList ) +import qualified Data.List as List +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as TB +import qualified Network.Socket as Socket + +data BindFailed = + BindFailed + { bindAddrsTried :: [AddrTried] + } + deriving Show + +instance Exception BindFailed + where + displayException = LT.unpack . TB.toLazyText . displayBindFailed + +data AddrTried = + AddrTried + { addrTried :: Socket.AddrInfo + , addrException :: SomeException + } + deriving Show + +instance Exception AddrTried + where + displayException = LT.unpack . TB.toLazyText . displayAddrTried + +displayBindFailed :: BindFailed -> TB.Builder +displayBindFailed BindFailed{ bindAddrsTried } + | null bindAddrsTried = displayBindFailedNoAddresses + | otherwise = displayBindFailedWithAddrs bindAddrsTried + +displayBindFailedNoAddresses :: TB.Builder +displayBindFailedNoAddresses = + TB.fromString + "Failed to set up a passive socket for the server \ + \because no candidate addresses were found." + +displayBindFailedWithAddrs :: [AddrTried] -> TB.Builder +displayBindFailedWithAddrs bindAddrsTried = + TB.fromString "Failed to set up a passive socket for the server. \ + \The following addresses were tried:\n" <> + fold + ( + List.intersperse + (TB.fromString "\n") + ( + List.map + ( \AddrTried{ addrTried, addrException } -> + TB.fromString " ❌ " <> + TB.fromString (show (Socket.addrAddress addrTried)) <> + TB.fromString " — " <> + TB.fromString (displayException addrException) + ) + bindAddrsTried + ) + ) + +displayAddrTried :: AddrTried -> TB.Builder +displayAddrTried AddrTried{ addrTried, addrException } = + TB.fromString (show addrTried) <> TB.fromString ": " + <> TB.fromString (displayException addrException) + +overException :: (Exception e1, Exception e2) => + (e1 -> e2) -- ^ How to turn the exception + -- into a different exception + -> IO a -- ^ Action that might throw the first exception + -> IO a -- ^ Action that might throw the second exception +overException f a = catch a (throw . f) +{- ^ + If the action throws an exception, turn it into a different + exception. This is useful to add information that explains + the context in which the original exception occurred. +-} + +firstSuccessOrAllExceptions :: (Exception e1, Exception e2) => + ([e1] -> e2) -- ^ How to collect the many exceptions into one + -> [IO a] -- ^ Many actions that may fail + -> IO a -- ^ The result from the first action that succeeds, + -- or else throws a collection of all the exceptions. +firstSuccessOrAllExceptions f = go Seq.empty + where + go exs [] = throw (f (Seq.toList exs)) + go exs (a : as) = catch a (\ex -> go (exs Seq.|> ex) as) diff --git a/src/SocketsAndPipes/Serve/ForkBracket.hs b/src/SocketsAndPipes/Serve/ForkBracket.hs new file mode 100644 --- /dev/null +++ b/src/SocketsAndPipes/Serve/ForkBracket.hs @@ -0,0 +1,58 @@ +{- | + + The 'forkBracket' function ensures that if the setup + action completes, then no matter what else happens, + exactly one of either 'onForkFail' or 'onThreadEnd' will run. + +-} +module SocketsAndPipes.Serve.ForkBracket + ( forkBracket, Cleanup (..), ThreadId ) where + +import Control.Concurrent ( forkFinally, ThreadId ) +import Control.Exception.Safe ( bracketOnError ) + +forkBracket :: + IO resource -- ^ Setup: + -- How to open some resource. + -> Cleanup resource -- ^ Cleanup: + -- How to close the resource. + -> (resource -> IO x) -- ^ Action that uses the resource. + -- This will run in a new thread. + -> IO ThreadId +forkBracket setup Cleanup{onForkFail, onThreadEnd} action = + bracketOnError setup onForkFail $ \resource -> + action resource `forkFinally` \_result -> + onThreadEnd resource >> return () + +{- | + A strategy for closing a resource that is opened + by a main event loop and used in a forked thread. + + It consists of handlers for two possibilities: + + * 'onThreadEnd' runs after the thread has completed. + * 'onForkFail' runs if the thread failed to start. +-} +data Cleanup resource + where + Cleanup :: + { onForkFail :: resource -> IO x + {- ^ Cleanup if forking fails. + + This action runs in the original thread. + + It only runs if there was an exception that + prevented a new thread from starting. + -} + + , onThreadEnd :: resource -> IO y + {- ^ Cleanup after the thread terminates. + + This action runs in the forked thread. + + If the thread actually started, this cleanup + action runs regardless of whether the thread + terminates normally or with an exception. + -} + } + -> Cleanup resource diff --git a/src/SocketsAndPipes/Serve/Loop.hs b/src/SocketsAndPipes/Serve/Loop.hs new file mode 100644 --- /dev/null +++ b/src/SocketsAndPipes/Serve/Loop.hs @@ -0,0 +1,42 @@ +module SocketsAndPipes.Serve.Loop ( run ) where + +import SocketsAndPipes.Serve.ForkBracket + ( forkBracket, Cleanup (..), ThreadId ) + +import SocketsAndPipes.Serve.Sockets + ( PeerSocket, PassiveSocket, accept, + closePeerSocketPolitely, closePeerSocketAbruptly ) + +import Control.Monad ( forever ) + +run :: + (PeerSocket -> IO a) -- ^ What to do when a new client connects. + -> PassiveSocket -- ^ A socket that is listening for connections. + -> IO b +run server s = forever (acceptAndFork s server) +{- ^ + Perpetually awaits new connections, + forking a new thread to handle each one. +-} + +acceptAndFork :: + PassiveSocket -- ^ A socket that is listening for connections. + -> (PeerSocket -> IO a) -- ^ What to do when a new client connects. + -> IO ThreadId +acceptAndFork s = forkBracket (accept s) socketForkBracketCleanup +{- ^ + Waits until a new client shows up to connect to our server. + When a peer connects, the socket for talking to them will + be passed to the given function. +-} + +socketForkBracketCleanup :: Cleanup PeerSocket +socketForkBracketCleanup = Cleanup{onForkFail, onThreadEnd} + where + onThreadEnd = -- At the end of the thread: + closePeerSocketPolitely -- Politely conclude the connection. + + onForkFail = -- If an exception occurs before the thread even starts: + closePeerSocketAbruptly -- Just close the socket abruptly. + -- Since this happens on the main thread, we don't + -- want to take the time to wait for a graceful close. diff --git a/src/SocketsAndPipes/Serve/Setup.hs b/src/SocketsAndPipes/Serve/Setup.hs new file mode 100644 --- /dev/null +++ b/src/SocketsAndPipes/Serve/Setup.hs @@ -0,0 +1,149 @@ +module SocketsAndPipes.Serve.Setup ( withSocketOnPort ) where + +import SocketsAndPipes.Serve.Sockets + ( PortNumber, Socket, PassiveSocket (..), closePassiveSocket ) + +import SocketsAndPipes.Serve.Exceptions + ( BindFailed (..), AddrTried (..), + overException, firstSuccessOrAllExceptions ) + +import Control.Monad ( (>=>), when ) +import Data.Function ( on ) + +import qualified Control.Exception.Safe as Exception +import qualified Data.List as List +import qualified Network.Socket as Socket + +withSocketOnPort :: PortNumber -> (PassiveSocket -> IO a) -> IO a +withSocketOnPort port = Exception.bracket (bindToPort port) closePassiveSocket + +bindToPort :: PortNumber -> IO PassiveSocket +bindToPort = addrsForPort >=> chooseAddrAndBind + +addrsForPort :: PortNumber -> IO [Socket.AddrInfo] +addrsForPort port = Socket.getAddrInfo hints hostName serviceName + where + hints = Just serverAddrHints :: Maybe Socket.AddrInfo + hostName = Nothing :: Maybe Socket.HostName + serviceName = Just (show port) :: Maybe Socket.ServiceName +{- ^ + The first thing we have to do when starting a server is figure + out exactly what network address to listen on. + + We've been given a port number, but that's only half the story; + a network address actually include a lot more obnoxious details + in addition to the port number. + + 'addrsForPort' uses the 'S.getAddrInfo' function from the network + library to find a list of possible addresses for us to choose from. +-} + +serverAddrHints :: Socket.AddrInfo +serverAddrHints = + Socket.defaultHints{ Socket.addrSocketType, Socket.addrFlags } + where + addrSocketType = Socket.Stream :: Socket.SocketType + {- A "stream" socket uses TCP to make sure all the + packets arrive in the right order. -} + addrFlags = [Socket.AI_PASSIVE] :: [Socket.AddrInfoFlag] + {- A "passive" socket is a socket that will be + used to listen for incoming connections. -} + +chooseAddrAndBind :: [Socket.AddrInfo] -> IO PassiveSocket +chooseAddrAndBind = + firstSuccessOrAllExceptions BindFailed . map bindToAddr + . List.sortBy (compare `on` addrPreference) + +addrPreference :: Socket.AddrInfo -> Int +addrPreference addr = + case Socket.addrFamily addr of + Socket.AF_INET6 -> 1 {- IPv6 is best, because these addresses can + accept both IPv4 and IPv6 connections. -} + Socket.AF_INET -> 2 {- IPv4 is next best, if IPv6 is not supported. -} + _ -> 3 {- Other addressing schemes are unfamiliar. -} +{- ^ + Assigns a ranking to each address, indicating our relative preference. + A lesser number indicates a more preferable address. +-} + +bindToAddr :: Socket.AddrInfo -> IO PassiveSocket +bindToAddr addr = + overException (AddrTried addr) $ + Exception.bracketOnError (Socket.openSocket addr) Socket.close $ \s -> + initServerSocket addr s *> return (PassiveSocket s) + +initServerSocket :: Socket.AddrInfo -> Socket -> IO () +initServerSocket addr s = + do + setReuseAddr s -- Disable some safety to permit fast restarts. + setKeepAlive s -- Send empty packets to keep connections alive. + setNoDelay s -- Send bytes immediately without buffering. + allowIPv4and6 addr s -- If it's an IPv6 address, enable IPv4 also. + bind addr s -- Assign the address to the socket. + listen s -- Announce willingness to receive connections. + +bind :: Socket.AddrInfo -> Socket -> IO () +bind addr s = Socket.bind s (Socket.addrAddress addr) + +allowIPv4and6 :: Socket.AddrInfo -> Socket -> IO () +allowIPv4and6 addr s = + when (Socket.addrFamily addr == Socket.AF_INET6) $ + Socket.setSocketOption s Socket.IPv6Only 0 + +setReuseAddr :: Socket -> IO () +setReuseAddr s = Socket.setSocketOption s Socket.ReuseAddr 1 +{- ^ + By default, the operating system will not let us restart our server and + bind to the same address immediately, because the new process will + receive any TCP packets that were in flight during the restart, which + is typically undesirable. + + Overriding the default behavior like this is not really safe! + But it lets us restart our server quickly :) +-} + +setKeepAlive :: Socket -> IO () +setKeepAlive s = Socket.setSocketOption s Socket.KeepAlive 1 +{- ^ + This enables a nice TCP feature: if there is a long period of time + with no activity on the socket, the OS will occasionally send an + empty packet. This has two benefits: + + 1. It lets the peer know that we're still here; otherwise the peer will + close the connection, assuming that we've abandoned the conversation. + + 2. If lets us know whether the peer is still there. If we don't receive + an acknowledgement of the empty packet, we can close the connection. +-} + +setNoDelay :: Socket -> IO () +setNoDelay s = Socket.setSocketOption s Socket.NoDelay 1 +{- ^ + + Since it's more efficient to transmit a few large packets than many + small packets, the OS doesn't always send your bytes right away when + you write to a socket; By default, it make some effort to group + together small writes into larger packets. + + The downside of this optimization is that it means sometimes we don't + immediately see the effect of writing to a socket. For experimental + and demonstration purposes, this can be quite undesirable, so we use + this setting to disable the feature. +-} + +listen :: Socket -> IO () +listen s = Socket.listen s listenBacklog +{- ^ + Informs the operating system that this socket will be used to + accept incoming connection requests. + + Such as socket is called a "passive socket". +-} + +listenBacklog :: Int +listenBacklog = 1_024 +{- ^ + The 'S.accept' function pulls sockets from a queue maintained by + the operating system. This is the size we are requesting for that queue. + (The OS might not actually give us a queue as big as we ask for.) +-} diff --git a/src/SocketsAndPipes/Serve/Sockets.hs b/src/SocketsAndPipes/Serve/Sockets.hs new file mode 100644 --- /dev/null +++ b/src/SocketsAndPipes/Serve/Sockets.hs @@ -0,0 +1,67 @@ +{- | + + The 'PassiveSocket' and 'PeerSocket' newtypes + distinguish passive sockets from peer sockets. + + This module also includes a few basic operations + involving these types. + +-} +module SocketsAndPipes.Serve.Sockets + ( + + Socket, + PortNumber, + + PassiveSocket (..), closePassiveSocket, + passiveSocketAddress, + + PeerSocket (..), closePeerSocketAbruptly, + closePeerSocketPolitely, + + accept + + ) where + +import Network.Socket ( Socket, PortNumber ) +import qualified Network.Socket as Socket + +newtype PassiveSocket = PassiveSocket { passiveSocket :: Socket } + -- ^ A passive socket that is listening for connections. + +newtype PeerSocket = PeerSocket { peerSocket :: Socket } + -- ^ A socket that we're using to talk to a client + -- that has connected to our server. + +closePassiveSocket :: PassiveSocket -> IO () +closePassiveSocket = Socket.close . passiveSocket + +closePeerSocketAbruptly :: PeerSocket -> IO () +closePeerSocketAbruptly = Socket.close . peerSocket + +closePeerSocketPolitely :: PeerSocket -> IO () +closePeerSocketPolitely s = + Socket.gracefulClose (peerSocket s) finMilliseconds +{- ^ + Closes a TCP connection by sending a FIN packet, which is more + respectful to the peer than if we were to simply ghost them. +-} + +finMilliseconds :: Int +finMilliseconds = 5_000 +{- ^ + Timeout for the 'fin' action. + 5 seconds = 5000 milliseconds +-} + +accept :: PassiveSocket -> IO PeerSocket +accept s = + Socket.accept (passiveSocket s) >>= + \(s', _) -> return (PeerSocket s') +{- ^ + Waits until a new client shows up to connect to our server. + Returns the socket that we use to talk to this particular peer. +-} + +passiveSocketAddress :: PassiveSocket -> IO Socket.SockAddr +passiveSocketAddress = Socket.getSocketName . passiveSocket