Merge: update to network 3.0

This PR introduces an abstraction layer that
builds a facade for network 2.8 and 3.0.

PR# 98

.gitignore

@@ -1,3 +1,4 @@
 dist/
 cabal.sandbox.config
 .cabal-sandbox/
+.stack-work/

Database/MongoDB/Connection.hs

@@ -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,
@@ -39,7 +38,7 @@ import qualified Data.List as List
 
 
 import Control.Monad.Identity (runIdentity)
-import Control.Monad.Error (throwError)
+import Control.Monad.Except (throwError)
 import Control.Concurrent.MVar.Lifted (MVar, newMVar, withMVar, modifyMVar,
                                        readMVar)
 import Data.Bson (Document, at, (=:))
@@ -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.

Database/MongoDB/GridFS.hs

@@ -27,7 +27,7 @@ import Control.Applicative((<$>))
 
 import Control.Monad(when)
 import Control.Monad.IO.Class
-import Control.Monad.Trans(MonadTrans, lift)
+import Control.Monad.Trans(lift)
 
 import Data.Conduit
 import Data.Digest.Pure.MD5
@@ -121,14 +121,14 @@ sourceFile file = yieldChunk 0 where
 
 -- Used to keep data during writing
 data FileWriter = FileWriter
-  { fwChunkSize :: Int64
-  , fwBucket :: Bucket
-  , fwFilesId :: ObjectId
-  , fwChunkIndex :: Int
-  , fwSize :: Int64
-  , fwAcc :: L.ByteString
-  , fwMd5Context :: MD5Context
-  , fwMd5acc :: L.ByteString
+  { _fwChunkSize :: Int64
+  , _fwBucket :: Bucket
+  , _fwFilesId :: ObjectId
+  , _fwChunkIndex :: Int
+  , _fwSize :: Int64
+  , _fwAcc :: L.ByteString
+  , _fwMd5Context :: MD5Context
+  , _fwMd5acc :: L.ByteString
   }
 
 -- Finalize file, calculating md5 digest, saving the last chunk, and creating the file in the bucket
@@ -136,10 +136,10 @@ finalizeFile :: (Monad m, MonadIO m) => Text -> FileWriter -> Action m File
 finalizeFile filename (FileWriter chunkSize bucket files_id i size acc md5context md5acc) = do
   let md5digest = finalizeMD5 md5context (L.toStrict md5acc)
   when (L.length acc > 0) $ putChunk bucket files_id i acc
-  timestamp <- liftIO $ getCurrentTime
+  currentTimestamp <- liftIO $ getCurrentTime
   let doc = [ "_id" =: files_id
             , "length" =: size
-            , "uploadDate" =: timestamp
+            , "uploadDate" =: currentTimestamp
             , "md5" =: show (md5digest)
             , "chunkSize" =: chunkSize
             , "filename" =: filename
@@ -149,13 +149,13 @@ finalizeFile filename (FileWriter chunkSize bucket files_id i size acc md5contex
 
 -- finalize the remainder and return the MD5Digest.
 finalizeMD5 :: MD5Context -> S.ByteString -> MD5Digest
-finalizeMD5 ctx rest =
-  md5Finalize ctx2 (S.drop lu rest) -- can only handle max md5BlockSizeInBytes length
+finalizeMD5 ctx remainder =
+  md5Finalize ctx2 (S.drop lu remainder) -- can only handle max md5BlockSizeInBytes length
   where
-    l = S.length rest
+    l = S.length remainder
     r = l `mod` md5BlockSizeInBytes
     lu = l - r
-    ctx2 = md5Update ctx (S.take lu rest)
+    ctx2 = md5Update ctx (S.take lu remainder)
 
 -- Write as many chunks as can be written from the file writer
 writeChunks :: (Monad m, MonadIO m) => FileWriter -> L.ByteString -> Action m FileWriter
@@ -167,16 +167,16 @@ writeChunks (FileWriter chunkSize bucket files_id i size acc md5context md5acc)
         if (L.length md5acc_temp < md5BlockLength)
         then (md5context, md5acc_temp)
         else let numBlocks = L.length md5acc_temp `div` md5BlockLength
-                 (current, rest) = L.splitAt (md5BlockLength * numBlocks) md5acc_temp
-             in (md5Update md5context (L.toStrict current), rest)
+                 (current, remainder) = L.splitAt (md5BlockLength * numBlocks) md5acc_temp
+             in (md5Update md5context (L.toStrict current), remainder)
   -- Update chunks
   let size' = (size + L.length chunk)
   let acc_temp = (acc `L.append` chunk)
   if (L.length acc_temp < chunkSize)
     then return (FileWriter chunkSize bucket files_id i size' acc_temp md5context' md5acc')
     else do
-      let (chunk, acc') = L.splitAt chunkSize acc_temp
-      putChunk bucket files_id i chunk
+      let (newChunk, acc') = L.splitAt chunkSize acc_temp
+      putChunk bucket files_id i newChunk
       writeChunks (FileWriter chunkSize bucket files_id (i+1) size' acc' md5context' md5acc') L.empty
 
 sinkFile :: (Monad m, MonadIO m) => Bucket -> Text -> Consumer S.ByteString (Action m) File

Database/MongoDB/Internal/Network.hs

@@ -0,0 +1,52 @@
+-- | Compatibility layer for network package, including newtype 'PortID'
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
+
+module Database.MongoDB.Internal.Network (PortID(..), N.HostName, connectTo) where
+
+
+#if !MIN_VERSION_network(2, 9, 0)
+
+import qualified Network as N
+import System.IO (Handle)
+
+#else
+
+import Control.Exception (bracketOnError)
+import Network.BSD as BSD
+import qualified Network.Socket as N
+import System.IO (Handle, IOMode(ReadWriteMode))
+
+#endif
+
+
+-- | Wraps network's 'PortNumber'
+-- Used to ease compatibility between older and newer network versions.
+newtype PortID = PortNumber N.PortNumber deriving (Enum, Eq, Integral, Num, Ord, Read, Real, Show)
+
+
+#if !MIN_VERSION_network(2, 9, 0)
+
+-- Unwrap our newtype and use network's PortID and connectTo
+connectTo :: N.HostName         -- Hostname
+          -> PortID             -- Port Identifier
+          -> IO Handle          -- Connected Socket
+connectTo hostname (PortNumber port) = N.connectTo hostname (N.PortNumber port)
+
+#else
+
+-- Copied implementation from network 2.8's 'connectTo', but using our 'PortID' newtype.
+-- 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
+        )
+#endif

Database/MongoDB/Internal/Util.hs

@@ -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,26 +12,19 @@ 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')
 
 import qualified Data.ByteString as S
 
-import Control.Monad.Error (MonadError(..), Error(..))
+import Control.Monad.Except (MonadError(..))
 import Control.Monad.Trans (MonadIO, liftIO)
 import Data.Bson
 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
@@ -69,9 +60,12 @@ loop :: Monad m => m (Maybe a) -> m [a]
 -- ^ Repeatedy execute action, collecting results, until it returns Nothing
 loop act = act >>= maybe (return []) (\a -> (a :) `liftM` loop act)
 
-untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b
+untilSuccess :: (MonadError e m) => (a -> m b) -> [a] -> m b
 -- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty.
-untilSuccess = untilSuccess' (strMsg "empty untilSuccess")
+untilSuccess = untilSuccess' (error "empty untilSuccess")
+-- Use 'error' copying behavior in removed 'Control.Monad.Error.Error' instance:
+-- instance Error Failure where strMsg = error
+-- 'fail' is treated the same as a programming 'error'. In other words, don't use it.
 
 untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b
 -- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty

Database/MongoDB/Query.hs

@@ -72,7 +72,6 @@ import Control.Concurrent.MVar.Lifted (MVar, addMVarFinalizer,
 import Control.Applicative ((<$>))
 import Control.Exception (catch)
 import Control.Monad (when, void)
-import Control.Monad.Error (Error(..))
 import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local)
 import Control.Monad.Trans (MonadIO, liftIO)
 import Data.Binary.Put (runPut)
@@ -138,9 +137,6 @@ instance Exception Failure
 type ErrorCode = Int
 -- ^ Error code from getLastError or query failure
 
-instance Error Failure where strMsg = error
--- ^ 'fail' is treated the same as a programming 'error'. In other words, don't use it.
-
 -- | Type of reads and writes to perform
 data AccessMode =
      ReadStaleOk  -- ^ Read-only action, reading stale data from a slave is OK.

Database/MongoDB/Transport/Tls.hs

@@ -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)
@@ -50,7 +50,7 @@ connect host port = bracketOnError (connectTo host port) hClose $ \handle -> do
 
   let params = (TLS.defaultParamsClient host "")
         { TLS.clientSupported = def
-            { TLS.supportedCiphers = TLS.ciphersuite_all}
+            { TLS.supportedCiphers = TLS.ciphersuite_default}
         , TLS.clientHooks = def
             { TLS.onServerCertificate = \_ _ _ _ -> return []}
         }

mongoDB.cabal

@@ -19,6 +19,11 @@ 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>
+  manual: False
+
 Library
   GHC-options:      -Wall
   default-language: Haskell2010
@@ -34,7 +39,6 @@ Library
                     , conduit-extra
                     , mtl >= 2
                     , cryptohash -any
-                    , network -any
                     , parsec -any
                     , random -any
                     , random-shuffle -any
@@ -54,6 +58,14 @@ 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 >= 3.0
+                    , network-bsd >= 2.7 && < 2.9
+
   Exposed-modules:  Database.MongoDB
                     Database.MongoDB.Admin
                     Database.MongoDB.Connection
@@ -61,7 +73,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
@@ -105,7 +118,6 @@ Benchmark bench
                     , containers -any
                     , mtl >= 2
                     , cryptohash -any
-                    , network -any
                     , nonce >= 1.0.5
                     , stm
                     , parsec -any
@@ -116,5 +128,14 @@ Benchmark bench
                     , transformers-base >= 0.4.1
                     , hashtables >= 1.1.2.0
                     , criterion
+
+  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 >= 3.0
+                    , network-bsd >= 2.7 && < 2.9
+
   default-language: Haskell2010
   default-extensions: OverloadedStrings

stack-ghc80.yaml

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

stack-ghc82.yaml

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

stack-ghc84.yaml

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

stack-ghc86-network3.yaml

@@ -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

stack-ghc86.yaml

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