Add module Database.MongoDB.Internal.Network.

Add flag imitating bson package PR for network changes.
Add stack files for compilation checking.

Both ghc86 builds work. Still need to fix ghc84 and under builds with older network code.
This commit is contained in:
Scott Fleischman 2019-05-29 18:02:37 -07:00
parent 5bb77518a8
commit 21cf023854
10 changed files with 72 additions and 17 deletions

View file

@ -30,7 +30,6 @@ import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_)
import Network (HostName, PortID(..), connectTo)
import System.IO.Unsafe (unsafePerformIO)
import System.Timeout (timeout)
import Text.ParserCombinators.Parsec (parse, many1, letter, digit, char, eof,
@ -48,6 +47,7 @@ import Data.Text (Text)
import qualified Data.Bson as B
import qualified Data.Text as T
import Database.MongoDB.Internal.Network (HostName, PortID(..), connectTo)
import Database.MongoDB.Internal.Protocol (Pipe, newPipe, close, isClosed)
import Database.MongoDB.Internal.Util (untilSuccess, liftIOE,
updateAssocs, shuffle, mergesortM)
@ -79,11 +79,7 @@ showHostPort :: Host -> String
-- TODO: Distinguish Service and UnixSocket port
showHostPort (Host hostname port) = hostname ++ ":" ++ portname where
portname = case port of
Service s -> s
PortNumber p -> show p
#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)
UnixSocket s -> s
#endif
readHostPortM :: (Monad m) => String -> m Host
-- ^ Read string \"hostname:port\" as @Host hosthame (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Fail if string does not match either syntax.

View file

@ -0,0 +1,32 @@
-- | Compatibility layer for network package, including newtype 'PortID'
{-# LANGUAGE CPP, PackageImports #-}
module Database.MongoDB.Internal.Network (PortID(..), N.HostName, connectTo) where
import Control.Exception (bracketOnError)
import Network.BSD as BSD
import System.IO (Handle, IOMode(ReadWriteMode))
#if !MIN_VERSION_network(2, 8, 0)
import qualified Network as N
#else
import qualified Network.Socket as N
#endif
newtype PortID = PortNumber N.PortNumber deriving (Show, Eq, Ord)
-- Taken from network 2.8's connectTo
-- https://github.com/haskell/network/blob/e73f0b96c9da924fe83f3c73488f7e69f712755f/Network.hs#L120-L129
connectTo :: N.HostName -- Hostname
-> PortID -- Port Identifier
-> IO Handle -- Connected Socket
connectTo hostname (PortNumber port) = do
proto <- BSD.getProtocolNumber "tcp"
bracketOnError
(N.socket N.AF_INET N.Stream proto)
(N.close) -- only done if there's an error
(\sock -> do
he <- BSD.getHostByName hostname
N.connect sock (N.SockAddrInet port (hostAddress he))
N.socketToHandle sock ReadWriteMode
)

View file

@ -1,9 +1,7 @@
-- | Miscellaneous general functions and Show, Eq, and Ord instances for PortID
-- | Miscellaneous general functions
{-# LANGUAGE FlexibleInstances, UndecidableInstances, StandaloneDeriving #-}
{-# LANGUAGE CPP #-}
-- PortID instances
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.MongoDB.Internal.Util where
@ -14,7 +12,6 @@ import Control.Exception (handle, throwIO, Exception)
import Control.Monad (liftM, liftM2)
import Data.Bits (Bits, (.|.))
import Data.Word (Word8)
import Network (PortID(..))
import Numeric (showHex)
import System.Random (newStdGen)
import System.Random.Shuffle (shuffle')
@ -28,12 +25,6 @@ import Data.Text (Text)
import qualified Data.Text as T
#if !MIN_VERSION_network(2, 4, 1)
deriving instance Show PortID
deriving instance Eq PortID
#endif
deriving instance Ord PortID
-- | A monadic sort implementation derived from the non-monadic one in ghc's Prelude
mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a]
mergesortM cmp = mergesortM' cmp . map wrap

View file

@ -39,7 +39,7 @@ import Database.MongoDB.Internal.Protocol (newPipeWith)
import Database.MongoDB.Transport (Transport(Transport))
import qualified Database.MongoDB.Transport as T
import System.IO.Error (mkIOError, eofErrorType)
import Network (connectTo, HostName, PortID)
import Database.MongoDB.Internal.Network (connectTo, HostName, PortID)
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra.Cipher as TLS
import Database.MongoDB.Query (access, slaveOk, retrieveServerData)

View file

@ -19,6 +19,12 @@ Build-type: Simple
Stability: alpha
Extra-Source-Files: CHANGELOG.md
-- Imitated from https://github.com/mongodb-haskell/bson/pull/18
Flag _old-network
description: Control whether to use <http://hackage.haskell.org/package/network-bsd network-bsd>
default: False
manual: False
Library
GHC-options: -Wall
default-language: Haskell2010
@ -54,6 +60,13 @@ Library
, base64-bytestring >= 1.0.0.1
, nonce >= 1.0.5
if flag(_old-network)
-- "Network.BSD" is only available in network < 2.9
build-depends: network < 2.9
else
-- "Network.BSD" has been moved into its own package `network-bsd`
build-depends: network-bsd >= 2.7 && < 2.9
Exposed-modules: Database.MongoDB
Database.MongoDB.Admin
Database.MongoDB.Connection
@ -61,7 +74,8 @@ Library
Database.MongoDB.Query
Database.MongoDB.Transport
Database.MongoDB.Transport.Tls
Other-modules: Database.MongoDB.Internal.Protocol
Other-modules: Database.MongoDB.Internal.Network
Database.MongoDB.Internal.Protocol
Database.MongoDB.Internal.Util
Source-repository head

4
stack-ghc80.yaml Normal file
View file

@ -0,0 +1,4 @@
resolver: lts-9.21
flags:
mongoDB:
_old-network: true

4
stack-ghc82.yaml Normal file
View file

@ -0,0 +1,4 @@
resolver: lts-11.22
flags:
mongoDB:
_old-network: true

4
stack-ghc84.yaml Normal file
View file

@ -0,0 +1,4 @@
resolver: lts-12.26
flags:
mongoDB:
_old-network: true

View file

@ -0,0 +1,6 @@
resolver: lts-13.23
extra-deps:
- git: git@github.com:hvr/bson.git # https://github.com/mongodb-haskell/bson/pull/18
commit: 2fc8d04120c0758201762b8e22254aeb6d574f41
- network-bsd-2.8.1.0
- network-3.1.0.0

4
stack-ghc86.yaml Normal file
View file

@ -0,0 +1,4 @@
resolver: lts-13.23
flags:
mongoDB:
_old-network: true