diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Change log + +eventsource-api uses [Semantic Versioning][]. +The change log is available through the [releases on GitHub][]. + +[Semantic Versioning]: http://semver.org/spec/v2.0.0.html +[releases on GitHub]: https://github.com/githubuser/eventsource-api/releases diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,34 @@ +[The BSD-3 License (BSD3)][] + +Copyright (c) 2016, Yorick Laupa + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Yorick Laupa nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +[The BSD-3 License (BSD3)]: https://opensource.org/licenses/BSD-3-Clause diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,60 @@ +# [eventsource-api][] + +This project provides what we think be a lean eventsourcing API. The goal is to +set a common ground for eventsourcing-based application, yet doesn't force you +to be trapped under a restrictive framework. + +This library main abstraction is the `Store` typeclass. + +```haskell +-- | Main event store abstraction. It exposes essential features expected from +-- an event store. +class Store store where + -- | Appends a batch of events at the end of a stream. + appendEvents :: (EncodeEvent a, MonadIO m) + => store + -> StreamName + -> ExpectedVersion + -> [a] + -> m (Async EventNumber) + + -- | Appends a batch of events at the end of a stream. + readBatch :: MonadIO m + => store + -> StreamName + -> Batch + -> m (Async (ReadStatus Slice)) + + -- | Subscribes to given stream. + subscribe :: MonadIO m => store -> StreamName -> m Subscription +``` + +The idea is to use any backend of your liking as long as it's able to derive that typeclass with its related implicit constraints. + + 1. `appendEvents` MUST add events at the end of a stream without doing any other alteration on the stream. The order of the event's array MUST be respected within the store. Most important, the implementation MUST comply to the given `ExpectedVersion` passed by the user. + + 2. `readBatch` SHOULD retrieve a set of event given a starting position and a batch size (represented by the `Batch` parameter). The returned array MUST have its events ordered by their `EventNumber` property. + + 3. `subscribe` SHOULD register a subscription to the given stream. An implementation MUST allow to subscribe to a stream that doesn't exist yet. A subscription allows the user to be notified of any event added to the stream. There is no mandatory timing to meet regarding how fast the subscription is notified by a change. We only suggest to dispatch new events as soon as possible. + +#### `ExpectedVersion` + +A word on `ExpectedVersion`. It's a mean to preserve data consistency in a concurrent setting. + +```haskell +-- | The purpose of 'ExpectedVersion' is to make sure a certain stream state is +-- at an expected point in order to carry out a write. +data ExpectedVersion + = AnyVersion + -- Stream is a any given state. + | NoStream + -- Stream shouldn't exist. + | StreamExists + -- Stream should exist. + | ExactVersion EventNumber + -- Stream should be at givent event number. +``` + +On a write, if the `ExpectedVersion` condition given by the user is not met within the store, the implementation should raise an exception. At the moment, the API doesn't capture this situation in the type system. + +[eventsource-api]: https://github.com/YoEight/eventsource-api diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- This script is used to build and install your package. Typically you don't +-- need to change it. The Cabal documentation has more information about this +-- file: . +import qualified Distribution.Simple + +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/eventsource-api.cabal b/eventsource-api.cabal new file mode 100644 --- /dev/null +++ b/eventsource-api.cabal @@ -0,0 +1,47 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: eventsource-api +version: 1.0.0 +synopsis: Provides a eventsourcing high level API. +description: Please read README.md. +category: Eventsourcing +homepage: https://github.com/YoEight/eventsource-api#readme +bug-reports: https://github.com/YoEight/eventsource-api/issues +author: Yorick Laupa +maintainer: yo.eight@gmail.com +license: BSD3 +license-file: LICENSE.md +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGELOG.md + LICENSE.md + package.yaml + README.md + stack.yaml + +source-repository head + type: git + location: https://github.com/YoEight/eventsource-api + +library + hs-source-dirs: + library + default-extensions: NoImplicitPrelude + ghc-options: -Wall + build-depends: + base >=4.9 && <5 + , protolude >= 0.1.10 && <0.2 + , uuid + , aeson + , mtl + , containers + , unordered-containers + exposed-modules: + EventSource + EventSource.Store + EventSource.Types + default-language: Haskell2010 diff --git a/library/EventSource.hs b/library/EventSource.hs new file mode 100644 --- /dev/null +++ b/library/EventSource.hs @@ -0,0 +1,19 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : EventSource +-- Copyright : (C) 2016 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- Stability : provisional +-- Portability : non-portable +-- +-------------------------------------------------------------------------------- +module EventSource + ( module EventSource.Store + , module EventSource.Types + ) where + +-------------------------------------------------------------------------------- +import EventSource.Store +import EventSource.Types diff --git a/library/EventSource/Store.hs b/library/EventSource/Store.hs new file mode 100644 --- /dev/null +++ b/library/EventSource/Store.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +-------------------------------------------------------------------------------- +-- | +-- Module : EventSource.Store +-- Copyright : (C) 2016 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- Stability : provisional +-- Portability : non-portable +-- +-------------------------------------------------------------------------------- +module EventSource.Store + ( Batch(..) + , Subscription(..) + , SubscriptionId + , ExpectedVersionException(..) + , Store(..) + , SomeStore(..) + , StreamIterator + , iteratorNext + , iteratorNextEvent + , iteratorReadAll + , iteratorReadAllEvents + , streamIterator + , freshSubscriptionId + , startFrom + , nextEventAs + , foldSub + , foldSubAsync + , appendEvent + , forEvents + , foldEventsM + , foldEvents + ) where + +-------------------------------------------------------------------------------- +import Prelude (Show(..)) + +-------------------------------------------------------------------------------- +import Control.Monad.Except +import Data.IORef +import Data.UUID +import Data.UUID.V4 +import Protolude hiding (from, show, trans) + +-------------------------------------------------------------------------------- +import EventSource.Types + +-------------------------------------------------------------------------------- +-- | Represents batch information needed to read a stream. +data Batch = + Batch { batchFrom :: EventNumber + , batchSize :: Int32 + } + +-------------------------------------------------------------------------------- +-- | Starts a 'Batch' from a given point. The batch size is set to default, +-- which is 500. +startFrom :: EventNumber -> Batch +startFrom from = Batch from 500 + +-------------------------------------------------------------------------------- +-- | Represents a subscription id. +newtype SubscriptionId = SubscriptionId UUID deriving (Eq, Ord, Show) + +-------------------------------------------------------------------------------- +-- | Returns a fresh subscription id. +freshSubscriptionId :: MonadIO m => m SubscriptionId +freshSubscriptionId = liftIO $ fmap SubscriptionId nextRandom + +-------------------------------------------------------------------------------- +-- | A subscription allows to be notified on every change occuring on a stream. +data Subscription = + Subscription { subscriptionId :: SubscriptionId + + , nextEvent :: forall m. MonadIO m + => m (Either SomeException SavedEvent) + } + +-------------------------------------------------------------------------------- +-- | Waits for the next event and deserializes it on the go. +nextEventAs :: (DecodeEvent a, MonadIO m) + => Subscription + -> m (Either SomeException a) +nextEventAs sub = do + res <- nextEvent sub + let action = do + event <- res + first (toException . DecodeEventException) + $ decodeEvent + $ savedEvent event + + return action + +-------------------------------------------------------------------------------- +-- | Folds over every event coming from the subscription until the end of the +-- universe, unless an 'Exception' raises from the subscription. +-- 'SomeException' is used because we let the underlying subscription model +-- exposed its own 'Exception'. If the callback that handles incoming events +-- throws an exception, it will not be catch by the error callback. +foldSub :: (DecodeEvent a, MonadIO m) + => Subscription + -> (a -> m ()) + -> (SomeException -> m ()) + -> m () +foldSub sub onEvent onError = loop + where + loop = do + res <- nextEventAs sub + case res of + Left e -> onError e + Right a -> onEvent a >> loop + +-------------------------------------------------------------------------------- +-- | Asynchronous version of 'foldSub'. +foldSubAsync :: DecodeEvent a + => Subscription + -> (a -> IO ()) + -> (SomeException -> IO ()) + -> IO (Async ()) +foldSubAsync sub onEvent onError = + async $ foldSub sub onEvent onError + +-------------------------------------------------------------------------------- +data ExpectedVersionException + = ExpectedVersionException + { versionExceptionExpected :: ExpectedVersion + , versionExceptionActual :: ExpectedVersion + } deriving Show + +-------------------------------------------------------------------------------- +instance Exception ExpectedVersionException + +-------------------------------------------------------------------------------- +-- | Main event store abstraction. It exposes essential features expected from +-- an event store. +class Store store where + -- | Appends a batch of events at the end of a stream. + appendEvents :: (EncodeEvent a, MonadIO m) + => store + -> StreamName + -> ExpectedVersion + -> [a] + -> m (Async EventNumber) + + -- | Appends a batch of events at the end of a stream. + readBatch :: MonadIO m + => store + -> StreamName + -> Batch + -> m (Async (ReadStatus Slice)) + + -- | Subscribes to given stream. + subscribe :: MonadIO m => store -> StreamName -> m Subscription + +-------------------------------------------------------------------------------- +-- | Utility type to pass any store that implements 'Store' typeclass. +data SomeStore = forall store. Store store => SomeStore store + +-------------------------------------------------------------------------------- +instance Store SomeStore where + appendEvents (SomeStore store) = appendEvents store + readBatch (SomeStore store) = readBatch store + subscribe (SomeStore store) = subscribe store + +-------------------------------------------------------------------------------- +-- | Appends a single event at the end of a stream. +appendEvent :: (EncodeEvent a, MonadIO m, Store store) + => store + -> StreamName + -> ExpectedVersion + -> a + -> m (Async EventNumber) +appendEvent store stream ver a = appendEvents store stream ver [a] + +-------------------------------------------------------------------------------- +-- | Represents failures that can occurs when using 'forEvents'. +data ForEventFailure + = ForEventReadFailure ReadFailure + | ForEventDecodeFailure Text + deriving Show + +-------------------------------------------------------------------------------- +-- | Iterates over all events of stream given a starting point and a batch size. +forEvents :: (MonadIO m, DecodeEvent a, Store store) + => store + -> StreamName + -> (a -> m ()) + -> ExceptT ForEventFailure m () +forEvents store name k = do + res <- streamIterator store name + case res of + ReadSuccess i -> loop i + ReadFailure e -> throwError $ ForEventReadFailure e + where + loop i = do + opt <- iteratorNext i + for_ opt $ \saved -> + case decodeEvent $ savedEvent saved of + Left e -> throwError $ ForEventDecodeFailure e + Right a -> lift (k a) >> loop i + +-------------------------------------------------------------------------------- +-- | Like 'forEvents' but expose signature similar to 'foldM'. +foldEventsM :: (MonadIO m, DecodeEvent a, Store store) + => store + -> StreamName + -> (s -> a -> m s) + -> s + -> ExceptT ForEventFailure m s +foldEventsM store stream k seed = mapExceptT trans action + where + trans m = evalStateT m seed + + action = do + forEvents store stream $ \a -> do + s <- get + s' <- lift $ k s a + put s' + get + +-------------------------------------------------------------------------------- +-- | Like 'foldEventsM' but expose signature similar to 'foldl'. +foldEvents :: (MonadIO m, DecodeEvent a, Store store) + => store + -> StreamName + -> (s -> a -> s) + -> s + -> ExceptT ForEventFailure m s +foldEvents store stream k seed = + foldEventsM store stream (\s a -> return $ k s a) seed + +-------------------------------------------------------------------------------- +-- | Allows to easily iterate over a stream's events. +newtype StreamIterator = + StreamIterator { iteratorNext :: forall m. MonadIO m => m (Maybe SavedEvent) } + +-------------------------------------------------------------------------------- +instance Show StreamIterator where + show _ = "StreamIterator" + +-------------------------------------------------------------------------------- +-- | Reads the next available event from the 'StreamIterator' and try to +-- deserialize it at the same time. +iteratorNextEvent :: (DecodeEvent a, MonadIO m, MonadPlus m) + => StreamIterator + -> m (Maybe a) +iteratorNextEvent i = do + res <- iteratorNext i + case res of + Nothing -> return Nothing + Just s -> + case decodeEvent $ savedEvent s of + Left _ -> mzero + Right a -> return $ Just a + +-------------------------------------------------------------------------------- +-- | Reads all events from the 'StreamIterator' until reaching end of stream. +iteratorReadAll :: MonadIO m => StreamIterator -> m [SavedEvent] +iteratorReadAll i = do + res <- iteratorNext i + case res of + Nothing -> return [] + Just s -> fmap (s:) $ iteratorReadAll i + +-------------------------------------------------------------------------------- +-- | Like 'iteratorReadAll' but try to deserialize the events at the same time. +iteratorReadAllEvents :: (DecodeEvent a, MonadIO m, MonadPlus m) + => StreamIterator + -> m [a] +iteratorReadAllEvents i = do + res <- iteratorNextEvent i + case res of + Nothing -> return [] + Just a -> fmap (a:) $ iteratorReadAllEvents i + +-------------------------------------------------------------------------------- +-- | Returns a 'StreamIterator' for the given stream name. The returned +-- 'StreamIterator' IS NOT THREADSAFE. +streamIterator :: (Store store, MonadIO m) + => store + -> StreamName + -> m (ReadStatus StreamIterator) +streamIterator store name = do + w <- readBatch store name (startFrom 0) + res <- liftIO $ wait w + for res $ \slice -> do + ref <- liftIO $ newIORef $ IteratorOverAvailable slice + return $ StreamIterator $ iterateOver store ref name + +-------------------------------------------------------------------------------- +data IteratorOverState + = IteratorOverAvailable Slice + | IteratorOverClosed + +-------------------------------------------------------------------------------- +data IteratorOverAction + = IteratorOverEvent SavedEvent + | IteratorOverNextBatch EventNumber + | IteratorOverEndOfStream + +-------------------------------------------------------------------------------- +iterateOver :: (Store store, MonadIO m) + => store + -> IORef IteratorOverState + -> StreamName + -> m (Maybe SavedEvent) +iterateOver store ref name = go + where + go = do + action <- liftIO $ atomicModifyIORef' ref $ \st -> + case st of + IteratorOverAvailable slice -> + case sliceEvents slice of + e:es -> + let nextSlice = slice { sliceEvents = es } + nxtSt = IteratorOverAvailable nextSlice in + (nxtSt, IteratorOverEvent e) + [] | sliceEndOfStream slice + -> (IteratorOverClosed, IteratorOverEndOfStream) + | otherwise + -> let resp = IteratorOverNextBatch $ + sliceNextEventNumber slice in + (st, resp) + IteratorOverClosed -> (st, IteratorOverEndOfStream) + + case action of + IteratorOverEvent e -> return $ Just e + IteratorOverEndOfStream -> return Nothing + IteratorOverNextBatch num -> do + w <- readBatch store name (startFrom num) + res <- liftIO $ wait w + case res of + ReadFailure _ -> do + liftIO $ atomicModifyIORef' ref $ \_ -> (IteratorOverClosed, ()) + return Nothing + ReadSuccess slice -> do + let nxtSt = IteratorOverAvailable slice + liftIO $ atomicModifyIORef' ref $ \_ -> (nxtSt, ()) + go diff --git a/library/EventSource/Types.hs b/library/EventSource/Types.hs new file mode 100644 --- /dev/null +++ b/library/EventSource/Types.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : EventSource.Types +-- Copyright : (C) 2016 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- Stability : provisional +-- Portability : non-portable +-- +-------------------------------------------------------------------------------- +module EventSource.Types where + +-------------------------------------------------------------------------------- +import Prelude (Show(..)) +import Data.Foldable +import Data.String + +-------------------------------------------------------------------------------- +import Protolude hiding (show) +import Data.Aeson +import Data.Aeson.Types +import Data.UUID hiding (fromString) +import Data.UUID.V4 +import qualified Data.HashMap.Strict as H +import qualified Data.Map.Strict as M + +-------------------------------------------------------------------------------- +-- | Opaque data type used to store raw data. +data Data + = Data ByteString + | DataAsJson Value + +-------------------------------------------------------------------------------- +instance Show Data where + show _ = "Data(*Binary data*)" + +-------------------------------------------------------------------------------- +-- | Sometimes, having to implement a 'FromJSON' instance isn't flexible enough. +-- 'JsonParsing' allow to pass parameters when parsing from a JSON value while +-- remaining composable. +newtype JsonParsing a = JsonParsing (Value -> Parser a) + +-------------------------------------------------------------------------------- +instance Functor JsonParsing where + fmap f (JsonParsing k) = JsonParsing $ \v -> f <$> k v + +-------------------------------------------------------------------------------- +instance Applicative JsonParsing where + pure a = JsonParsing $ \_ -> return a + + (JsonParsing kf) <*> (JsonParsing ka) = + JsonParsing $ \v -> + kf v <*> ka v + +-------------------------------------------------------------------------------- +instance Monad JsonParsing where + return = pure + + JsonParsing k >>= f = JsonParsing $ \v -> do + a <- k v + let JsonParsing km = f a + km v + +-------------------------------------------------------------------------------- +-- | Returns 'Data' content as a 'ByteString'. +dataAsBytes :: Data -> ByteString +dataAsBytes (Data bs) = bs +dataAsBytes (DataAsJson v) = toS $ encode v + +-------------------------------------------------------------------------------- +-- | Creates a 'Data' object from a raw 'ByteString'. +dataFromBytes :: ByteString -> Data +dataFromBytes = Data + +-------------------------------------------------------------------------------- +-- | Creates a 'Data' object from a JSON object. +dataFromJson :: ToJSON a => a -> Data +dataFromJson = DataAsJson . toJSON + +-------------------------------------------------------------------------------- +-- | Returns 'Data' content as any value that implements 'FromJSON' type-class. +dataAsJson :: FromJSON a => Data -> Either Text a +dataAsJson (Data bs) = first toS $ eitherDecodeStrict bs +dataAsJson (DataAsJson v) = first toS $ parseEither parseJSON v + +-------------------------------------------------------------------------------- +-- | Uses a 'JsonParsing' comuputation to extract a value. +dataAsParsing :: Data -> JsonParsing a -> Either Text a +dataAsParsing dat (JsonParsing k) = do + value <- dataAsJson dat + first toS $ parseEither k value + +-------------------------------------------------------------------------------- +-- | Like 'dataAsParsing' but doesn't require you to use 'JsonParsing'. +dataAsParse :: Data -> (Value -> Parser a) -> Either Text a +dataAsParse dat k = dataAsParsing dat $ JsonParsing k + +-------------------------------------------------------------------------------- +-- | Used to store a set a properties. One example is to be used as 'Event' +-- metadata. +newtype Properties = Properties (Map Text Text) + +-------------------------------------------------------------------------------- +instance Monoid Properties where + mempty = Properties mempty + mappend (Properties a) (Properties b) = Properties $ mappend a b + +-------------------------------------------------------------------------------- +instance Show Properties where + show (Properties m) = show m + +-------------------------------------------------------------------------------- +instance ToJSON Properties where + toJSON = object . fmap go . properties + where + go (k, v) = k .= v + +-------------------------------------------------------------------------------- +instance FromJSON Properties where + parseJSON = withObject "Properties" $ \o -> + let go p k = fmap (\v -> setProperty k v p) (o .: k) in + foldlM go mempty (H.keys o) + +-------------------------------------------------------------------------------- +-- | Retrieves a value associated with the given key. +property :: MonadPlus m => Text -> Properties -> m Text +property k (Properties m) = + case M.lookup k m of + Nothing -> mzero + Just v -> return v + +-------------------------------------------------------------------------------- +-- | Builds a 'Properties' with a single pair of key-value. +singleton :: Text -> Text -> Properties +singleton k v = setProperty k v mempty + +-------------------------------------------------------------------------------- +-- | Adds a pair of key-value into given 'Properties'. +setProperty :: Text -> Text -> Properties -> Properties +setProperty key value (Properties m) = Properties $ M.insert key value m + +-------------------------------------------------------------------------------- +-- | Returns all associated key-value pairs as a list. +properties :: Properties -> [(Text, Text)] +properties (Properties m) = M.toList m + +-------------------------------------------------------------------------------- +-- | Used to identify an event. +newtype EventId = EventId UUID deriving (Eq, Ord) + +-------------------------------------------------------------------------------- +instance Show EventId where + show (EventId uuid) = show uuid + +-------------------------------------------------------------------------------- +-- | Generates a fresh 'EventId'. +freshEventId :: MonadIO m => m EventId +freshEventId = fmap EventId $ liftIO nextRandom + +-------------------------------------------------------------------------------- +-- | Represents a stream name. +newtype StreamName = StreamName Text deriving (Eq, Ord) + +-------------------------------------------------------------------------------- +instance Show StreamName where + show (StreamName s) = show s + +-------------------------------------------------------------------------------- +instance IsString StreamName where + fromString = StreamName . fromString + +-------------------------------------------------------------------------------- +-- | Used to identity the type of an 'Event'. +newtype EventType = EventType Text deriving Eq + +-------------------------------------------------------------------------------- +instance Show EventType where + show (EventType t) = show t + +-------------------------------------------------------------------------------- +instance IsString EventType where + fromString = EventType . fromString + +-------------------------------------------------------------------------------- +-- | Sets 'EventType' for an 'Event'. +setEventType :: EventType -> State Event () +setEventType typ = modify $ \s -> s { eventType = typ } + +-------------------------------------------------------------------------------- +-- | Sets 'Eventid' for an 'Event'. +setEventId :: EventId -> State Event () +setEventId eid = modify $ \s -> s { eventId = eid } + +-------------------------------------------------------------------------------- +-- | Sets a payload for an 'Event'. +setEventPayload :: Data -> State Event () +setEventPayload dat = modify $ \s -> s { eventPayload = dat } + +-------------------------------------------------------------------------------- +-- | Sets metadata for an 'Event'. +setEventMetadata :: Properties -> State Event () +setEventMetadata props = modify $ \s -> s { eventMetadata = Just props } + +-------------------------------------------------------------------------------- +-- | Encapsulates an event which is about to be saved. +data Event = + Event { eventType :: EventType + , eventId :: EventId + , eventPayload :: Data + , eventMetadata :: Maybe Properties + } deriving Show + +-------------------------------------------------------------------------------- +-- | Represents an event index in a stream. +newtype EventNumber = EventNumber Int32 deriving (Eq, Ord, Num, Enum, Show) + +-------------------------------------------------------------------------------- +-- | Represents an event that's saved into the event store. +data SavedEvent = + SavedEvent { eventNumber :: EventNumber + , savedEvent :: Event + } deriving Show + +-------------------------------------------------------------------------------- +-- | Deserializes a 'SavedEvent'. +savedEventAs :: DecodeEvent a => SavedEvent -> Either Text a +savedEventAs = decodeEvent . savedEvent + +-------------------------------------------------------------------------------- +-- | Represents batch of events read from a store. +data Slice = + Slice { sliceEvents :: [SavedEvent] + , sliceEndOfStream :: Bool + , sliceNextEventNumber :: EventNumber + } deriving Show + +-------------------------------------------------------------------------------- +-- | Deserializes a 'Slice''s events. +sliceEventsAs :: DecodeEvent a => Slice -> Either Text [a] +sliceEventsAs = traverse savedEventAs . sliceEvents + +-------------------------------------------------------------------------------- +-- | Encodes a data object into an 'Event'. 'encodeEvent' get passed an +-- 'EventId' in a case where a fresh id is needed. +class EncodeEvent a where + encodeEvent :: a -> State Event () + +-------------------------------------------------------------------------------- +-- | Decodes an 'Event' into a data object. +class DecodeEvent a where + decodeEvent :: Event -> Either Text a + +-------------------------------------------------------------------------------- +newtype DecodeEventException = DecodeEventException Text deriving Show + +-------------------------------------------------------------------------------- +instance Exception DecodeEventException + +-------------------------------------------------------------------------------- +instance DecodeEvent Event where + decodeEvent = Right + +-------------------------------------------------------------------------------- +-- | The purpose of 'ExpectedVersion' is to make sure a certain stream state is +-- at an expected point in order to carry out a write. +data ExpectedVersion + = AnyVersion + -- Stream is a any given state. + | NoStream + -- Stream shouldn't exist. + | StreamExists + -- Stream should exist. + | ExactVersion EventNumber + -- Stream should be at givent event number. + deriving Show + +-------------------------------------------------------------------------------- +-- | Statuses you can get on every read attempt. +data ReadStatus a + = ReadSuccess a + | ReadFailure ReadFailure + deriving Show + +-------------------------------------------------------------------------------- +-- | Returns 'True' is 'ReadStatus' is a 'ReadSuccess'. +isReadSuccess :: ReadStatus a -> Bool +isReadSuccess (ReadSuccess _) = True +isReadSuccess _ = False + +-------------------------------------------------------------------------------- +-- | Returns 'False' is 'ReadStatus' is a 'ReadFailure'. +isReadFailure :: ReadStatus a -> Bool +isReadFailure (ReadFailure _) = True +isReadFailure _ = False + +-------------------------------------------------------------------------------- +-- | Represents the different kind of failure you can get when reading. +data ReadFailure + = StreamNotFound + | ReadError (Maybe Text) + | AccessDenied + deriving Show + +-------------------------------------------------------------------------------- +instance Functor ReadStatus where + fmap f (ReadSuccess a) = ReadSuccess $ f a + fmap _ (ReadFailure e) = ReadFailure e + +-------------------------------------------------------------------------------- +instance Foldable ReadStatus where + foldMap f (ReadSuccess a) = f a + foldMap _ _ = mempty + +-------------------------------------------------------------------------------- +instance Traversable ReadStatus where + traverse f (ReadSuccess a) = fmap ReadSuccess $ f a + traverse _ (ReadFailure e) = pure $ ReadFailure e diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,32 @@ +# This YAML file describes your package. Stack will automatically generate a +# Cabal file when you run `stack build`. See the hpack website for help with +# this file: . +category: Eventsourcing +description: Please read README.md. +extra-source-files: +- CHANGELOG.md +- LICENSE.md +- package.yaml +- README.md +- stack.yaml +ghc-options: -Wall +github: YoEight/eventsource-api +library: + default-extensions: + - NoImplicitPrelude + dependencies: + - base >=4.9 && <5 + - protolude >= 0.1.10 && <0.2 + - uuid + - aeson + - mtl + - containers + - unordered-containers + source-dirs: library +license: BSD3 +license-file: LICENSE.md +author: Yorick Laupa +maintainer: yo.eight@gmail.com +name: eventsource-api +synopsis: Provides a eventsourcing high level API. +version: '1.0.0' diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-7.14 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.3" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor