diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,19 @@ +Copyright (c) 2016-2017 David Reaver + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# Eventful core diff --git a/eventful-core.cabal b/eventful-core.cabal new file mode 100644 --- /dev/null +++ b/eventful-core.cabal @@ -0,0 +1,113 @@ +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack + +name: eventful-core +version: 0.1.0 +synopsis: Core module for eventful +description: Core module for eventful +category: Database,Eventsourcing +stability: experimental +maintainer: David Reaver +license: MIT +license-file: LICENSE.md +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGELOG.md + README.md + +library + hs-source-dirs: + src + default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5 + , aeson + , containers + , http-api-data + , path-pieces + , template-haskell + , text + , transformers + , uuid + exposed-modules: + Eventful + Eventful.Aggregate + Eventful.EventBus + Eventful.ProcessManager + Eventful.Projection + Eventful.ReadModel.Class + Eventful.Serializer + Eventful.Store.Class + Eventful.TH + Eventful.TH.Projection + Eventful.TH.SumType + Eventful.TH.SumTypeSerializer + Eventful.UUID + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + tests + src + default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5 + , aeson + , containers + , http-api-data + , path-pieces + , template-haskell + , text + , transformers + , uuid + , hspec + , HUnit + other-modules: + Eventful.SerializerSpec + Eventful.TH.SumTypeSpec + HLint + Eventful + Eventful.Aggregate + Eventful.EventBus + Eventful.ProcessManager + Eventful.Projection + Eventful.ReadModel.Class + Eventful.Serializer + Eventful.Store.Class + Eventful.TH + Eventful.TH.Projection + Eventful.TH.SumType + Eventful.TH.SumTypeSerializer + Eventful.UUID + default-language: Haskell2010 + +test-suite style + type: exitcode-stdio-1.0 + main-is: HLint.hs + hs-source-dirs: + tests + default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies + ghc-options: -Wall + build-depends: + base >= 4.9 && < 5 + , aeson + , containers + , http-api-data + , path-pieces + , template-haskell + , text + , transformers + , uuid + , hlint + other-modules: + Eventful.SerializerSpec + Eventful.TH.SumTypeSpec + Spec + default-language: Haskell2010 diff --git a/src/Eventful.hs b/src/Eventful.hs new file mode 100644 --- /dev/null +++ b/src/Eventful.hs @@ -0,0 +1,12 @@ +module Eventful + ( module X + ) where + +import Eventful.Aggregate as X +import Eventful.EventBus as X +import Eventful.Projection as X +import Eventful.ProcessManager as X +import Eventful.ReadModel.Class as X +import Eventful.Serializer as X +import Eventful.Store.Class as X +import Eventful.UUID as X diff --git a/src/Eventful/Aggregate.hs b/src/Eventful/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/Aggregate.hs @@ -0,0 +1,54 @@ +-- | Defines an Aggregate type-class from DDD parlance. + +module Eventful.Aggregate + ( Aggregate (..) + , allAggregateStates + , commandStoredAggregate + ) where + +import Data.Foldable (foldl') +import Data.List (scanl') + +import Eventful.Projection +import Eventful.Store.Class +import Eventful.UUID + +-- | An 'Aggregate' is a combination of a 'Projection' and a function to +-- validate commands against that 'Projection'. When using an aggregate in some +-- service, it is common to simply load the latest projection state from the +-- event store and handle the command. If the command is valid then the new +-- events are applied to the projection in the event store. +data Aggregate state event cmd = + Aggregate + { aggregateCommandHandler :: state -> cmd -> [event] + , aggregateProjection :: Projection state event + } + +-- | Given a list commands, produce all of the states the aggregate's +-- projection sees. This is useful for unit testing aggregates. +allAggregateStates + :: Aggregate state event cmd + -> [cmd] + -> [state] +allAggregateStates (Aggregate commandHandler (Projection seed eventHandler)) events = + scanl' go seed events + where + go state command = foldl' eventHandler state $ commandHandler state command + +-- | Loads the latest version of a 'Projection' from the event store and tries to +-- apply the 'Aggregate' command to it. If the command succeeds, then this +-- saves the events back to the store as well. +commandStoredAggregate + :: (Monad m) + => EventStore serialized m + -> Aggregate state serialized cmd + -> UUID + -> cmd + -> m [serialized] +commandStoredAggregate store (Aggregate handler proj) uuid command = do + (latest, vers) <- getLatestProjection store proj uuid + let events = handler latest command + mError <- storeEvents store (ExactVersion vers) uuid events + case mError of + (Just err) -> error $ "TODO: Create aggregate restart logic. " ++ show err + Nothing -> return events diff --git a/src/Eventful/EventBus.hs b/src/Eventful/EventBus.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/EventBus.hs @@ -0,0 +1,50 @@ +module Eventful.EventBus + ( synchronousEventBusWrapper + , storeAndPublishEvents + ) where + +import Eventful.Store.Class +import Eventful.UUID + +-- | This function wraps an event store by sending events to event handlers +-- after running 'storeEvents'. This is useful to quickly wire up event +-- handlers in your application (like read models or process managers), and it +-- is also useful for integration testing along with an in-memory event store. +synchronousEventBusWrapper + :: (Monad m) + => EventStore serialized m + -> [EventStore serialized m -> UUID -> serialized -> m ()] + -> EventStore serialized m +synchronousEventBusWrapper store handlers = + let + -- NB: We need to use recursive let bindings so we can put wrappedStore + -- inside the event handlers + handlers' = map ($ wrappedStore) handlers + wrappedStore = + EventStore + { getLatestVersion = getLatestVersion store + , getEvents = getEvents store + , storeEvents = storeAndPublishEvents store handlers' + } + in wrappedStore + +-- | Stores events in the store and them publishes them to the event handlers. +-- This is used in the 'synchronousEventBusWrapper'. +storeAndPublishEvents + :: (Monad m) + => EventStore serialized m + -> [UUID -> serialized -> m ()] + -> ExpectedVersion + -> UUID + -> [serialized] + -> m (Maybe EventWriteError) +storeAndPublishEvents store handlers expectedVersion uuid events = do + result <- storeEvents store expectedVersion uuid events + case result of + Just err -> return $ Just err + Nothing -> do + -- NB: If a handler stores events, then its events will be published + -- before the events of the next handler. That is, we will be storing + -- events generated by handlers in depth-first order. + mapM_ (\handler -> mapM_ (handler uuid) events) handlers + return Nothing diff --git a/src/Eventful/ProcessManager.hs b/src/Eventful/ProcessManager.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/ProcessManager.hs @@ -0,0 +1,92 @@ +module Eventful.ProcessManager + ( ProcessManager (..) + , ProcessManagerCommand (..) + , ProcessManagerEvent (..) + , ProcessManagerRouter (..) + , processManagerHandler + ) where + +import Control.Monad (forM_, void) + +import Eventful.Aggregate +import Eventful.Projection +import Eventful.Store.Class +import Eventful.UUID + +-- | A 'ProcessManager' manages interaction between aggregates. It works by +-- listening to events on an event bus (see 'processManagerHandler') and +-- applying events to its internal 'Projection'. Then, pending commands and +-- events are plucked off of that Projection and applied to the appropriate +-- Aggregates or Projections in other streams. +data ProcessManager state event command + = ProcessManager + { processManagerProjection :: Projection state event + , processManagerPendingCommands :: state -> [ProcessManagerCommand event command] + , processManagerPendingEvents :: state -> [ProcessManagerEvent event] + } + +-- | This is a @command@ along with the UUID of the target 'Aggregate', and +-- well as the 'Aggregate' instance. Note that this uses an existential type to +-- hide the @state@ type parameter on the Aggregate. +data ProcessManagerCommand event command + = forall state. ProcessManagerCommand + { processManagerCommandAggregateId :: UUID + , processManagerCommandAggregate :: Aggregate state event command + , processManagerCommandCommand :: command + } + +instance (Show command, Show event) => Show (ProcessManagerCommand event command) where + show (ProcessManagerCommand uuid _ command) = + "ProcessManagerCommand{ processManagerCommandAggregateId = " ++ show uuid ++ + ", processManagerCommandCommand = " ++ show command + +-- | This is an @event@ paired with the UUID of the stream to which the event +-- will be applied. +data ProcessManagerEvent event + = ProcessManagerEvent + { processManagerEventProjectionId :: UUID + , processManagerEventEvent :: event + } deriving (Show, Eq) + +-- | A 'ProcessManagerRouter' decides which process manager projection ID to +-- use for a given event. +data ProcessManagerRouter state event command + = ProcessManagerRouter + { processManagerRouterGetManagerId :: UUID -> event -> Maybe UUID + -- TODO: Should this really be just "Maybe UUID"? We should consider + -- allowing UUID creation as well when the first event for a process comes + -- in so we know every process manager has a unique UUID. We could make an + -- ADT for ProcessManagerRouteResult that returns either the UUID, a value + -- saying we need to make a UUID, or a value saying the manager ignores + -- that event. + , processManagerRouterManager :: ProcessManager state event command + } + +-- | This is an event handler for a 'ProcessManager' that applies all events to +-- the 'ProcessManagerRouter', and then applied any pending commands or events +-- to the appropriate places. +processManagerHandler + :: (Monad m) + => ProcessManagerRouter state event command + -> EventStore event m + -> UUID + -> event + -> m () +processManagerHandler (ProcessManagerRouter getManagerId manager) store eventAggregateId event = + maybe (return ()) (processManagerHandler' manager store event) (getManagerId eventAggregateId event) + +processManagerHandler' + :: (Monad m) + => ProcessManager state event command + -> EventStore event m + -> event + -> UUID + -> m () +processManagerHandler' ProcessManager{..} store startEvent managerId = do + -- TODO: Don't ignore storage errors + _ <- storeEvents store AnyVersion managerId [startEvent] + (managerState, _) <- getLatestProjection store processManagerProjection managerId + forM_ (processManagerPendingCommands managerState) $ \(ProcessManagerCommand aggregateId aggregate command) -> + void $ commandStoredAggregate store aggregate aggregateId command + forM_ (processManagerPendingEvents managerState) $ \(ProcessManagerEvent projectionId event) -> + storeEvents store AnyVersion projectionId [event] diff --git a/src/Eventful/Projection.hs b/src/Eventful/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/Projection.hs @@ -0,0 +1,57 @@ +module Eventful.Projection + ( Projection (..) + , latestProjection + , allProjections + , getLatestProjection + ) + where + +import Data.Foldable (foldl') +import Data.List (scanl') + +import Eventful.Store.Class +import Eventful.UUID + +-- | A 'Projection' is a piece of @state@ that is constructed only from +-- @event@s. A Projection is how you reconstruct event sourced state from the +-- ordered stream of events that constitute that state. The "seed" of a +-- Projection is the initial state before any events are applied. The event +-- handler for a projection is the function that actually modifies state based +-- on the given event. +data Projection state event + = Projection + { projectionSeed :: state + -- ^ Initial state of a projection + , projectionEventHandler :: state -> event -> state + -- ^ The function that applies and event to the current state, producing a + -- new state. + } + +-- | Computes the latest state of a 'Projection' from some events. +latestProjection :: (Foldable t) => Projection state event -> t event -> state +latestProjection (Projection seed handler) = foldl' handler seed + +-- | Given a list of events, produce all the Projections that were ever +-- produced. Just a 'scanl' using 'projectionEventHandler'. This function is +-- useful for testing 'Projection's; you can easily assert that all the states +-- of a Projection are valid given a list of events. +allProjections :: Projection state event -> [event] -> [state] +allProjections (Projection seed handler) = scanl' handler seed + +-- | Gets the latest projection from a store by using 'getEvents' and then +-- applying the events using the Projection's event handler. +getLatestProjection + :: (Monad m) + => EventStore serialized m + -> Projection proj serialized + -> UUID + -> m (proj, EventVersion) +getLatestProjection store proj uuid = do + events <- getEvents store uuid Nothing + let + latestVersion = maxEventVersion events + latestProj = latestProjection proj $ storedEventEvent <$> events + return (latestProj, latestVersion) + where + maxEventVersion [] = -1 + maxEventVersion es = maximum $ storedEventVersion <$> es diff --git a/src/Eventful/ReadModel/Class.hs b/src/Eventful/ReadModel/Class.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/ReadModel/Class.hs @@ -0,0 +1,45 @@ +module Eventful.ReadModel.Class + ( ReadModel (..) + , runPollingReadModel + ) where + +import Control.Concurrent (threadDelay) +import Control.Monad (forever) +import Control.Monad.IO.Class (liftIO, MonadIO) + +import Eventful.Store.Class + +data ReadModel model serialized m = + ReadModel + { readModelModel :: model + , readModelLatestAppliedSequence :: model -> m SequenceNumber + , readModelHandleEvents :: model -> [GloballyOrderedEvent (StoredEvent serialized)] -> m () + } + +type PollingPeriodSeconds = Double + +runPollingReadModel + :: (MonadIO m, Monad mstore) + => ReadModel model serialized m + -> GloballyOrderedEventStore serialized mstore + -> (forall a. mstore a -> m a) + -> PollingPeriodSeconds + -> m () +runPollingReadModel ReadModel{..} getGloballyOrderedEvents runStore waitSeconds = forever $ do + -- Get new events starting from latest applied sequence number + latestSeq <- readModelLatestAppliedSequence readModelModel + newEvents <- runStore $ getSequencedEvents getGloballyOrderedEvents (latestSeq + 1) + + -- Handle the new events + readModelHandleEvents readModelModel newEvents + + -- Wait before running again + liftIO $ threadDelay $ ceiling (waitSeconds * 1000000) -- threadDelay accepts microseconds + +-- data EventHandler m serialized = forall event. (Serializable event serialized, Monad m) => EventHandler (event -> m ()) + +-- combineHandlers :: (Monad m) => [EventHandler m serialized] -> (serialized -> m ()) +-- combineHandlers handlers event = mapM_ ($ event) (mkHandler <$> handlers) + +-- mkHandler :: EventHandler m serialized -> (serialized -> m ()) +-- mkHandler (EventHandler handler) event = maybe (return ()) handler (deserialize event) diff --git a/src/Eventful/Serializer.hs b/src/Eventful/Serializer.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/Serializer.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module Eventful.Serializer + ( -- * Class + Serializer (..) + , simpleSerializer + , composeSerializers + -- * Common serializers + , idSerializer + , jsonSerializer + , jsonTextSerializer + , dynamicSerializer + -- * Serialized event store + , serializedEventStore + , serializedGloballyOrderedEventStore + -- * Sum types + , EventSumType (..) + , eventSumTypeSerializer + ) where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Dynamic +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import GHC.Generics + +import Eventful.Store.Class + +-- | A 'Serializer' describes the injective conversion between types @a@ and +-- @b@. In plain English, this means that you can go from @a@ to @b@, and you +-- can 'Maybe' go from @b@ back to @a@. This is often used to serialize events +-- to an event store, and then deserialize them back. +data Serializer a b = + Serializer + { serialize :: a -> b + , deserialize :: b -> Maybe a + , deserializeEither :: b -> Either String a + -- ^ Deserialize with additional information on failure + } + +-- | Simple constructor to just use 'deserialize' to construct +-- 'deserializeEither'. +simpleSerializer + :: (a -> b) + -> (b -> Maybe a) + -> Serializer a b +simpleSerializer serialize' deserialize' = + Serializer + { serialize = serialize' + , deserialize = deserialize' + , deserializeEither = maybe (Left "Serializable: Failed to deserialize") Right . deserialize' + } + +-- | Apply an intermediate 'Serializer' to a serializer to go from type @a@ to +-- @c@ with @b@ in the middle. Note that with deserializing, if the conversion +-- from @c@ to @b@ or from @b@ to @a@ fails, the whole deserialization fails. +composeSerializers :: Serializer a b -> Serializer b c -> Serializer a c +composeSerializers serializer1 serializer2 = Serializer serialize' deserialize' deserializeEither' + where + serialize' = serialize serializer2 . serialize serializer1 + deserialize' x = deserialize serializer2 x >>= deserialize serializer1 + deserializeEither' x = deserializeEither serializer2 x >>= deserializeEither serializer1 + +-- | Simple "serializer" using 'id'. Useful for when an API requires a +-- serializer but you don't need to actually change types. +idSerializer :: Serializer a a +idSerializer = simpleSerializer id Just + +-- | A 'Serializer' for aeson 'Value's. +jsonSerializer :: (ToJSON a, FromJSON a) => Serializer a Value +jsonSerializer = + Serializer + { serialize = toJSON + , deserialize = \x -> + case fromJSON x of + Success a -> Just a + Error _ -> Nothing + , deserializeEither = \x -> + case fromJSON x of + Success a -> Right a + Error e -> Left e + } + +-- | A 'Serializer' to convert JSON to/from lazy text. Useful for Sql event +-- stores that store JSON values as text. +jsonTextSerializer :: (ToJSON a, FromJSON a) => Serializer a TL.Text +jsonTextSerializer = + Serializer + { serialize = TLE.decodeUtf8 . encode + , deserialize = decode . TLE.encodeUtf8 + , deserializeEither = eitherDecode . TLE.encodeUtf8 + } + +-- | A 'Serializer' for 'Dynamic' values using 'toDyn' and 'fromDynamic'. +dynamicSerializer :: (Typeable a) => Serializer a Dynamic +dynamicSerializer = simpleSerializer toDyn fromDynamic + +-- | A 'Serializer' from one 'EventSumType' instance to another. WARNING: If +-- not all events in the source 'EventSumType' are in the @serialized@ +-- 'EventSumType', then this function will be partial! +eventSumTypeSerializer :: (Typeable a, EventSumType a, EventSumType b) => Serializer a b +eventSumTypeSerializer = simpleSerializer serialize' deserialize' + where + serialize' event = + fromMaybe + (error $ "Failure in eventSumTypeSerializer. Can't serialize " ++ show (typeOf event)) + (eventFromDyn $ eventToDyn event) + deserialize' = eventFromDyn . eventToDyn + +-- | Wraps an 'EventStore' and transparently serializes/deserializes events for +-- you. Note that in this implementation deserialization errors when using +-- 'getEvents' are simply ignored (the event is not returned). +serializedEventStore + :: (Monad m) + => Serializer event serialized + -> EventStore serialized m + -> EventStore event m +serializedEventStore Serializer{..} store = + EventStore + (getLatestVersion store) + getEvents' + storeEvents' + where + getEvents' uuid mVersion = mapMaybe (traverse deserialize) <$> getEvents store uuid mVersion + storeEvents' expectedVersion uuid events = storeEvents store expectedVersion uuid (serialize <$> events) + +-- | Like 'serializedEventStore' except for 'GloballyOrderedEventStore'. +serializedGloballyOrderedEventStore + :: (Monad m) + => Serializer event serialized + -> GloballyOrderedEventStore serialized m + -> GloballyOrderedEventStore event m +serializedGloballyOrderedEventStore Serializer{..} store = + GloballyOrderedEventStore getSequencedEvents' + where + getSequencedEvents' sequenceNumber = + mapMaybe (traverse (traverse deserialize)) <$> getSequencedEvents store sequenceNumber + +-- | This is a type class for serializing sum types of events to 'Dynamic' +-- without the associated constructor. This is useful when transforming between +-- two sum types of events. A common pattern is to put all the events in an +-- application in one big event sum type, and then have a smaller sum type for +-- each 'Projection'. Then, you can use 'eventSumTypeSerializer' to transform +-- between the two. +-- +-- It is meant to be derived with 'Generic'. For example: +-- +-- @ +-- data EventA = EventA deriving (Show) +-- data EventB = EventB deriving (Show) +-- data EventC = EventC deriving (Show) +-- +-- data AllEvents +-- = AllEventsEventA EventA +-- | AllEventsEventB EventB +-- | AllEventsEventC EventC +-- deriving (Show, Generic) +-- +-- instance EventSumType AllEvents +-- +-- data MyEvents +-- = MyEventsEventA EventA +-- | MyEventsEventB EventB +-- deriving (Show, Generic) +-- +-- instance EventSumType MyEvents +-- @ +-- +-- Now we can serialize to 'Dynamic' without a constructor tag: +-- +-- >>> eventToDyn (MyEventsEventA EventA) +-- <> +-- +-- We can also go from a 'MyEvents' value to an 'AllEvents' value: +-- +-- >>> eventFromDyn (eventToDyn (MyEventsEventA EventA)) :: Maybe AllEvents +-- Just (AllEventsEventA EventA) +-- +class EventSumType a where + -- | Convert an event to a 'Dynamic' without the constructor tag + eventToDyn :: a -> Dynamic + + -- | Go from a 'Dynamic' to an event with the constructor tag. Note, this + -- function is @O(n)@ to the number of constructors. + eventFromDyn :: Dynamic -> Maybe a + + default eventToDyn :: (Generic a, EventSumType' (Rep a)) => a -> Dynamic + eventToDyn x = eventToDyn' (from x) + + default eventFromDyn :: (Generic a, EventSumType' (Rep a)) => Dynamic -> Maybe a + eventFromDyn = fmap to . eventFromDyn' + +-- Auxiliary type class for 'EventSumType' Generic fun +class EventSumType' f where + eventToDyn' :: f p -> Dynamic + eventFromDyn' :: Dynamic -> Maybe (f p) + +-- M1 is the top-level metadata. We don't need the metadata so we just pass on +-- through. +instance (EventSumType' f) => EventSumType' (M1 i t f) where + eventToDyn' (M1 x) = eventToDyn' x + eventFromDyn' = fmap M1 . eventFromDyn' + +-- The :+: operator is for when a type has multiple constructors. When +-- serializing, we just pass on through. When deserializing, we try the first +-- constructor, and if that fails then the second. +instance (EventSumType' f, EventSumType' g) => EventSumType' (f :+: g) where + eventToDyn' (L1 x) = eventToDyn' x + eventToDyn' (R1 x) = eventToDyn' x + eventFromDyn' dyn = (L1 <$> eventFromDyn' dyn) <|> (R1 <$> eventFromDyn' dyn) + +-- K1 R represents an actual constructor. This is where we do the actual +-- conversion to/from 'Dynamic'. +instance (Typeable c) => EventSumType' (K1 R c) where + eventToDyn' (K1 x) = toDyn x + eventFromDyn' dyn = K1 <$> fromDynamic dyn diff --git a/src/Eventful/Store/Class.hs b/src/Eventful/Store/Class.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/Store/Class.hs @@ -0,0 +1,130 @@ +module Eventful.Store.Class + ( -- * EventStore + EventStore (..) + , GloballyOrderedEventStore (..) + , ExpectedVersion (..) + , EventWriteError (..) + -- * Utility types + , StoredEvent (..) + , GloballyOrderedEvent (..) + , EventVersion (..) + , SequenceNumber (..) + -- * Utility functions + , transactionalExpectedWriteHelper + ) where + +import Data.Aeson +import Web.HttpApiData +import Web.PathPieces + +import Eventful.UUID + +-- | The 'EventStore' is the core type of eventful. A store operates in some +-- monad @m@ and stores events by serializing them to the type @serialized@. +data EventStore serialized m + = EventStore + { getLatestVersion :: UUID -> m EventVersion + -- ^ Gets the latest 'EventVersion' for a given 'Projection'. + , getEvents :: UUID -> Maybe EventVersion -> m [StoredEvent serialized] + -- ^ Retrieves all the events for a given 'Projection' using that + -- projection's UUID. If an event version is provided then all events with + -- a version greater than or equal to that version are returned. + , storeEvents :: ExpectedVersion -> UUID -> [serialized] -> m (Maybe EventWriteError) + -- ^ Stores the events for a given 'Projection' using that projection's + -- UUID. + } + +-- | Gets all the events ordered starting with a given 'SequenceNumber', and +-- ordered by 'SequenceNumber'. This is used when replaying all the events in a +-- store. +newtype GloballyOrderedEventStore serialized m = + GloballyOrderedEventStore + { getSequencedEvents :: SequenceNumber -> m [GloballyOrderedEvent (StoredEvent serialized)] + } + +-- | ExpectedVersion is used to assert the event stream is at a certain version +-- number. This is used when multiple writers are concurrently writing to the +-- event store. If the expected version is incorrect, then storing fails. +data ExpectedVersion + = AnyVersion + -- ^ Used when the writer doesn't care what version the stream is at. + | NoStream + -- ^ The stream shouldn't exist yet. + | StreamExists + -- ^ The stream should already exist. + | ExactVersion EventVersion + -- ^ Used to assert the stream is at a particular version. + deriving (Show, Eq) + +data EventWriteError + = EventStreamNotAtExpectedVersion EventVersion + deriving (Show, Eq) + +-- | Helper to create 'storeEventsRaw' given a function to get the latest +-- stream version and a function to write to the event store. **NOTE**: This +-- only works if the monad @m@ is transactional. +transactionalExpectedWriteHelper + :: (Monad m) + => (UUID -> m EventVersion) + -> (UUID -> [serialized] -> m ()) + -> ExpectedVersion -> UUID -> [serialized] -> m (Maybe EventWriteError) +transactionalExpectedWriteHelper getLatestVersion' storeEvents' expected = + go expected getLatestVersion' storeEvents' + where + go AnyVersion = transactionalExpectedWriteHelper' Nothing + go NoStream = transactionalExpectedWriteHelper' (Just $ (==) (-1)) + go StreamExists = transactionalExpectedWriteHelper' (Just (> (-1))) + go (ExactVersion vers) = transactionalExpectedWriteHelper' (Just $ (==) vers) + +transactionalExpectedWriteHelper' + :: (Monad m) + => Maybe (EventVersion -> Bool) + -> (UUID -> m EventVersion) + -> (UUID -> [serialized] -> m ()) + -> UUID -> [serialized] -> m (Maybe EventWriteError) +transactionalExpectedWriteHelper' Nothing _ storeEvents' uuid events = + storeEvents' uuid events >> return Nothing +transactionalExpectedWriteHelper' (Just f) getLatestVersion' storeEvents' uuid events = do + latestVersion <- getLatestVersion' uuid + if f latestVersion + then storeEvents' uuid events >> return Nothing + else return $ Just $ EventStreamNotAtExpectedVersion latestVersion + +-- | A 'StoredEvent' is an event with associated storage metadata. +data StoredEvent event + = StoredEvent + { storedEventProjectionId :: UUID + -- ^ The UUID of the 'Projection' that the event belongs to. + , storedEventVersion :: EventVersion + -- ^ The version of the Projection corresponding to this event. + , storedEventEvent :: event + -- ^ The actual event type. Note that this can be a serialized event or the + -- actual Haskell event type. + } deriving (Show, Eq, Functor, Foldable, Traversable) + +-- | A 'GloballyOrderedEvent' is an event that has a global 'SequenceNumber'. +data GloballyOrderedEvent event + = GloballyOrderedEvent + { globallyOrderedEventSequenceNumber :: SequenceNumber + -- ^ The global sequence number of this event. + , globallyOrderedEventEvent :: event + -- ^ The actual event type. Note that this can be a serialized event or the + -- actual Haskell event type. + } deriving (Show, Eq, Functor, Foldable, Traversable) + +-- | Event versions are a strictly increasing series of integers for each +-- projection. They allow us to order the events when they are replayed, and +-- they also help as a concurrency check in a multi-threaded environment so +-- services modifying the projection can be sure the projection didn't change +-- during their execution. +newtype EventVersion = EventVersion { unEventVersion :: Int } + deriving (Show, Read, Ord, Eq, Enum, Num, FromJSON, ToJSON) + +-- | The sequence number gives us a global ordering of events in a particular +-- event store. Using sequence numbers is not strictly necessary for an event +-- sourcing and CQRS system, but it makes it way easier to replay events +-- consistently without having to use distributed transactions in an event bus. +-- In SQL-based event stores, they are also very cheap to create. +newtype SequenceNumber = SequenceNumber { unSequenceNumber :: Int } + deriving (Show, Read, Ord, Eq, Enum, Num, FromJSON, ToJSON, + PathPiece, ToHttpApiData, FromHttpApiData) diff --git a/src/Eventful/TH.hs b/src/Eventful/TH.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/TH.hs @@ -0,0 +1,7 @@ +module Eventful.TH + ( module X + ) where + +import Eventful.TH.Projection as X +import Eventful.TH.SumType as X +import Eventful.TH.SumTypeSerializer as X diff --git a/src/Eventful/TH/Projection.hs b/src/Eventful/TH/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/TH/Projection.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Eventful.TH.Projection + ( mkProjection + ) where + +import Data.Char (toLower) +import Language.Haskell.TH + +import Eventful.Projection +import Eventful.TH.SumType + +-- | Creates a 'Projection' for a given type and a list of events. The user of +-- this function also needs to provide event handlers for each event. For +-- example: +-- +-- @ +-- data EventA = EventA +-- data EventB = EventB +-- +-- data MyState = MyState Int +-- +-- myStateDefault :: MyState +-- myStateDefault = MyState 0 +-- +-- mkProjection ''MyState 'myStateDefault [''EventA, ''EventB] +-- +-- handleEventA :: MyState -> EventA -> MyState +-- handleEventA (MyState x) EventA = MyState (x + 1) +-- +-- handleEventB :: MyState -> EventB -> MyState +-- handleEventB (MyState x) EventB = MyState (x - 1) +-- @ +-- +-- This will produce the following: +-- +-- @ +-- data MyStateEvent = MyStateEventA !EventA | MyStateEventB !EventB +-- +-- handleMyStateEvent :: MyState -> MyStateEvent -> MyState +-- handleMyStateEvent state (MyStateEventA event) = handleEventA state event +-- handleMyStateEvent state (MyStateEventB event) = handleEventB state event +-- +-- type MyStateProjection = Projection MyState MyStateEvent +-- +-- myStateProjection :: MyStateProjection +-- myStateProjection = Projection myStateDefault handleMyStateEvent +-- @ +mkProjection :: Name -> Name -> [Name] -> Q [Dec] +mkProjection stateName stateDefault events = do + -- Make event sum type + let eventTypeName = nameBase stateName ++ "Event" + sumTypeDecls <- mkSumType eventTypeName (nameBase stateName ++) events + + -- Make function to handle events from sum type to handlers. + let handleFuncName = mkName $ "handle" ++ eventTypeName + handleFuncType <- [t| $(conT stateName) -> $(conT $ mkName eventTypeName) -> $(conT stateName) |] + handleFuncBodies <- mapM (handleFuncBody stateName) events + let + handleTypeDecls = + [ SigD handleFuncName handleFuncType + , FunD handleFuncName handleFuncBodies + ] + + -- Make the projection type + projectionType <- [t| Projection $(conT stateName) $(conT $ mkName eventTypeName) |] + let + projectionTypeName = mkName $ nameBase stateName ++ "Projection" + projectionTypeDecl = TySynD projectionTypeName [] projectionType + + -- Make the projection + projectionFuncExpr <- [e| Projection $(varE stateDefault) $(varE handleFuncName) |] + let + projectionFuncName = mkName $ firstCharToLower (nameBase stateName) ++ "Projection" + projectionFuncClause = Clause [] (NormalB projectionFuncExpr) [] + projectionDecls = + [ SigD projectionFuncName (ConT projectionTypeName) + , FunD projectionFuncName [projectionFuncClause] + ] + + return $ sumTypeDecls ++ handleTypeDecls ++ [projectionTypeDecl] ++ projectionDecls + +handleFuncBody :: Name -> Name -> Q Clause +handleFuncBody stateName event = do + let + statePattern = VarP (mkName "state") + eventPattern = ConP (mkName $ nameBase stateName ++ nameBase event) [VarP (mkName "event")] + handleFuncName = mkName $ "handle" ++ nameBase event + constructor <- [e| $(varE handleFuncName) $(varE $ mkName "state") $(varE $ mkName "event") |] + return $ Clause [statePattern, eventPattern] (NormalB constructor) [] + +firstCharToLower :: String -> String +firstCharToLower [] = [] +firstCharToLower (x:xs) = toLower x : xs diff --git a/src/Eventful/TH/SumType.hs b/src/Eventful/TH/SumType.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/TH/SumType.hs @@ -0,0 +1,51 @@ +module Eventful.TH.SumType + ( mkSumType + , mkSumType' + ) where + +import Language.Haskell.TH + +-- | This is a template haskell function that creates a sum type from a list of +-- types. This is very useful when creating an event type for a 'Projection' +-- from a list of events in your system. Here is an example: +-- +-- @ +-- data EventA = EventA +-- data EventB = EventB +-- data EventC = EventC +-- +-- mkSumType "MyEvent" ("MyEvent" ++) [''EventA, ''EventB, ''EventC] +-- @ +-- +-- This will produce the following sum type: +-- +-- @ +-- data MyEvent +-- = MyEventEventA EventA +-- | MyEventEventB EventB +-- | MyEventEventC EventC +-- @ +-- +-- Note that you can use standalone deriving to derive any instances you want: +-- +-- @ +-- deriving instance Show MyEvent +-- deriving instance Eq MyEvent +-- @ +mkSumType :: String -> (String -> String) -> [Name] -> Q [Dec] +mkSumType typeName mkConstructorName eventTypes = do + let + mkConstructor eventName = + NormalC + (mkName . mkConstructorName . nameBase $ eventName) + [(Bang NoSourceUnpackedness SourceStrict, ConT eventName)] + constructors = map mkConstructor eventTypes + return [DataD [] (mkName typeName) [] Nothing constructors []] + +-- | Variant of mkSumType that just appends a @'@ to each constructor. +-- +-- @ +-- mkSumType' name events = mkSumType name (++ "'") events +-- @ +mkSumType' :: String -> [Name] -> Q [Dec] +mkSumType' name = mkSumType name (++ "'") diff --git a/src/Eventful/TH/SumTypeSerializer.hs b/src/Eventful/TH/SumTypeSerializer.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/TH/SumTypeSerializer.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Eventful.TH.SumTypeSerializer + ( mkSumTypeSerializer + ) where + +import Data.Char (toLower) +import Data.List (lookup) +import Language.Haskell.TH + +-- | This is a template haskell function that creates a 'Serializer' between +-- two sum types. The first sum type must be a subset of the second sum type. +-- This is useful in situations where you define all the events in your system +-- in one type, and you want to create sum types that are subsets for each +-- 'Projection'. +-- +-- For example, assume we have the following three event types and two sum +-- types holding these events: +-- +-- @ +-- data EventA = EventA +-- data EventB = EventB +-- data EventC = EventC +-- +-- data AllEvents +-- = AllEventsEventA EventA +-- | AllEventsEventB EventB +-- | AllEventsEventC EventC +-- +-- data MyEvents +-- = MyEventsEventA EventA +-- | MyEventsEventB EventB +-- @ +-- +-- In this case, @AllEvents@ holds all the events in our system, and @MyEvents@ +-- holds some subset of @AllEvents@. If we run +-- +-- @ +-- mkSumTypeSerializer "myEventsSerializer" ''MyEvents ''AllEvents +-- @ +-- +-- we will produce the following code: +-- +-- @ +-- -- Serialization function +-- myEventsToAllEvents :: MyEvents -> AllEvents +-- myEventsToAllEvents (MyEventsEventA e) = AllEventsEventA e +-- myEventsToAllEvents (MyEventsEventB e) = AllEventsEventB e +-- +-- -- Deserialization function +-- allEventsToMyEvents :: AllEvents -> Maybe MyEvents +-- allEventsToMyEvents (AllEventsEventA e) = Just (MyEventsEventA e) +-- allEventsToMyEvents (AllEventsEventB e) = Just (MyEventsEventB e) +-- allEventsToMyEvents _ = Nothing +-- +-- -- Serializer +-- myEventsSerializer :: Serializer MyEvents AllEvents +-- myEventsSerializer = simpleSerializer myEventsToAllEvents allEventsToMyEvents +-- @ +mkSumTypeSerializer :: String -> Name -> Name -> Q [Dec] +mkSumTypeSerializer serializerName sourceType targetType = do + -- Get the constructors for both types and match them up based on event type. + sourceConstructors <- typeConstructors sourceType + targetConstructors <- typeConstructors targetType + bothConstructors <- mapM (matchConstructor targetConstructors) sourceConstructors + + -- Construct the serialization function + let + serializeFuncName = mkName $ firstCharToLower (nameBase sourceType) ++ "To" ++ nameBase targetType + serializeFuncClauses = map mkSerializeFunc bothConstructors + serializeTypeDecl <- [t| $(conT sourceType) -> $(conT targetType) |] + + -- Construct the deserialization function + let + deserializeFuncName = mkName $ firstCharToLower (nameBase targetType) ++ "To" ++ nameBase sourceType + wildcardDeserializeClause = Clause [WildP] (NormalB (ConE 'Nothing)) [] + deserializeFuncClauses = map mkDeserializeFunc bothConstructors ++ [wildcardDeserializeClause] + deserializeTypeDecl <- [t| $(conT targetType) -> Maybe $(conT sourceType) |] + + -- Construct the serializer + serializerTypeDecl <- [t| $(conT $ mkName "Serializer") $(conT sourceType) $(conT targetType) |] + serializerExp <- [e| $(varE $ mkName "simpleSerializer") $(varE serializeFuncName) $(varE deserializeFuncName) |] + let + serializerClause = Clause [] (NormalB serializerExp) [] + + return + [ -- Serialization + SigD serializeFuncName serializeTypeDecl + , FunD serializeFuncName serializeFuncClauses + + -- Deserialization + , SigD deserializeFuncName deserializeTypeDecl + , FunD deserializeFuncName deserializeFuncClauses + + -- Serializer + , SigD (mkName serializerName) serializerTypeDecl + , FunD (mkName serializerName) [serializerClause] + ] + +-- | Extract the constructors and event types for the given type. +typeConstructors :: Name -> Q [(Type, Name)] +typeConstructors typeName = do + info <- reify typeName + case info of + (TyConI (DataD _ _ _ _ constructors _)) -> mapM go constructors + where + go (NormalC name []) = fail $ "Constructor " ++ nameBase name ++ " doesn't have any arguments" + go (NormalC name [(_, type')]) = return (type', name) + go (NormalC name _) = fail $ "Constructor " ++ nameBase name ++ " has more than one argument" + go _ = fail $ "Invalid constructor in " ++ nameBase typeName + _ -> fail $ nameBase typeName ++ " must be a sum type" + +-- | Find the corresponding target constructor for a given source constructor. +matchConstructor :: [(Type, Name)] -> (Type, Name) -> Q BothConstructors +matchConstructor targetConstructors (type', sourceConstructor) = do + targetConstructor <- + maybe + (fail $ "Can't find constructor in target type corresponding to " ++ nameBase sourceConstructor) + return + (lookup type' targetConstructors) + return $ BothConstructors type' sourceConstructor targetConstructor + +-- | Utility type to hold the source and target constructors for a given event +-- type. +data BothConstructors = + BothConstructors + { eventType :: Type + , sourceConstructor :: Name + , targetConstructor :: Name + } + +-- | Construct the TH function 'Clause' for the serialization function for a +-- given type. +mkSerializeFunc :: BothConstructors -> Clause +mkSerializeFunc BothConstructors{..} = + let + patternMatch = ConP sourceConstructor [VarP (mkName "e")] + constructor = AppE (ConE targetConstructor) (VarE (mkName "e")) + in Clause [patternMatch] (NormalB constructor) [] + +-- | Construct the TH function 'Clause' for the deserialization function for a +-- given type. +mkDeserializeFunc :: BothConstructors -> Clause +mkDeserializeFunc BothConstructors{..} = + let + patternMatch = ConP targetConstructor [VarP (mkName "e")] + constructor = AppE (ConE 'Just) (AppE (ConE sourceConstructor) (VarE (mkName "e"))) + in Clause [patternMatch] (NormalB constructor) [] + +firstCharToLower :: String -> String +firstCharToLower [] = [] +firstCharToLower (x:xs) = toLower x : xs diff --git a/src/Eventful/UUID.hs b/src/Eventful/UUID.hs new file mode 100644 --- /dev/null +++ b/src/Eventful/UUID.hs @@ -0,0 +1,67 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} + +-- | This module contains orphan 'UUID' instances and a few convenience +-- functions around UUIDs. It would be great if this were its own entirely +-- separate package. + +module Eventful.UUID + ( UUID + , uuidFromText + , uuidToText + , nil + , uuidNextRandom + , uuidFromInteger + ) where + +import Data.UUID +import qualified Data.UUID.V4 as UUID4 + +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) +import Text.Printf (printf) +import Web.PathPieces + +#if MIN_VERSION_aeson(1,1,0) + +#else +import Data.Aeson (ToJSON (..), FromJSON (..)) + +instance ToJSON UUID where + toJSON uuid = toJSON (toText uuid) + +instance FromJSON UUID where + parseJSON text = do + uuid <- parseJSON text + maybe (fail $ "Error parsing UUID " ++ show uuid) pure (fromText uuid) +#endif + +uuidFromText :: Text -> Maybe UUID +uuidFromText = fromText + +uuidToText :: UUID -> Text +uuidToText = toText + +uuidNextRandom :: IO UUID +uuidNextRandom = UUID4.nextRandom + +instance PathPiece UUID where + fromPathPiece = uuidFromText + toPathPiece = uuidToText + +-- | Constructs a valid 'UUID' from an 'Integer' by padding with zeros. Useful +-- for testing. +-- +-- >>> uuidFromInteger 1 +-- 00000000-0000-0000-0000-000000000001 +uuidFromInteger :: Integer -> UUID +uuidFromInteger i = + let rawString = take 32 $ printf "%032x" i + (p1, rest1) = splitAt 8 rawString + (p2, rest2) = splitAt 4 rest1 + (p3, rest3) = splitAt 4 rest2 + (p4, p5) = splitAt 4 rest3 + withHyphens = intercalate "-" [p1, p2, p3, p4, p5] + mUuid = uuidFromText . pack $ withHyphens + in fromMaybe (error $ "Failure in uuidFrominteger for: " ++ show i) mUuid diff --git a/tests/Eventful/SerializerSpec.hs b/tests/Eventful/SerializerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Eventful/SerializerSpec.hs @@ -0,0 +1,53 @@ +module Eventful.SerializerSpec (spec) where + +import Data.Dynamic +import GHC.Generics +import Test.Hspec + +import Eventful.Serializer +import Eventful.TH.SumTypeSerializer + +data EventA = EventA deriving (Show, Eq) +data EventB = EventB deriving (Show, Eq) +data EventC = EventC deriving (Show, Eq) + +data AllEvents + = AllEventsEventA EventA + | AllEventsEventB EventB + | AllEventsEventC EventC + deriving (Show, Eq, Generic) + +instance EventSumType AllEvents + +data MyEvents + = MyEventsEventA EventA + | MyEventsEventB EventB + deriving (Show, Eq, Generic) + +instance EventSumType MyEvents + +mkSumTypeSerializer "myEventsSerializer" ''MyEvents ''AllEvents + +spec :: Spec +spec = do + describe "EventSumType" $ do + it "can serialize events without the constructor" $ do + dynTypeRep (eventToDyn $ MyEventsEventA EventA) `shouldBe` typeOf EventA + dynTypeRep (eventToDyn $ MyEventsEventA EventA) `shouldBe` dynTypeRep (eventToDyn $ AllEventsEventA EventA) + + it "can deserialize events with the constructor" $ do + eventFromDyn (toDyn EventA) `shouldBe` Just (MyEventsEventA EventA) + eventFromDyn (toDyn EventB) `shouldBe` Just (AllEventsEventB EventB) + + eventFromDyn (eventToDyn $ MyEventsEventA EventA) `shouldBe` Just (AllEventsEventA EventA) + eventFromDyn (eventToDyn $ AllEventsEventB EventB) `shouldBe` Just (MyEventsEventB EventB) + + describe "mkSumTypeSerializer" $ do + it "can serialize events" $ do + serialize myEventsSerializer (MyEventsEventA EventA) `shouldBe` AllEventsEventA EventA + serialize myEventsSerializer (MyEventsEventB EventB) `shouldBe` AllEventsEventB EventB + + it "can deserialize events" $ do + deserialize myEventsSerializer (AllEventsEventA EventA) `shouldBe` Just (MyEventsEventA EventA) + deserialize myEventsSerializer (AllEventsEventB EventB) `shouldBe` Just (MyEventsEventB EventB) + deserialize myEventsSerializer (AllEventsEventC EventC) `shouldBe` Nothing diff --git a/tests/Eventful/TH/SumTypeSpec.hs b/tests/Eventful/TH/SumTypeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Eventful/TH/SumTypeSpec.hs @@ -0,0 +1,21 @@ +module Eventful.TH.SumTypeSpec (spec) where + +import Test.Hspec + +import Eventful.TH.SumType + +data EventA = EventA deriving (Show, Eq) +data EventB = EventB deriving (Show, Eq) +data EventC = EventC deriving (Show, Eq) + +mkSumType' "MyEvent" [''EventA, ''EventB, ''EventC] + +deriving instance Show MyEvent +deriving instance Eq MyEvent + +spec :: Spec +spec = do + describe "mkSumType" $ do + it "can create events" $ do + -- The real utility in this test is the fact that it compiles + length [EventA' EventA, EventB' EventB, EventC' EventC] `shouldBe` 3 diff --git a/tests/HLint.hs b/tests/HLint.hs new file mode 100644 --- /dev/null +++ b/tests/HLint.hs @@ -0,0 +1,21 @@ +module Main (main) where + +import Language.Haskell.HLint (hlint) +import System.Exit (exitFailure, exitSuccess) + +import Prelude (String, IO, null) + +arguments :: [String] +arguments = + [ "src" + , "tests" + , "-i=Redundant do" + , "-i=Unused LANGUAGE pragma" -- This fails on DeriveGeneric + , "-i=Use newtype instead of data" + , "-i=Eta reduce" + ] + +main :: IO () +main = do + hints <- hlint arguments + if null hints then exitSuccess else exitFailure diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}