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
This commit is contained in:
commit
33f2aca7b7
13 changed files with 129 additions and 47 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
@ -1,3 +1,4 @@
|
|||
dist/
|
||||
cabal.sandbox.config
|
||||
.cabal-sandbox/
|
||||
.stack-work/
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
52
Database/MongoDB/Internal/Network.hs
Normal file
52
Database/MongoDB/Internal/Network.hs
Normal file
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 []}
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
4
stack-ghc80.yaml
Normal file
4
stack-ghc80.yaml
Normal file
|
@ -0,0 +1,4 @@
|
|||
resolver: lts-9.21
|
||||
flags:
|
||||
mongoDB:
|
||||
_old-network: true
|
4
stack-ghc82.yaml
Normal file
4
stack-ghc82.yaml
Normal file
|
@ -0,0 +1,4 @@
|
|||
resolver: lts-11.22
|
||||
flags:
|
||||
mongoDB:
|
||||
_old-network: true
|
4
stack-ghc84.yaml
Normal file
4
stack-ghc84.yaml
Normal file
|
@ -0,0 +1,4 @@
|
|||
resolver: lts-12.26
|
||||
flags:
|
||||
mongoDB:
|
||||
_old-network: true
|
6
stack-ghc86-network3.yaml
Normal file
6
stack-ghc86-network3.yaml
Normal 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
4
stack-ghc86.yaml
Normal file
|
@ -0,0 +1,4 @@
|
|||
resolver: lts-13.23
|
||||
flags:
|
||||
mongoDB:
|
||||
_old-network: true
|
Loading…
Reference in a new issue