eventstore 0.9.1.3 → 0.10.0.0

raw patch · 7 files changed

+140/−90 lines, 7 filesdep −attoparsecPVP ok

version bump matches the API change (PVP)

Dependencies removed: attoparsec

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +9/−0
• Database/EventStore.hs +6/−0
• Database/EventStore/Internal/Manager/Subscription/Message.hs +20/−6
• Database/EventStore/Internal/TimeSpan.hs +49/−68
• Database/EventStore/Internal/Types.hs +38/−14
• eventstore.cabal +1/−2
• tests/Tests.hs +17/−0

@@ -1,3 +1,12 @@+0.10.0.0+--------+* Fix $maxAge and $cacheControl TimeSpan metadata serialization.+* Fix `timeSpanFrom*` functions.+* Implement `timeSpanTotalDays`, `timeSpanTotalHours`, `timeSpanTotalMinutes` and `timeSpanTotalSeconds`.+* Add `withBinary` and `withBinaryAndMetadata`.+* Remove useless `TimeSpan` `ToJSON` and `FromJSON` instances.+* Drop `attoparsec` dependency.+ 0.9.1.3 ------- * Increase cereal upper bound to <0.6

@@ -34,6 +34,8 @@     , createEvent     , withJson     , withJsonAndMetadata+    , withBinary+    , withBinaryAndMetadata      -- * Read Operations     , StreamMetadataResult(..)     , readEvent@@ -96,6 +98,10 @@     , timeSpanFromMinutes     , timeSpanFromHours     , timeSpanFromDays+    , timeSpanTotalDays+    , timeSpanTotalHours+    , timeSpanTotalMinutes+    , timeSpanTotalSeconds     , timeSpanTotalMillis       -- * Transaction     , Transaction

@@ -132,14 +132,22 @@     , cpsStreamId          = putField stream     , cpsResolveLinkTos    = putField $ psSettingsResolveLinkTos sett     , cpsStartFrom         = putField $ psSettingsStartFrom sett-    , cpsMsgTimeout        = putField $ ms $ psSettingsMsgTimeout sett+    , cpsMsgTimeout        = putField+                             . fromIntegral+                             . (truncate :: Double -> Int64)+                             . timeSpanTotalMillis+                             $ psSettingsMsgTimeout sett     , cpsRecordStats       = putField $ psSettingsExtraStats sett     , cpsLiveBufSize       = putField $ psSettingsLiveBufSize sett     , cpsReadBatchSize     = putField $ psSettingsReadBatchSize sett     , cpsBufSize           = putField $ psSettingsHistoryBufSize sett     , cpsMaxRetryCount     = putField $ psSettingsMaxRetryCount sett     , cpsPreferRoundRobin  = putField False-    , cpsChkPtAfterTime    = putField $ ms $ psSettingsCheckPointAfter sett+    , cpsChkPtAfterTime    = putField+                             . fromIntegral+                             . (truncate :: Double -> Int64)+                             . timeSpanTotalMillis+                             $ psSettingsCheckPointAfter sett     , cpsChkPtMaxCount     = putField $ psSettingsMaxCheckPointCount sett     , cpsChkPtMinCount     = putField $ psSettingsMinCheckPointCount sett     , cpsSubMaxCount       = putField $ psSettingsMaxSubsCount sett@@ -147,7 +155,6 @@     }   where     strText = strategyText $ psSettingsNamedConsumerStrategy sett-    ms      = fromIntegral . timeSpanTotalMillis  -------------------------------------------------------------------------------- instance Encode CreatePersistentSubscription@@ -246,14 +253,22 @@     , upsStreamId          = putField stream     , upsResolveLinkTos    = putField $ psSettingsResolveLinkTos sett     , upsStartFrom         = putField $ psSettingsStartFrom sett-    , upsMsgTimeout        = putField $ ms $ psSettingsMsgTimeout sett+    , upsMsgTimeout        = putField+                             . fromIntegral+                             . (truncate :: Double -> Int64)+                             . timeSpanTotalMillis+                             $ psSettingsMsgTimeout sett     , upsRecordStats       = putField $ psSettingsExtraStats sett     , upsLiveBufSize       = putField $ psSettingsLiveBufSize sett     , upsReadBatchSize     = putField $ psSettingsReadBatchSize sett     , upsBufSize           = putField $ psSettingsHistoryBufSize sett     , upsMaxRetryCount     = putField $ psSettingsMaxRetryCount sett     , upsPreferRoundRobin  = putField False-    , upsChkPtAfterTime    = putField $ ms $ psSettingsCheckPointAfter sett+    , upsChkPtAfterTime    = putField+                             . fromIntegral+                             . (truncate :: Double -> Int64)+                             . timeSpanTotalMillis+                             $ psSettingsCheckPointAfter sett     , upsChkPtMaxCount     = putField $ psSettingsMaxCheckPointCount sett     , upsChkPtMinCount     = putField $ psSettingsMinCheckPointCount sett     , upsSubMaxCount       = putField $ psSettingsMaxSubsCount sett@@ -261,7 +276,6 @@     }   where     strText = strategyText $ psSettingsNamedConsumerStrategy sett-    ms      = fromIntegral . timeSpanTotalMillis  -------------------------------------------------------------------------------- instance Encode UpdatePersistentSubscription

@@ -27,18 +27,19 @@     , timeSpanFromMinutes     , timeSpanFromHours     , timeSpanFromDays+    , timeSpanTotalDays+    , timeSpanTotalHours+    , timeSpanTotalMinutes+    , timeSpanTotalSeconds     , timeSpanTotalMillis     ) where  ---------------------------------------------------------------------------------import Control.Applicative import Data.Int import Data.Monoid import Prelude  ---------------------------------------------------------------------------------import Data.Aeson-import Data.Attoparsec.Text import Data.Text.Lazy (unpack) import Data.Text.Lazy.Builder @@ -51,66 +52,6 @@     show = unpack . toLazyText . timeSpanBuilder  ---------------------------------------------------------------------------------instance ToJSON TimeSpan where-    toJSON = toJSON . toLazyText . timeSpanBuilder-----------------------------------------------------------------------------------instance FromJSON TimeSpan where-    parseJSON (String s) =-        case parseOnly parseTimeSpan s of-            Left e   -> fail e-            Right ts -> return ts-    parseJSON _ = empty------------------------------------------------------------------------------------- | Determines weither a number is positive or negative.-parseFormatLiteral :: Parser FormatLiteral-parseFormatLiteral = do-    c <- peekChar'-    case c of-        '-' -> fmap (const Negative) anyChar-        _   -> return Positive-----------------------------------------------------------------------------------parseDays :: Parser Int64-parseDays = option 0 (decimal <* char '.')-----------------------------------------------------------------------------------parseHours :: Parser Int64-parseHours = decimal <* char ':'-----------------------------------------------------------------------------------parseMinutes :: Parser Int64-parseMinutes = parseHours-----------------------------------------------------------------------------------parseSeconds :: Parser Int64-parseSeconds = decimal-----------------------------------------------------------------------------------parseMillis :: Parser Int64-parseMillis = option 0 (char '.' >> decimal)-----------------------------------------------------------------------------------parseBaseTimeSpan :: Parser TimeSpan-parseBaseTimeSpan =-    timeSpanDaysHoursMinsSecsMillis <$>-    parseDays                       <*>-    parseHours                      <*>-    parseMinutes                    <*>-    parseSeconds                    <*>-    parseMillis-----------------------------------------------------------------------------------parseTimeSpan :: Parser TimeSpan-parseTimeSpan = do-    lit             <- parseFormatLiteral-    ts@(TimeSpan i) <- parseBaseTimeSpan-    case lit of-        Negative -> return $ TimeSpan $ negate i-        Positive -> return ts---------------------------------------------------------------------------------- millisPerSecond :: Int64 millisPerSecond = 1000 @@ -147,6 +88,22 @@ ticksPerDay = ticksPerHour * 24  --------------------------------------------------------------------------------+daysPerTick :: Double+daysPerTick = 1 / (realToFrac ticksPerDay)++--------------------------------------------------------------------------------+hoursPerTick :: Double+hoursPerTick = 1 / (realToFrac ticksPerHour)++--------------------------------------------------------------------------------+minutesPerTick :: Double+minutesPerTick = 1 / (realToFrac ticksPerMinute)++--------------------------------------------------------------------------------+secondsPerTick :: Double+secondsPerTick = 1 / (realToFrac ticksPerSecond)++-------------------------------------------------------------------------------- millisPerTick :: Double millisPerTick = 1 / (realToFrac ticksPerMillisecond) @@ -274,13 +231,37 @@  -------------------------------------------------------------------------------- -- | Gets the value of the current 'TimeSpan' structure expressed in whole and+--   fractional days.+timeSpanTotalDays :: TimeSpan -> Double+timeSpanTotalDays (TimeSpan i) = (realToFrac i) * daysPerTick++--------------------------------------------------------------------------------+-- | Gets the value of the current 'TimeSpan' structure expressed in whole and+--   fractional hours.+timeSpanTotalHours :: TimeSpan -> Double+timeSpanTotalHours (TimeSpan i) = (realToFrac i) * hoursPerTick++--------------------------------------------------------------------------------+-- | Gets the value of the current 'TimeSpan' structure expressed in whole and+--   fractional minutes.+timeSpanTotalMinutes :: TimeSpan -> Double+timeSpanTotalMinutes (TimeSpan i) = (realToFrac i) * minutesPerTick++--------------------------------------------------------------------------------+-- | Gets the value of the current 'TimeSpan' structure expressed in whole and+--   fractional seconds.+timeSpanTotalSeconds :: TimeSpan -> Double+timeSpanTotalSeconds (TimeSpan i) = (realToFrac i) * secondsPerTick++--------------------------------------------------------------------------------+-- | Gets the value of the current 'TimeSpan' structure expressed in whole and --   fractional milliseconds.-timeSpanTotalMillis :: TimeSpan -> Int64+timeSpanTotalMillis :: TimeSpan -> Double timeSpanTotalMillis (TimeSpan i) =     let tmp = (realToFrac i) * millisPerTick in-    if tmp > (realToFrac maxMillis) then maxMillis-    else if tmp < (realToFrac minMillis) then minMillis-         else truncate tmp+    if tmp > (realToFrac maxMillis) then realToFrac maxMillis+    else if tmp < (realToFrac minMillis) then realToFrac minMillis+         else tmp  -------------------------------------------------------------------------------- data FormatLiteral = Positive | Negative@@ -353,6 +334,6 @@ interval :: Double -> Int64 -> TimeSpan interval value scale =     let tmp    = value * (realToFrac scale)-        millis = tmp * (if value >= 0 then 0.5 else (-0.5))+        millis = tmp + (if value >= 0 then 0.5 else (-0.5))         res    = truncate (millis * (realToFrac ticksPerMillisecond)) in     TimeSpan res

@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DataKinds          #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | -- Module : Database.EventStore.Internal.Types@@ -87,38 +88,53 @@ -- | Holds event data. data EventData     = Json A.Value (Maybe A.Value)+    | Binary ByteString (Maybe ByteString)     deriving (Eq, Show)  -------------------------------------------------------------------------------- -- | Maps 'Event' inner data type to an 'Int32' understandable by the server. eventDataType :: EventData -> Int32 eventDataType (Json _ _) = 1+eventDataType _          = 0  ----------------------------------------------------------------------------------- | Maps 'Event' inner metadata type to an 'Int32' understandable by the server.+-- | Maps 'Event' inner metadata type to an 'Int32' understandable by the+--   server. eventMetadataType :: EventData -> Int32 eventMetadataType _ = 0  ----------------------------------------------------------------------------------- | Creates a event using JSON format+-- | Creates an event using JSON format withJson :: ToJSON a => a -> EventData withJson value = Json (toJSON value) Nothing  ----------------------------------------------------------------------------------- | Create a event with metadata using JSON format+-- | Creates an event using a binary format.+withBinary :: ByteString -> EventData+withBinary bs = Binary bs Nothing++--------------------------------------------------------------------------------+-- | Creates an event with metadata using JSON format. withJsonAndMetadata :: (ToJSON a, ToJSON b) => a -> b -> EventData withJsonAndMetadata value metadata =     Json (toJSON value) (Just $ toJSON metadata)  --------------------------------------------------------------------------------+-- | Creates an event with metadata using binary format.+withBinaryAndMetadata :: ByteString -> ByteString -> EventData+withBinaryAndMetadata value metadata = Binary value (Just metadata)++-------------------------------------------------------------------------------- -- | Serializes 'EventData''s data to a raw 'ByteString'. eventDataBytes :: EventData -> ByteString-eventDataBytes (Json value _) = toStrict $ A.encode value+eventDataBytes (Json value _)   = toStrict $ A.encode value+eventDataBytes (Binary value _) = value  -------------------------------------------------------------------------------- -- | Serializes 'EventData' metadata to a raw 'ByteString'. eventMetadataBytes :: EventData -> Maybe ByteString-eventMetadataBytes (Json _ meta_m) = fmap (toStrict . A.encode) meta_m+eventMetadataBytes (Json _ meta_m)   = fmap (toStrict . A.encode) meta_m+eventMetadataBytes (Binary _ meta_m) = meta_m  -------------------------------------------------------------------------------- -- Expected Version@@ -648,15 +664,18 @@ -- | Serialized a 'StreamMetadata' to 'Value' for serialization purpose. streamMetadataJSON :: StreamMetadata -> A.Value streamMetadataJSON StreamMetadata{..} =-    A.object $ [ p_maxAge         .= streamMetadataMaxAge+    A.object $ [ p_maxAge         .= fmap toInt64 streamMetadataMaxAge                , p_maxCount       .= streamMetadataMaxCount                , p_truncateBefore .= streamMetadataTruncateBefore-               , p_cacheControl   .= streamMetadataCacheControl+               , p_cacheControl   .= fmap toInt64 streamMetadataCacheControl                , p_acl            .= streamACLJSON streamMetadataACL                ] ++ custPairs   where     custPairs = customMetaToPairs streamMetadataCustom +    toInt64 :: TimeSpan -> Int64+    toInt64 = truncate . timeSpanTotalSeconds+ -------------------------------------------------------------------------------- -- Stream ACL Properties --------------------------------------------------------------------------------@@ -755,11 +774,16 @@ parseStreamMetadata (A.Object m) =     StreamMetadata                    <$>     m A..: p_maxCount                 <*>-    m A..: p_maxAge                   <*>+    parseTimeSpan p_maxAge            <*>     m A..: p_truncateBefore           <*>-    m A..: p_cacheControl             <*>+    parseTimeSpan p_cacheControl      <*>     (m A..: p_acl >>= parseStreamACL) <*>     pure (keepUserProperties m)+  where+    parseTimeSpan ::  Text -> Parser (Maybe TimeSpan)+    parseTimeSpan prop = do+        (secs :: Maybe Int64) <- m A..: prop+        return $ fmap (timeSpanFromSeconds . realToFrac) secs parseStreamMetadata _ = mzero  --------------------------------------------------------------------------------

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.9.1.3+version:             0.10.0.0  tested-with: GHC >= 7.8.3 && < 7.11 @@ -113,7 +113,6 @@                      , uuid       ==1.3.*                      , unordered-containers                      , stm-                     , attoparsec    -- Directories containing source files.   -- hs-source-dirs:

@@ -46,6 +46,7 @@     , testCase "Update persistent sub" $ updatePersistentTest conn     , testCase "Delete persistent sub" $ deletePersistentTest conn     , testCase "Connect persistent sub" $ connectToPersistentTest conn+    , testCase "MaxAge metadata test" $ maxAgeTest conn     , testCase "Shutdown connection" $ shutdownTest conn     ] @@ -303,6 +304,22 @@             return False     res <- catch action $ \(_ :: SubscriptionClosed) -> return True     assertBool "Should have raised an exception" res++--------------------------------------------------------------------------------+maxAgeTest :: Connection -> IO ()+maxAgeTest conn = do+    let timespan = timeSpanFromDays 1+        metadata = buildStreamMetadata $ setMaxAge timespan+        evt = createEvent "foo" Nothing+              $ withJson (object ["type" .= (3 :: Int)])+    _ <- sendEvent conn "test-max-age" anyVersion evt >>= wait+    _ <- setStreamMetadata conn "test-max-age" anyVersion metadata >>= wait+    r <- getStreamMetadata conn "test-max-age" >>= wait+    case r of+        StreamMetadataResult _ _ m ->+            assertEqual "Should have equal timespan" (Just timespan)+            (streamMetadataMaxAge m)+        _ -> fail "Stream test-max-age doesn't exist"  -------------------------------------------------------------------------------- shutdownTest :: Connection -> IO ()