eventstore 0.12.0.0 → 0.13.0.0
raw patch · 12 files changed
+255/−252 lines, 12 filesdep +connectiondep −networkdep ~time
Dependencies added: connection
Dependencies removed: network
Dependency ranges changed: time
Files
- CHANGELOG.markdown +5/−0
- Database/EventStore.hs +12/−2
- Database/EventStore/Internal/Connection.hs +165/−52
- Database/EventStore/Internal/Execution/Production.hs +12/−91
- Database/EventStore/Internal/Packages.hs +0/−73
- Database/EventStore/Internal/Processor.hs +0/−1
- Database/EventStore/Internal/Types.hs +22/−1
- Database/EventStore/Logging.hs +27/−2
- README.md +1/−17
- eventstore.cabal +5/−5
- tests/Tests.hs +3/−0
- tests/integration.hs +3/−8
CHANGELOG.markdown view
@@ -1,3 +1,8 @@+0.13.0.0+--------+* Implement SSL Connection+* Implement `waitConfirmation` function+ 0.12.0.0 -------- * Quit using internal .NET TimeSpan for dotnet-timespan TimeSpan
Database/EventStore.hs view
@@ -18,7 +18,6 @@ Connection , ConnectionType(..) , ConnectionException(..)- , ServerConnectionError(..) , Credentials , Settings(..) , Retry@@ -26,6 +25,7 @@ , keepRetrying , credentials , defaultSettings+ , defaultSSLSettings , connect , shutdown , waitTillClosed@@ -109,6 +109,7 @@ , Subscription , S.Running(..) , S.SubDropReason(..)+ , waitConfirmation -- * Volatile Subscription , S.Regular , subscribe@@ -180,6 +181,7 @@ , (<>) , NonEmpty(..) , nonEmpty+ , TLSSettings ) where --------------------------------------------------------------------------------@@ -192,6 +194,7 @@ import Data.Maybe import Data.Monoid ((<>)) import Data.Typeable+import Network.Connection (TLSSettings) -------------------------------------------------------------------------------- import Control.Concurrent.Async@@ -200,7 +203,7 @@ import Data.UUID ---------------------------------------------------------------------------------import Database.EventStore.Internal.Connection hiding (Connection)+import Database.EventStore.Internal.Connection import Database.EventStore.Internal.Discovery import qualified Database.EventStore.Internal.Manager.Subscription as S import Database.EventStore.Internal.Manager.Subscription.Message@@ -384,6 +387,13 @@ -- | Non blocking version of 'nextEvent'. nextEventMaybe :: Subscription a -> IO (Maybe ResolvedEvent) nextEventMaybe = atomically . _nextEventMaybe++--------------------------------------------------------------------------------+-- | Waits until the `Subscription` has been confirmed.+waitConfirmation :: Subscription a -> IO ()+waitConfirmation s = atomically $ do+ _ <- readTMVar $ _subRun s+ return () -------------------------------------------------------------------------------- _nextEventMaybe :: Subscription a -> STM (Maybe ResolvedEvent)
Database/EventStore/Internal/Connection.hs view
@@ -14,9 +14,8 @@ -- -------------------------------------------------------------------------------- module Database.EventStore.Internal.Connection- ( Connection+ ( InternalConnection , ConnectionException(..)- , HostName , connUUID , connClose , connSend@@ -30,14 +29,16 @@ import Control.Concurrent.STM import Control.Exception import qualified Data.ByteString as B+import Data.Foldable (for_) import Data.IORef import Data.Typeable-import System.IO+import Text.Printf --------------------------------------------------------------------------------+import Data.Serialize import Data.UUID import Data.UUID.V4-import Network+import Network.Connection -------------------------------------------------------------------------------- import Database.EventStore.Internal.Discovery@@ -52,6 +53,10 @@ -- ^ The max reconnection attempt threshold has been reached. | ClosedConnection -- ^ Use of a close 'Connection'.+ | WrongPackageFraming+ -- ^ TCP package sent by the server had a wrong framing.+ | PackageParsingError String+ -- ^ Server sent a malformed TCP package. deriving (Show, Typeable) --------------------------------------------------------------------------------@@ -61,60 +66,62 @@ data In a where Id :: In UUID Close :: In ()- Send :: B.ByteString -> In ()- Recv :: Int -> In B.ByteString+ Send :: Package -> In ()+ Recv :: In Package -------------------------------------------------------------------------------- -- | Internal representation of a connection with the server.-data Connection =- Connection- { _var :: TMVar State- , _last :: IORef (Maybe EndPoint)- , _disc :: Discovery- , _setts :: Settings+data InternalConnection =+ InternalConnection+ { _var :: TMVar State+ , _last :: IORef (Maybe EndPoint)+ , _disc :: Discovery+ , _setts :: Settings+ , _ctx :: ConnectionContext } -------------------------------------------------------------------------------- data State = Offline- | Online !UUID !Handle+ | Online !UUID !Connection | Closed ----------------------------------------------------------------------------------- | Creates a new 'Connection'.-newConnection :: Settings -> Discovery -> IO Connection+-- | Creates a new 'InternalConnection'.+newConnection :: Settings -> Discovery -> IO InternalConnection newConnection setts disc = do+ ctx <- initConnectionContext var <- newTMVarIO Offline ref <- newIORef Nothing- return $ Connection var ref disc setts+ return $ InternalConnection var ref disc setts ctx ----------------------------------------------------------------------------------- | Gets current 'Connection' 'UUID'.-connUUID :: Connection -> IO UUID+-- | Gets current 'InternalConnection' 'UUID'.+connUUID :: InternalConnection -> IO UUID connUUID conn = execute conn Id ----------------------------------------------------------------------------------- | Closes the 'Connection'. It will not retry to reconnect after that call. it--- means a new 'Connection' has to be created. 'ClosedConnection' exception--- will be raised if the same 'Connection' object is used after a 'connClose'--- call.-connClose :: Connection -> IO ()+-- | Closes the 'InternalConnection'. It will not retry to reconnect after that+-- call. it means a new 'InternalConnection' has to be created.+-- 'ClosedConnection' exception will be raised if the same+-- 'InternalConnection' object is used after a 'connClose' call.+connClose :: InternalConnection -> IO () connClose conn = execute conn Close ----------------------------------------------------------------------------------- | Writes 'ByteString' into the buffer.-connSend :: Connection -> B.ByteString -> IO ()-connSend conn b = execute conn (Send b)+-- | Sends 'Package' to the server.+connSend :: InternalConnection -> Package -> IO ()+connSend conn pkg = execute conn (Send pkg) -------------------------------------------------------------------------------- -- | Asks the requested amount of bytes from the 'handle'.-connRecv :: Connection -> Int -> IO B.ByteString-connRecv conn i = execute conn (Recv i)+connRecv :: InternalConnection -> IO Package+connRecv conn = execute conn Recv -------------------------------------------------------------------------------- -- | Returns True if the connection is in closed state.-connIsClosed :: Connection -> STM Bool-connIsClosed Connection{..} = do+connIsClosed :: InternalConnection -> STM Bool+connIsClosed InternalConnection{..} = do r <- readTMVar _var case r of Closed -> return True@@ -123,21 +130,21 @@ -------------------------------------------------------------------------------- -- | Main connection logic. It will automatically reconnect to the server when -- a exception occured while the 'Handle' is accessed.-execute :: forall a. Connection -> In a -> IO a-execute Connection{..} i = do+execute :: forall a. InternalConnection -> In a -> IO a+execute InternalConnection{..} i = do res <- atomically $ do s <- takeTMVar _var case s of Offline -> return $ Right Nothing- Online u hdl -> return $ Right $ Just (u, hdl)+ Online u con -> return $ Right $ Just (u, con) Closed -> return $ Left ClosedConnection case i of Close -> case res of Left _ -> atomically $ putTMVar _var Closed- Right Nothing -> atomically $ putTMVar _var Closed- Right (Just (_, h)) -> do- hClose h+ Right Nothing -> atomically $ putTMVar _var Closed+ Right (Just (_, con)) -> do+ connectionClose con atomically $ putTMVar _var Closed other -> case res of@@ -146,7 +153,7 @@ throwIO e Right alt -> do sres <- case alt of- Nothing -> newState _setts _last _disc+ Nothing -> newState _setts _ctx _last _disc Just (u, h) -> return $ Right $ Online u h case sres of Left e -> do@@ -154,19 +161,20 @@ throwIO e Right s -> do atomically $ putTMVar _var s- let Online u h = s+ let Online u con = s case other of Id -> return u- Send b -> B.hPut h b >> hFlush h- Recv siz -> B.hGet h siz+ Send pkg -> send con pkg+ Recv -> recv con Close -> error "impossible execute" -------------------------------------------------------------------------------- newState :: Settings+ -> ConnectionContext -> IORef (Maybe EndPoint) -> Discovery -> IO (Either ConnectionException State)-newState sett ref disc =+newState sett ctx ref disc = case s_retry sett of AtMost n -> let loop i = do@@ -184,7 +192,7 @@ Just ept -> do let host = endPointIp ept port = endPointPort ept- st <- connect sett host port+ st <- connect sett ctx host port writeIORef ref (Just ept) return $ Right st catch action $ \(_ :: SomeException) -> do@@ -206,7 +214,7 @@ Just ept -> do let host = endPointIp ept port = endPointPort ept- st <- connect sett host port+ st <- connect sett ctx host port writeIORef ref (Just ept) return $ Right st catch action $ \(_ :: SomeException) ->@@ -220,15 +228,120 @@ secs = 1000000 ---------------------------------------------------------------------------------connect :: Settings -> HostName -> Int -> IO State-connect sett host port = do- hdl <- connectTo host (PortNumber $ fromIntegral port)- hSetBuffering hdl NoBuffering+connect :: Settings -> ConnectionContext -> String -> Int -> IO State+connect sett ctx host port = do+ let params = ConnectionParams host (fromIntegral port) (s_ssl sett) Nothing+ conn <- connectTo ctx params uuid <- nextRandom- regularConnection sett hdl uuid+ _settingsLog sett (Info $ Connected uuid)+ return $ Online uuid conn ---------------------------------------------------------------------------------regularConnection :: Settings -> Handle -> UUID -> IO State-regularConnection sett h uuid = do- _settingsLog sett (Info $ Connected uuid)- return $ Online uuid h+-- Binary operations+--------------------------------------------------------------------------------+recv :: Connection -> IO Package+recv con = do+ header_bs <- connectionGet con 4+ case runGet getLengthPrefix header_bs of+ Left _ -> throwIO WrongPackageFraming+ Right length_prefix -> do+ bs <- connectionGet con length_prefix+ case runGet getPackage bs of+ Left e -> throwIO $ PackageParsingError e+ Right pkg -> return pkg++--------------------------------------------------------------------------------+send :: Connection -> Package -> IO ()+send con pkg = connectionPut con bs+ where+ bs = runPut $ putPackage pkg++--------------------------------------------------------------------------------+-- Serialization+--------------------------------------------------------------------------------+-- | Serializes a 'Package' into raw bytes.+putPackage :: Package -> Put+putPackage pack = do+ putWord32le length_prefix+ putWord8 (packageCmd pack)+ putWord8 flag_word8+ putLazyByteString corr_bytes+ for_ cred_m $ \(Credentials login passw) -> do+ putWord8 $ fromIntegral $ B.length login+ putByteString login+ putWord8 $ fromIntegral $ B.length passw+ putByteString passw+ putByteString pack_data+ where+ pack_data = packageData pack+ cred_len = maybe 0 credSize cred_m+ length_prefix = fromIntegral (B.length pack_data + mandatorySize + cred_len)+ cred_m = packageCred pack+ flag_word8 = maybe 0x00 (const 0x01) cred_m+ corr_bytes = toByteString $ packageCorrelation pack++--------------------------------------------------------------------------------+credSize :: Credentials -> Int+credSize (Credentials login passw) = B.length login + B.length passw + 2++--------------------------------------------------------------------------------+-- | The minimun size a 'Package' should have. It's basically a command byte,+-- correlation bytes ('UUID') and a 'Flag' byte.+mandatorySize :: Int+mandatorySize = 18++--------------------------------------------------------------------------------+-- Parsing+--------------------------------------------------------------------------------+getLengthPrefix :: Get Int+getLengthPrefix = fmap fromIntegral getWord32le++--------------------------------------------------------------------------------+getPackage :: Get Package+getPackage = do+ cmd <- getWord8+ flg <- getFlag+ col <- getUUID+ cred <- getCredentials flg+ rest <- remaining+ dta <- getBytes rest++ let pkg = Package+ { packageCmd = cmd+ , packageCorrelation = col+ , packageData = dta+ , packageCred = cred+ }++ return pkg++--------------------------------------------------------------------------------+getFlag :: Get Flag+getFlag = do+ wd <- getWord8+ case wd of+ 0x00 -> return None+ 0x01 -> return Authenticated+ _ -> fail $ printf "TCP: Unhandled flag value 0x%x" wd++--------------------------------------------------------------------------------+getCredEntryLength :: Get Int+getCredEntryLength = fmap fromIntegral getWord8++--------------------------------------------------------------------------------+getCredentials :: Flag -> Get (Maybe Credentials)+getCredentials None = return Nothing+getCredentials _ = do+ loginLen <- getCredEntryLength+ login <- getBytes loginLen+ passwLen <- getCredEntryLength+ passw <- getBytes passwLen+ return $ Just $ credentials login passw++--------------------------------------------------------------------------------+getUUID :: Get UUID+getUUID = do+ bs <- getLazyByteString 16+ case fromByteString bs of+ Just uuid -> return uuid+ _ -> fail "TCP: Wrong UUID format"
Database/EventStore/Internal/Execution/Production.hs view
@@ -24,7 +24,6 @@ -------------------------------------------------------------------------------- module Database.EventStore.Internal.Execution.Production ( Production- , ServerConnectionError(..) , newExecutionModel , pushOperation , shutdownExecutionModel@@ -49,12 +48,8 @@ import Data.IORef import Data.Int import Data.Foldable-import Data.Typeable-import Text.Printf ---------------------------------------------------------------------------------import Data.Serialize.Get hiding (Done)-import Data.Serialize.Put import Data.Text import Data.UUID @@ -70,7 +65,6 @@ , abort ) import Database.EventStore.Internal.Operation hiding (retry)-import Database.EventStore.Internal.Packages import Database.EventStore.Internal.Processor import Database.EventStore.Internal.Types import Database.EventStore.Logging@@ -83,18 +77,6 @@ deriving Show ----------------------------------------------------------------------------------- | Raised when the server responded in an unexpected way.-data ServerConnectionError- = WrongPackageFraming- -- ^ TCP package sent by the server had a wrong framing.- | PackageParsingError String- -- ^ Server sent a malformed TCP package.- deriving (Show, Typeable)-----------------------------------------------------------------------------------instance Exception ServerConnectionError---------------------------------------------------------------------------------- -- | Used to determine if we hit the end of the queue. data Slot a = Slot !a | End @@ -190,7 +172,7 @@ -- ^ Holds manager thread state. , _nextSubmit :: TVar (Msg -> IO ()) -- ^ Indicates the action to call in order to push new commands.- , _connRef :: IORef Connection+ , _connRef :: IORef InternalConnection -- ^ Connection to the server. , _disposed :: TMVar () -- ^ Indicates when the production execution model has been shutdown and@@ -332,88 +314,27 @@ updateProc p s = s { _proc = p } ----------------------------------------------------------------------------------- | Reader thread. Keeps reading 'Package' from the connection.----------------------------------------------------------------------------------reader :: Settings -> CycleQueue Msg -> Connection -> IO ()+-- | Reader thread. Keeps reading 'Package' from the server.+reader :: Settings -> CycleQueue Msg -> InternalConnection -> IO () reader sett queue c = forever $ do- header_bs <- connRecv c 4- case runGet getLengthPrefix header_bs of- Left _ -> throwIO WrongPackageFraming- Right length_prefix -> connRecv c length_prefix >>= parsePackage- where- parsePackage bs =- case runGet getPackage bs of- Left e -> throwIO $ PackageParsingError e- Right pkg -> do- atomically $ writeCycleQueue queue (Arrived pkg)- let cmd = packageCmd pkg- uuid = packageCorrelation pkg- _settingsLog sett $ Info $ PackageReceived cmd uuid+ pkg <- connRecv c+ let cmd = packageCmd pkg+ uuid = packageCorrelation pkg + atomically $ writeCycleQueue queue (Arrived pkg)+ _settingsLog sett $ Info $ PackageReceived cmd uuid+ -------------------------------------------------------------------------------- -- | Writer thread, writes incoming 'Package's ---------------------------------------------------------------------------------writer :: Settings -> CycleQueue Package -> Connection -> IO ()+writer :: Settings -> CycleQueue Package -> InternalConnection -> IO () writer setts pkg_queue conn = forever $ do pkg <- atomically $ readCycleQueue pkg_queue- connSend conn $ runPut $ putPackage pkg+ connSend conn pkg let cmd = packageCmd pkg uuid = packageCorrelation pkg- _settingsLog setts $ Info $ PackageSent cmd uuid ----------------------------------------------------------------------------------getLengthPrefix :: Get Int-getLengthPrefix = fmap fromIntegral getWord32le-----------------------------------------------------------------------------------getPackage :: Get Package-getPackage = do- cmd <- getWord8- flg <- getFlag- col <- getUUID- cred <- getCredentials flg- rest <- remaining- dta <- getBytes rest-- let pkg = Package- { packageCmd = cmd- , packageCorrelation = col- , packageData = dta- , packageCred = cred- }-- return pkg-----------------------------------------------------------------------------------getFlag :: Get Flag-getFlag = do- wd <- getWord8- case wd of- 0x00 -> return None- 0x01 -> return Authenticated- _ -> fail $ printf "TCP: Unhandled flag value 0x%x" wd-----------------------------------------------------------------------------------getCredEntryLength :: Get Int-getCredEntryLength = fmap fromIntegral getWord8-----------------------------------------------------------------------------------getCredentials :: Flag -> Get (Maybe Credentials)-getCredentials None = return Nothing-getCredentials _ = do- loginLen <- getCredEntryLength- login <- getBytes loginLen- passwLen <- getCredEntryLength- passw <- getBytes passwLen- return $ Just $ credentials login passw-----------------------------------------------------------------------------------getUUID :: Get UUID-getUUID = do- bs <- getLazyByteString 16- case fromByteString bs of- Just uuid -> return uuid- _ -> fail "TCP: Wrong UUID format"+ _settingsLog setts $ Info $ PackageSent cmd uuid -------------------------------------------------------------------------------- -- Runner thread. Keeps running job comming from the Manager thread.
− Database/EventStore/Internal/Packages.hs
@@ -1,73 +0,0 @@------------------------------------------------------------------------------------ |--- Module : Database.EventStore.Internal.Packages--- Copyright : (C) 2014 Yorick Laupa--- License : (see the file LICENSE)------ Maintainer : Yorick Laupa <yo.eight@gmail.com>--- Stability : provisional--- Portability : non-portable-------------------------------------------------------------------------------------module Database.EventStore.Internal.Packages- ( -- * Package Smart Contructors- heartbeatResponsePackage- -- * Cereal Put- , putPackage- ) where-----------------------------------------------------------------------------------import qualified Data.ByteString as B-import Data.Foldable (for_)-----------------------------------------------------------------------------------import Data.Serialize.Put-import Data.UUID-----------------------------------------------------------------------------------import Database.EventStore.Internal.Types------------------------------------------------------------------------------------- Encode------------------------------------------------------------------------------------ | Constructs a heartbeat response given the 'UUID' of heartbeat request.-heartbeatResponsePackage :: UUID -> Package-heartbeatResponsePackage uuid =- Package- { packageCmd = 0x02- , packageCorrelation = uuid- , packageData = B.empty- , packageCred = Nothing- }------------------------------------------------------------------------------------- | Serializes a 'Package' into raw bytes.-putPackage :: Package -> Put-putPackage pack = do- putWord32le length_prefix- putWord8 (packageCmd pack)- putWord8 flag_word8- putLazyByteString corr_bytes- for_ cred_m $ \(Credentials login passw) -> do- putWord8 $ fromIntegral $ B.length login- putByteString login- putWord8 $ fromIntegral $ B.length passw- putByteString passw- putByteString pack_data- where- pack_data = packageData pack- cred_len = maybe 0 credSize cred_m- length_prefix = fromIntegral (B.length pack_data + mandatorySize + cred_len)- cred_m = packageCred pack- flag_word8 = maybe 0x00 (const 0x01) cred_m- corr_bytes = toByteString $ packageCorrelation pack-----------------------------------------------------------------------------------credSize :: Credentials -> Int-credSize (Credentials login passw) = B.length login + B.length passw + 2------------------------------------------------------------------------------------- | The minimun size a 'Package' should have. It's basically a command byte,--- correlation bytes ('UUID') and a 'Flag' byte.-mandatorySize :: Int-mandatorySize = 18
Database/EventStore/Internal/Processor.hs view
@@ -40,7 +40,6 @@ -------------------------------------------------------------------------------- import Database.EventStore.Internal.Generator import Database.EventStore.Internal.Operation hiding (SM(..))-import Database.EventStore.Internal.Packages import Database.EventStore.Internal.Types --------------------------------------------------------------------------------
Database/EventStore/Internal/Types.hs view
@@ -44,6 +44,7 @@ import Data.Time import Data.Time.Clock.POSIX import Data.UUID (UUID, fromByteString, toByteString)+import Network.Connection (TLSSettings) -------------------------------------------------------------------------------- import Database.EventStore.Logging@@ -339,8 +340,10 @@ -------------------------------------------------------------------------------- -- | Converts a raw 'Int64' into an 'UTCTime'+-- fromIntegral should be a no-op in GHC and allow eventstore to compile w GHCJS+-- GHCJS maps CTime to Int32 (cf PR https://github.com/YoEight/eventstore/pull/47) toUTC :: Int64 -> UTCTime-toUTC = posixSecondsToUTCTime . (/1000) . realToFrac . CTime+toUTC = posixSecondsToUTCTime . (/1000) . realToFrac . CTime . fromIntegral -------------------------------------------------------------------------------- -- | Constructs a 'RecordedEvent' from an 'EventRecord'.@@ -491,6 +494,17 @@ deriving Show --------------------------------------------------------------------------------+-- | Constructs a heartbeat response given the 'UUID' of heartbeat request.+heartbeatResponsePackage :: UUID -> Package+heartbeatResponsePackage uuid =+ Package+ { packageCmd = 0x02+ , packageCorrelation = uuid+ , packageData = ""+ , packageCred = Nothing+ }++-------------------------------------------------------------------------------- -- Settings -------------------------------------------------------------------------------- -- | Represents reconnection strategy.@@ -521,6 +535,7 @@ , s_retry :: Retry , s_reconnect_delay_secs :: Int -- ^ In seconds , s_logger :: Maybe (Log -> IO ())+ , s_ssl :: Maybe TLSSettings } --------------------------------------------------------------------------------@@ -541,7 +556,13 @@ , s_retry = atMost 3 , s_reconnect_delay_secs = 3 , s_logger = Nothing+ , s_ssl = Nothing }++--------------------------------------------------------------------------------+-- | Default SSL settings based on 'defaultSettings'.+defaultSSLSettings :: TLSSettings -> Settings+defaultSSLSettings tls = defaultSettings { s_ssl = Just tls } -------------------------------------------------------------------------------- -- | Triggers the logger callback if it has been set.
Database/EventStore/Logging.hs view
@@ -9,11 +9,16 @@ -- Portability : non-portable -- ---------------------------------------------------------------------------------module Database.EventStore.Logging where+module Database.EventStore.Logging+ ( Log(..)+ , ErrorMessage(..)+ , InfoMessage(..)+ ) where -------------------------------------------------------------------------------- import Control.Exception import Data.Word+import Numeric -------------------------------------------------------------------------------- import Data.UUID@@ -44,4 +49,24 @@ -- ^ Indicates a package has been sent. | PackageReceived Word8 UUID -- ^ Indicates the client's received a package from the server.- deriving Show++--------------------------------------------------------------------------------+instance Show InfoMessage where+ show (Connecting i) =+ "Connexion attempt n°" ++ show i+ show (ConnectionClosed u) =+ "Connection [" ++ show u ++ "] closed"+ show (Connected u) =+ "Connected [" ++ show u ++ "]"+ show (Disconnected u) =+ "Disconnected [" ++ show u ++ "]"+ show (PackageSent cmd u) =+ "Package send 0x" ++ padding (showHex cmd "") ++ " [" ++ show u ++ "]"+ show (PackageReceived cmd u) =+ "Package received 0x" +++ padding (showHex cmd "") ++ " [" ++ show u ++ "]"++--------------------------------------------------------------------------------+padding :: String -> String+padding [x] = ['0',x]+padding xs = xs
README.md view
@@ -4,23 +4,7 @@ [](https://gitter.im/YoEight/eventstore?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [](https://travis-ci.org/YoEight/eventstore) -That driver supports:-- * Read event(s) from regular or $all stream (forward or backward).- * Write event(s) to regular stream.- * Delete regular stream.- * Transactional writes to regular stream.- * Volatile subscriptions to regular or $all stream.- * Catch-up subscriptions to regular or $all stream.- * Competing consumers (a.k.a Persistent subscriptions) to regular stream.- * Authenticated communication with EventStore server.- * Read stream metadata (ACL and custom properties).- * Write stream metadata (ACL and custom properties).- * Cluster Connection.--Not implemented yet-===================- * Secured connection with the server (SSL).+That driver supports 100% of EventStore features ! Requirements ============
eventstore.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.12.0.0+version: 0.13.0.0 tested-with: GHC >= 7.8.3 && < 7.11 @@ -67,7 +67,6 @@ Database.EventStore.Internal.Execution.Production Database.EventStore.Internal.Generator Database.EventStore.Internal.Operation- Database.EventStore.Internal.Packages Database.EventStore.Internal.Processor Database.EventStore.Internal.Stream Database.EventStore.Internal.Types@@ -105,11 +104,10 @@ , bytestring >=0.10.4 && <0.11 , cereal >=0.4 && <0.6 , containers >=0.5 && <0.6- , network ==2.6.* , protobuf >=0.2 && <0.3 , random ==1.* , text >=1.1.1 && <1.3- , time >=1.4 && <1.6+ , time >=1.4 && <1.7 , uuid ==1.3.* , unordered-containers , stm@@ -118,6 +116,7 @@ , array , http-client , dotnet-timespan+ , connection ==0.2.* -- Directories containing source files. -- hs-source-dirs:@@ -145,4 +144,5 @@ text, stm, time,- dotnet-timespan+ dotnet-timespan,+ connection
tests/Tests.hs view
@@ -170,6 +170,7 @@ ] evts = fmap (createEvent "foo" Nothing . withJson) jss sub <- subscribe conn "subscribe-test" False+ _ <- waitConfirmation sub _ <- sendEvents conn "subscribe-test" anyVersion evts >>= wait let loop 3 = return [] loop i = do@@ -201,6 +202,7 @@ evts2 = fmap (createEvent "foo" Nothing . withJson) jss2 _ <- sendEvents conn "subscribe-from-test" anyVersion evts >>= wait sub <- subscribeFrom conn "subscribe-from-test" False Nothing (Just 1)+ _ <- waitConfirmation sub _ <- sendEvents conn "subscribe-from-test" anyVersion evts2 >>= wait let loop [] = do@@ -285,6 +287,7 @@ _ <- createPersistentSubscription conn "group" "connect-sub" def >>= wait _ <- sendEvents conn "connect-sub" anyVersion evts >>= wait sub <- connectToPersistentSubscription conn "group" "connect-sub" 1+ _ <- waitConfirmation sub r <- nextEvent sub case resolvedEventDataAsJson r of Just js_evt -> assertEqual "event 1 should match" js1 js_evt
tests/integration.hs view
@@ -17,7 +17,6 @@ import Data.Time import Database.EventStore import Database.EventStore.Logging-import Numeric import Test.Tasty import Test.Tasty.Ingredients.Basic @@ -30,6 +29,7 @@ let setts = defaultSettings { s_credentials = Just $ credentials "admin" "changeit" , s_reconnect_delay_secs = 1+ , s_logger = Nothing } conn <- connect setts (Static "127.0.0.1" 1113) let tree = tests conn@@ -46,13 +46,8 @@ where showLog (Info m) = do putStr "[INFO] "- case m of- PackageSent cmd uuid ->- putStrLn $ "Sent 0x" ++ showHex cmd "" ++ " over " ++ show uuid- PackageReceived cmd uuid ->- putStrLn $ "Received 0x" ++ showHex cmd "" ++ " over "- ++ show uuid- _ -> print m+ print m+ showLog (Error m) = do putStr "!!! ERROR !!! " print m