@@ -38,6 +38,8 @@ module Network.Wai.Handler.Warp
3838 , settingsTimeout
3939 , settingsIntercept
4040 , settingsManager
41+ -- ** Data types
42+ , HostPreference (..)
4143 -- * Connection
4244 , Connection (..)
4345 , runSettingsConnection
@@ -116,6 +118,7 @@ import qualified Data.CaseInsensitive as CI
116118import System.IO (hPutStrLn, stderr)
117119import ReadInt (readInt64)
118120import qualified Data.IORef as I
121+import Data.String (IsString (..))
119122
120123#if WINDOWS
121124import Control.Concurrent (threadDelay)
@@ -164,18 +167,27 @@ socketConnection s = Connection
164167 }
165168
166169
167−bindPort :: Int -> String -> IO Socket
170+bindPort :: Int -> HostPreference -> IO Socket
168171bindPort p s = do
169172 let hints = defaultHints { addrFlags = [AI_PASSIVE
170173 , AI_NUMERICSERV
171174 , AI_NUMERICHOST]
172175 , addrSocketType = Stream }
173− host = if s == "*" then Nothing else Just s
176+ host =
177+ case s of
178+ Host s' -> Just s'
179+ _ -> Nothing
174180 port = Just . show $ p
175181 addrs <- getAddrInfo (Just hints) host port
176182 -- Choose an IPv6 socket if exists. This ensures the socket can
177183 -- handle both IPv4 and IPv6 if v6only is false.
178− let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs ++ filter (\x -> addrFamily x /= AF_INET6) addrs
184+ let addrs4 = filter (\x -> addrFamily x /= AF_INET6) addrs
185+ addrs6 = filter (\x -> addrFamily x == AF_INET6) addrs
186+ addrs' =
187+ case s of
188+ HostIPv4 -> addrs4 ++ addrs6
189+ HostIPv6 -> addrs6 ++ addrs4
190+ _ -> addrs
179191
180192 tryAddrs (addr1:rest@(_:_)) =
181193 catch
@@ -616,19 +628,51 @@ connSink Connection { connSendAll = send } th =
616628-- > defaultSettings { settingsTimeout = 20 }
617629data Settings = Settings
618630 { settingsPort :: Int -- ^ Port to listen on. Default value: 3000
619− , settingsHost :: String -- ^ Host to bind to, or * for all. Default value: *
631+ , settingsHost :: HostPreference -- ^ Default value: HostIPv4
620632 , settingsOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
621633 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
622634 , settingsIntercept :: Request -> Maybe (C.BufferedSource IO S.ByteString -> Connection -> ResourceT IO ())
623635 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
624636 }
625637
638+-- | Which host to bind.
639+--
640+-- Note: The @IsString@ instance recognizes the following special values:
641+--
642+-- * @*@ means @HostAny@
643+--
644+-- * @*4@ means @HostIPv4@
645+--
646+-- * @*6@ means @HostIPv6@
647+data HostPreference =
648+ HostAny
649+ | HostIPv4
650+ | HostIPv6
651+ | Host String
652+ deriving (Show, Eq, Ord)
653+
654+instance IsString HostPreference where
655+ -- The funny code coming up is to get around some irritating warnings from
656+ -- GHC. I should be able to just write:
657+ {-
658+ fromString "*" = HostAny
659+ fromString "*4" = HostIPv4
660+ fromString "*6" = HostIPv6
661+ -}
662+ fromString s'@('*':s) =
663+ case s of
664+ [] -> HostAny
665+ ['4'] -> HostIPv4
666+ ['6'] -> HostIPv6
667+ _ -> Host s'
668+ fromString s = Host s
669+
626670-- | The default settings for the Warp server. See the individual settings for
627671-- the default value.
628672defaultSettings :: Settings
629673defaultSettings = Settings
630674 { settingsPort = 3000
631− , settingsHost = "*"
675+ , settingsHost = HostIPv4
632676 , settingsOnException = \e ->
633677 case fromException e of
634678 Just x -> go x