cqrs-example (empty) → 0.4.0

raw patch · 6 files changed

+233/−0 lines, 6 filesdep +basedep +cerealdep +cqrssetup-changed

Dependencies added: base, cereal, cqrs, data-default, text, transformers

Files

LICENSE +19/−0
Setup.hs +2/−0
cqrs-example.cabal +28/−0
src/Aggregates.hs +105/−0
src/Events.hs +44/−0
src/Main.hs +35/−0

+ LICENSE view

@@ -0,0 +1,19 @@+Copyright (c) 2011 Bardur Arantsson++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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ cqrs-example.cabal view

@@ -0,0 +1,28 @@+Name:                cqrs-example+Version:             0.4.0+Synopsis:            Example for cqrs package+License:             MIT+License-file:        LICENSE+Author:              Bardur Arantsson+Maintainer:          spam@scientician.net+Category:            Web+Build-type:          Simple+Cabal-version:       >=1.6.0.1++Executable cqrs-example+  Main-is:           Main.hs+  Build-depends:     base == 4.*+                   , cereal >= 0.3 && < 0.4+                   , cqrs >= 0.4 && < 0.5+                   , data-default >= 0.3 && < 0.4+                   , text >= 0.11 && < 0.12+                   , transformers >= 0.2.2 && < 0.3+  Ghc-options:       -Wall+  Extensions:        DeriveDataTypeable+                     MultiParamTypeClasses+                     OverloadedStrings+                     ScopedTypeVariables+  Hs-source-dirs:    src+  Other-modules:     Aggregates+                     Events+

+ src/Aggregates.hs view

@@ -0,0 +1,105 @@+module Aggregates+       ( Project(..)+       , ProjectId+       , ProjectState(..)+       , Task(..)+       , TaskId+       , TaskState(..)+       ) where++import Control.Monad (liftM)+import Data.CQRS (Aggregate(..), GUID)+import Data.Default (Default(..))+import Data.Serialize (Serialize(..), decode, encode)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Typeable (Typeable)+import Data.Word (Word8)++-- Projects.++type ProjectId = GUID Project++data ProjectState = New+                  | Active+                  deriving (Eq, Typeable)++instance Serialize ProjectState where+  put New = put (0 :: Word8)+  put Active = put (1 :: Word8)+  get = do+    i :: Word8 <- get+    case i of+      0 -> return New+      1 -> return Active+      _ -> fail $ "Cannot decode project state: " ++ show i++data Project = Project { projectName :: Text+                       , projectState :: ProjectState+                       }+               deriving (Typeable)++instance Serialize Project where+  put (Project pn ps) = do+    put $ encodeUtf8 pn+    put ps+  get = do+    pn <- liftM decodeUtf8 get+    ps <- get+    return $ Project pn ps++instance Aggregate Project where+  encodeAggregate = encode+  decodeAggregate s =+    case decode s of+      Left e -> error e+      Right a -> a++instance Default Project where+  def = Project T.empty New++-- Tasks.++type TaskId = GUID Task++data TaskState = TaskNew+               | TaskActive+                 deriving (Eq, Typeable)++instance Serialize TaskState where+  put TaskNew = put (0 :: Word8)+  put TaskActive = put (1 :: Word8)+  get = do+    i :: Word8 <- get+    case i of+      0 -> return TaskNew+      1 -> return TaskActive+      _ -> fail $ "Cannot decode task state: " ++ show i++data Task = Task { taskProjectId :: ProjectId+                 , taskState :: TaskState+                 , taskShortDescription :: Text+                 }+            deriving (Typeable)++instance Serialize Task where+  put (Task tpid ts tsd) = do+    put tpid+    put ts+    put $ encodeUtf8 tsd+  get = do+    tpid <- get+    ts <- get+    tsd <- liftM decodeUtf8 get+    return $ Task tpid ts tsd++instance Aggregate Task where+  encodeAggregate = encode+  decodeAggregate s =+    case decode s of+      Left e -> error e+      Right a -> a++instance Default Task where+  def = Task def TaskNew T.empty

+ src/Events.hs view

@@ -0,0 +1,44 @@+module Events+       ( ExampleEvent(..)+       ) where++import Aggregates+import Control.Monad (liftM)+import Data.Serialize (Serialize(..))+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Typeable (Typeable)+import Data.Word (Word8)++data ExampleEvent = CreateProject Text+                  | RenameProject Text+                  | AddTask ProjectId Text+                    deriving (Typeable)++instance Serialize ExampleEvent where+  put (CreateProject name) = do+    put (0 :: Word8)+    put $ encodeUtf8 name+  put (RenameProject name) = do+    put (1 :: Word8)+    put $ encodeUtf8 name+  put (AddTask pid tsd) = do+    put (2 :: Word8)+    put $ pid+    put $ encodeUtf8 tsd+  get = do+    i :: Word8 <- get+    case i of+      0 -> do+        n <- liftM decodeUtf8 get+        return $ CreateProject n+      1 -> do+        n <- liftM decodeUtf8 get+        return $ RenameProject n+      2 -> do+        pid <- get+        tsd <- liftM decodeUtf8 get+        return $ AddTask pid tsd+      _ -> do+        fail $ "Unrecognized event type " ++ show i+

+ src/Main.hs view

@@ -0,0 +1,35 @@+import Control.Monad.Trans.Class (lift)+import Data.CQRS+import Data.CQRS.EventStore (withEventStore)+import Data.CQRS.EventStore.Sqlite3+import Aggregates+import Events+import Instances ()++sqliteFile :: String+sqliteFile = "example.db"++test1 :: IO ()+test1 =+    withEventStore (openSqliteEventStore sqliteFile) $ \eventStore -> do+      runTransactionT eventStore $ do+        -- Create new project.+        projectId :: GUID Project <- lift $ newGUID+        (projectRef, _) <- getAggregateRoot projectId+        publishEvent projectRef $ CreateProject "my project"++        -- Add a couple of tasks+        taskId1 :: GUID Task <- lift $ newGUID+        (taskRef1, _) <- getAggregateRoot taskId1+        publishEvent taskRef1 $ AddTask projectId "tweak knob"++        taskId2 :: GUID Task <- lift $ newGUID+        (taskRef2, _) <- getAggregateRoot taskId2+        publishEvent taskRef2 $ AddTask projectId "pull lever"++main :: IO ()+main = do+  putStrLn "Running test1..."+  test1+  putStrLn "Done."+