diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/Database/EventStore.hs b/Database/EventStore.hs --- a/Database/EventStore.hs +++ b/Database/EventStore.hs @@ -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 diff --git a/Database/EventStore/Internal/Manager/Subscription/Message.hs b/Database/EventStore/Internal/Manager/Subscription/Message.hs --- a/Database/EventStore/Internal/Manager/Subscription/Message.hs +++ b/Database/EventStore/Internal/Manager/Subscription/Message.hs @@ -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 diff --git a/Database/EventStore/Internal/TimeSpan.hs b/Database/EventStore/Internal/TimeSpan.hs --- a/Database/EventStore/Internal/TimeSpan.hs +++ b/Database/EventStore/Internal/TimeSpan.hs @@ -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 diff --git a/Database/EventStore/Internal/Types.hs b/Database/EventStore/Internal/Types.hs --- a/Database/EventStore/Internal/Types.hs +++ b/Database/EventStore/Internal/Types.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/eventstore.cabal b/eventstore.cabal --- a/eventstore.cabal +++ b/eventstore.cabal @@ -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: diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -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 ()