diff --git a/cqrs-example.cabal b/cqrs-example.cabal --- a/cqrs-example.cabal +++ b/cqrs-example.cabal @@ -1,5 +1,5 @@ Name: cqrs-example -Version: 0.7.1 +Version: 0.8.0 Synopsis: Example for cqrs package Description: Example for cqrs package License: MIT @@ -15,35 +15,47 @@ Ghc-options: -Wall Build-depends: base == 4.* , aeson >= 0.3.2.12 && <0.4 + , base64-bytestring >= 0.1 && <0.2 + , blaze-builder >= 0.3 && <0.4 , bytestring >= 0.9 && < 0.10 + , case-insensitive >= 0.2 && < 0.3 , cereal >= 0.3 && < 0.4 + , conduit >= 0.1 && < 0.2 , containers >= 0.4 && < 0.5 , convertible >= 1.0.11.0 && < 1.1 - , cqrs >= 0.7.1 && < 0.8 - , cqrs-sqlite3 >= 0.7.1 && < 0.8 + , cqrs >= 0.8.0 && < 0.9 + , cqrs-sqlite3 >= 0.8.0 && < 0.9 , data-default >= 0.3 && < 0.4 - , enumerator >= 0.4.15 && < 0.5 - , happstack-lite >= 6.0 && < 7.0 - , happstack-server >= 6.3 && < 7.0 - , happstack-util >= 6.0 && < 7.0 , HDBC >= 2.3.1.0 && < 2.4 , HDBC-sqlite3 >= 2.3.3.0 && < 2.4 + , http-types >= 0.6 && <0.7 , old-locale >= 1.0 && < 1.1 + , safecopy >= 0.6 && <0.7 + , strict-concurrency >= 0.2 && < 0.3 , text >= 0.11 && < 0.12 , time >= 1.2 && < 1.3 , transformers >= 0.2.2 && < 0.3 + , wai >= 1.0.0 && < 1.1 + , wai-app-static >= 1.0 && < 1.1 + , wai-eventsource >= 1.0 && < 1.1 + , wai-extra >= 1.0 && < 1.1 + , warp >= 1.0.0 && < 1.1 Default-extensions: DeriveDataTypeable MultiParamTypeClasses OverloadedStrings ScopedTypeVariables + TemplateHaskell Hs-source-dirs: src Other-modules: CQRSExample.Aggregates CQRSExample.Command - CQRSExample.Controller.Auth + CQRSExample.Duration CQRSExample.Events CQRSExample.Instances CQRSExample.Json CQRSExample.Query + CQRSExample.Wai + CQRSExample.WaiAuth + CQRSExample.WaiParameters Default-language: Haskell2010 Test-Suite cqrs-example-tests @@ -53,12 +65,13 @@ build-depends: base == 4.* , bytestring >= 0.9 && < 0.10 , cereal >= 0.3 && < 0.4 + , conduit >= 0.1 && < 0.2 , containers >= 0.4 && < 0.5 - , cqrs >= 0.7.1 && < 0.8 - , cqrs-sqlite3 >= 0.7.1 && < 0.8 + , cqrs >= 0.8.0 && < 0.9 + , cqrs-sqlite3 >= 0.8.0 && < 0.9 , data-default >= 0.3 && < 0.4 , direct-sqlite >= 1.1 && < 1.2 - , enumerator >= 0.4.15 && < 0.5 + , safecopy >= 0.6 && <0.7 , text >= 0.11 && < 0.12 , time >= 1.2 && < 1.3 , transformers >= 0.2.2 && < 0.3 @@ -74,4 +87,4 @@ MultiParamTypeClasses OverloadedStrings ScopedTypeVariables - + TemplateHaskell diff --git a/src/CQRSExample/Aggregates.hs b/src/CQRSExample/Aggregates.hs --- a/src/CQRSExample/Aggregates.hs +++ b/src/CQRSExample/Aggregates.hs @@ -11,33 +11,18 @@ , WorkUnitId ) where -import Control.Monad (liftM) +import CQRSExample.Duration (Duration) import Data.CQRS (Aggregate(..), GUID) -import Data.CQRS.Serialize (decode') +import Data.CQRS.Serialize (decode', encode) import Data.Default (Default(..)) import Data.Map (Map) +import Data.SafeCopy (base, deriveSafeCopySimple) import Data.Set (Set) import qualified Data.Set as S -import Data.Serialize (Serialize(..), encode) import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time.Calendar(Day(..), toGregorian, fromGregorian) +import Data.Time.Calendar(Day(..)) import Data.Typeable (Typeable) -import Data.Word (Word8) --- Instances for Haskell built-ins. -instance Serialize Day where - put = put . toGregorian - get = do - (a,b,c) <- get - return $ fromGregorian a b c - --- Instance for Text. We'll just serialize all of it as UTF-8, --- there's very little point in doing otherwise for our use case. -instance Serialize Text where - put = put . encodeUtf8 - get = fmap decodeUtf8 get - -- Site aggregate. This keeps track of things which must be "per site" -- (per installation), e.g. a list of used user names such that we -- can be sure that there are no users with the same login name. @@ -47,12 +32,6 @@ data Site = Site { sUserNames :: Set Text } deriving (Typeable, Eq, Show) -instance Serialize Site where - put (Site suns) = - put suns - get = do - fmap Site get - instance Aggregate Site where encodeAggregate = encode decodeAggregate = decode' @@ -68,42 +47,24 @@ type ProjectId = GUID -data Project = DefaultProject +data Project = UninitializedProject | ActiveProject { projectName :: Text , projectCustomer :: Text } deriving (Typeable, Eq, Show) -instance Serialize Project where - put DefaultProject = do - put (0 :: Word8) - put (ActiveProject pn pc) = do - put (1 :: Word8) - put $ encodeUtf8 pn - put $ encodeUtf8 pc - get = do - i :: Word8 <- get - case i of - 0 -> return DefaultProject - 1 -> do - pn <- liftM decodeUtf8 get - pc <- liftM decodeUtf8 get - return $ ActiveProject pn pc - _ -> - fail $ "Cannot decode project state" ++ show i - instance Aggregate Project where encodeAggregate = encode decodeAggregate = decode' instance Default Project where - def = DefaultProject + def = UninitializedProject -- Tasks. type TaskId = GUID -data Task = NewTask +data Task = UninitializedTask | ActiveTask { taskProjectId :: ProjectId , taskShortDescription :: Text , taskLongDescription :: Text @@ -111,41 +72,18 @@ } deriving (Typeable, Eq, Show) -instance Serialize Task where - put NewTask = do - put (0 :: Word8) - put (ActiveTask tpid tsd tld twu) = do - put (1 :: Word8) - put tpid - put $ encodeUtf8 tsd - put $ encodeUtf8 tld - put twu - get = do - i :: Word8 <- get - case i of - 0 -> return NewTask - 1 -> do - tpid <- get - tsd <- liftM decodeUtf8 get - tld <- liftM decodeUtf8 get - twu <- get - return $ ActiveTask tpid tsd tld twu - _ -> - fail $ "Cannot decode task state: " ++ show i - - instance Aggregate Task where encodeAggregate = encode decodeAggregate = decode' instance Default Task where - def = NewTask + def = UninitializedTask -- Users. type UserId = GUID -data User = UncreatedUser +data User = UninitializedUser | ActiveUser { auUserName :: Text , auPassword :: Text , auLastName :: Text @@ -153,34 +91,12 @@ } deriving (Typeable, Eq, Show) -instance Serialize User where - put UncreatedUser = do - put $ (0 :: Word8) - put (ActiveUser auun aupw auln aufn) = do - put $ (1 :: Word8) - put $ encodeUtf8 auun - put $ encodeUtf8 aupw - put $ encodeUtf8 auln - put $ encodeUtf8 aufn - get = do - i :: Word8 <- get - case i of - 0 -> return UncreatedUser - 1 -> do - auun <- liftM decodeUtf8 get - aupw <- liftM decodeUtf8 get - auln <- liftM decodeUtf8 get - aufn <- liftM decodeUtf8 get - return $ ActiveUser auun aupw auln aufn - _ -> - fail $ "Cannot decode user state: " ++ show i - instance Aggregate User where encodeAggregate = encode decodeAggregate = decode' instance Default User where - def = UncreatedUser + def = UninitializedUser -- Work Units (NOT aggregates!) @@ -188,20 +104,15 @@ data WorkUnit = WorkUnit { workUnitId :: GUID , workUnitComment :: Text - , workUnitDuration :: Integer + , workUnitDuration :: Duration , workUnitUser :: UserId } deriving (Eq, Show) -instance Serialize WorkUnit where - put (WorkUnit wuid wuc wud wuu) = do - put $ wuid - put $ encodeUtf8 wuc - put wud - put wuu - get = do - wuid <- get - wuc <- liftM decodeUtf8 get - wud <- get - wuu <- get - return $ WorkUnit wuid wuc wud wuu +-- SafeCopy instances. + +$(deriveSafeCopySimple 1 'base ''Task) +$(deriveSafeCopySimple 1 'base ''Site) +$(deriveSafeCopySimple 1 'base ''Project) +$(deriveSafeCopySimple 1 'base ''User) +$(deriveSafeCopySimple 1 'base ''WorkUnit) diff --git a/src/CQRSExample/Command.hs b/src/CQRSExample/Command.hs --- a/src/CQRSExample/Command.hs +++ b/src/CQRSExample/Command.hs @@ -12,12 +12,14 @@ import Control.Monad (when, void) import Control.Monad.Trans.Class (lift) import CQRSExample.Aggregates +import CQRSExample.Duration (Duration) import CQRSExample.Events import CQRSExample.Instances () import Data.CQRS import qualified Data.Set as S import Data.Text (Text) import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) -- Perform any needed site initialization. siteInitialization :: TransactionT Event IO () @@ -34,11 +36,11 @@ (siteRef, site :: Site) <- getAggregateRoot siteGUID when (S.member userName $ sUserNames site) $ fail $ "User already exists: " ++ (show userName) -- Add user to site aggregate. - publishEvent siteRef $ UserRegistered userName + publishEvent siteRef $ SiteEvent $ UserRegistered userName -- Publish to the user aggregate. userId <- lift $ newGUID (userRef, _ :: User) <- getAggregateRoot userId - publishEvent userRef $ UserCreated userName password firstName lastName + publishEvent userRef $ UserEvent $ UserCreated userName password firstName lastName return userId -- Create a new project. @@ -46,43 +48,44 @@ createProject name shortDescription = do projectId <- lift $ newGUID (projectRef, _ :: Project) <- getAggregateRoot projectId - publishEvent projectRef $ ProjectCreated name shortDescription + publishEvent projectRef $ ProjectEvent $ ProjectCreated name shortDescription return projectId -- Rename project. renameProject :: ProjectId -> Text -> TransactionT Event IO () renameProject projectId newName = do (projectRef, _ :: Project) <- getAggregateRoot projectId - publishEvent projectRef $ ProjectRenamed newName + publishEvent projectRef $ ProjectEvent $ ProjectRenamed newName -- Create new task in a project. -createTask :: ProjectId -> Text -> TransactionT Event IO TaskId -createTask projectId shortDescription = do +createTask :: ProjectId -> Text -> Duration -> UserId -> TransactionT Event IO TaskId +createTask projectId shortDescription estimate userId = do taskId <- lift $ newGUID (taskRef, _ :: Task) <- getAggregateRoot taskId - publishEvent taskRef $ TaskAdded projectId shortDescription + ts <- lift $ getCurrentTime + publishEvent taskRef $ TaskEvent $ TaskAdded projectId shortDescription estimate userId ts return taskId -- Star a task. starTask :: TaskId -> UserId -> TransactionT Event IO () starTask taskId userId = do (taskRef, _ :: Task) <- getAggregateRoot taskId - publishEvent taskRef $ TaskStarred userId + publishEvent taskRef $ TaskEvent $ TaskStarred userId return () -- Unstar a task. unstarTask :: TaskId -> UserId -> TransactionT Event IO () unstarTask taskId userId = do (taskRef, _ :: Task) <- getAggregateRoot taskId - publishEvent taskRef $ TaskUnstarred userId + publishEvent taskRef $ TaskEvent $ TaskUnstarred userId return () -- Log work. Returns the GUID of the newly logged work. -logWork :: TaskId -> UserId -> Day -> Integer -> Text -> TransactionT Event IO WorkUnitId +logWork :: TaskId -> UserId -> Day -> Duration -> Text -> TransactionT Event IO WorkUnitId logWork taskId userId day duration comment = do -- Find the task. (taskRef, _ :: Task) <- getAggregateRoot taskId -- Publish the event to the task. wid <- lift $ newGUID - publishEvent taskRef $ RecordedWorkUnit wid day duration comment userId + publishEvent taskRef $ TaskEvent $ RecordedWorkUnit wid day duration comment userId return wid diff --git a/src/CQRSExample/Controller/Auth.hs b/src/CQRSExample/Controller/Auth.hs deleted file mode 100644 --- a/src/CQRSExample/Controller/Auth.hs +++ /dev/null @@ -1,30 +0,0 @@ -module CQRSExample.Controller.Auth - ( basicAuth - ) where - -import Control.Monad.Trans.Class (lift) -import qualified Data.ByteString.Char8 as B -import Data.Foldable (foldMap) -import qualified Happstack.Crypto.Base64 as Base64 -import Happstack.Lite (ServerPart, Response) -import Happstack.Server.Monads (setHeaderM, getHeaderM, escape) -import Happstack.Server.Response (unauthorized, toResponse) - --- | Support for Basic Auth. -basicAuth :: String -> (String -> String -> IO Bool) -> (String -> ServerPart Response) -> ServerPart Response -basicAuth realmName authMap rest = do - aHeader <- getHeaderM "authorization" - case foldMap parseHeader aHeader of - (name, ':':password) -> do - found <- lift $ authMap name password - case found of - True -> rest name - False -> err - _ -> err - where - parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6 - headerName = "WWW-Authenticate" - headerValue = "Basic realm=\"" ++ realmName ++ "\"" - err = escape $ do - setHeaderM headerName headerValue - unauthorized $ toResponse ("Not authorized" :: String) diff --git a/src/CQRSExample/Duration.hs b/src/CQRSExample/Duration.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Duration.hs @@ -0,0 +1,40 @@ +module CQRSExample.Duration + ( Duration + , hours + , minutes + , seconds + , toMinutes + , toSeconds + ) where + +import Data.SafeCopy (base, deriveSafeCopySimple) +import Data.Typeable (Typeable) + +-- | Duration type. +data Duration = Duration Integer + deriving (Typeable, Show, Eq) + +-- | Create a new duration from a number of minutes. +minutes :: Integer -> Duration +minutes m = Duration (60 * m) + +-- | Create a new duration from a number of seconds. +seconds :: Integer -> Duration +seconds s = Duration s + +-- | Create a new duration from a number of hours. +hours :: Integer -> Duration +hours h = Duration (60 * 60 * h) + +-- | Get the number of seconds from a duration. +toSeconds :: Duration -> Integer +toSeconds (Duration s) = s + +-- | Get the number of minutes from a duration. +-- Any seconds are truncated. +toMinutes :: Duration -> Integer +toMinutes (Duration s) = s `div` 60 + +-- SafeCopy instances. + +$(deriveSafeCopySimple 1 'base ''Duration) diff --git a/src/CQRSExample/Events.hs b/src/CQRSExample/Events.hs --- a/src/CQRSExample/Events.hs +++ b/src/CQRSExample/Events.hs @@ -1,96 +1,47 @@ module CQRSExample.Events ( Event(..) + , ProjectEvent(..) + , SiteEvent(..) + , TaskEvent(..) + , UserEvent(..) ) where -import Control.Monad (liftM) import CQRSExample.Aggregates +import CQRSExample.Duration (Duration) import Data.CQRS (GUID) -import Data.Serialize (Serialize(..)) +import Data.SafeCopy (base, deriveSafeCopySimple) import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Data.Typeable (Typeable) -import Data.Word (Word8) -data Event = ProjectCreated Text Text - | ProjectRenamed Text - | TaskAdded ProjectId Text - | RecordedWorkUnit GUID Day Integer Text UserId - | UserCreated Text Text Text Text - | UserRegistered Text - | TaskStarred UserId - | TaskUnstarred UserId +data Event = ProjectEvent ProjectEvent + | TaskEvent TaskEvent + | UserEvent UserEvent + | SiteEvent SiteEvent deriving (Typeable, Show) -instance Serialize Event where - put (ProjectCreated name shortDesc) = do - put (0 :: Word8) - put $ encodeUtf8 name - put $ encodeUtf8 shortDesc - put (ProjectRenamed name) = do - put (1 :: Word8) - put $ encodeUtf8 name - put (TaskAdded pid tsd) = do - put (2 :: Word8) - put $ pid - put $ encodeUtf8 tsd - put (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) = do - put (3 :: Word8) - put $ wuId - put $ wuDay - put $ wuDuration - put $ encodeUtf8 wuComment - put wuUserId - put (UserCreated ucUserName ucPassword ucFirst ucLast) = do - put (4 :: Word8) - put $ encodeUtf8 ucUserName - put $ encodeUtf8 ucPassword -- FIXME: Should really hash the password, shouldn't we? - put $ encodeUtf8 ucFirst - put $ encodeUtf8 ucLast - put (TaskStarred userId) = do - put (5 :: Word8) - put userId - put (TaskUnstarred userId) = do - put (6 :: Word8) - put userId - put (UserRegistered userId) = do - put (7 :: Word8) - put userId - get = do - i :: Word8 <- get - case i of - 0 -> do - n <- liftM decodeUtf8 get - sd <- liftM decodeUtf8 get - return $ ProjectCreated n sd - 1 -> do - n <- liftM decodeUtf8 get - return $ ProjectRenamed n - 2 -> do - pid <- get - tsd <- liftM decodeUtf8 get - return $ TaskAdded pid tsd - 3 -> do - wuId <- get - wuDay <- get - wuDuration <- get - wuComment <- liftM decodeUtf8 get - wuUserId <- get - return $ RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId - 4 -> do - ucUserName <- liftM decodeUtf8 get - ucPassword <- liftM decodeUtf8 get - ucFirst <- liftM decodeUtf8 get - ucLast <- liftM decodeUtf8 get - return $ UserCreated ucUserName ucPassword ucFirst ucLast - 5 -> do - userId <- get - return $ TaskStarred userId - 6 -> do - userId <- get - return $ TaskUnstarred userId - 7 -> do - userId <- get - return $ UserRegistered userId - _ -> do - fail $ "Unrecognized event type " ++ show i +data ProjectEvent = ProjectCreated Text Text + | ProjectRenamed Text + deriving (Typeable, Show) + +data TaskEvent = TaskAdded ProjectId Text Duration UserId UTCTime + | TaskStarred UserId + | TaskUnstarred UserId + | RecordedWorkUnit GUID Day Duration Text UserId + deriving (Typeable, Show) + +data UserEvent = UserCreated Text Text Text Text + deriving (Typeable, Show) + +data SiteEvent = UserRegistered Text + deriving (Typeable, Show) + +-- SafeCopy instances. It is extremely important that compatibility is preserved +-- as detailed in the SafeCopy documentation. + +$(deriveSafeCopySimple 1 'base ''ProjectEvent) +$(deriveSafeCopySimple 1 'base ''TaskEvent) +$(deriveSafeCopySimple 1 'base ''UserEvent) +$(deriveSafeCopySimple 1 'base ''SiteEvent) +$(deriveSafeCopySimple 1 'base ''Event) diff --git a/src/CQRSExample/Instances.hs b/src/CQRSExample/Instances.hs --- a/src/CQRSExample/Instances.hs +++ b/src/CQRSExample/Instances.hs @@ -10,67 +10,85 @@ import qualified Data.Text as T instance Eventable Project Event where - applyEvent (ProjectCreated name shortDesc) DefaultProject = - ActiveProject name shortDesc -- Project changes to "active". - applyEvent (ProjectCreated _ _ ) (ActiveProject _ _) = - error "Invalid ProjectCreated event for project that already exists" - applyEvent (ProjectRenamed _ ) DefaultProject = - error "Cannot rename inactive project" - applyEvent (ProjectRenamed name) project@(ActiveProject _ _) = - project { projectName = name } - applyEvent (TaskAdded _ _) DefaultProject = - error "Cannot add task to inactive project" - applyEvent (TaskAdded _ _) project@(ActiveProject _ _) = - project -- Project doesn't change - applyEvent (RecordedWorkUnit _ _ _ _ _) DefaultProject = - error "Cannot record work on inactive project" - applyEvent (RecordedWorkUnit _ _ _ _ _) project@(ActiveProject _ _) = - project -- Project doesn't change - applyEvent (TaskStarred _) project = - project -- Project doesn't change - applyEvent (TaskUnstarred _) project = - project -- Project doesn't change - applyEvent (UserCreated _ _ _ _) project = + + applyEvent (ProjectEvent projectEvent) project_ = + go projectEvent project_ + where + go (ProjectCreated name shortDesc) UninitializedProject = + ActiveProject name shortDesc -- Project changes to "active". + go (ProjectCreated _ _ ) (ActiveProject _ _) = + error "Invalid ProjectCreated event for project that already exists" + go (ProjectRenamed _ ) UninitializedProject = + error "Cannot rename uninitialized project" + go (ProjectRenamed name) project@(ActiveProject _ _) = + project { projectName = name } + + applyEvent (TaskEvent _) project = project - applyEvent (UserRegistered _) project = + + applyEvent (UserEvent _) project = project + applyEvent (SiteEvent _) project = + project + instance Eventable Task Event where - applyEvent (ProjectCreated _ _) task = task - applyEvent (ProjectRenamed _) task = task - applyEvent (TaskAdded pId tsd) NewTask = - ActiveTask pId tsd T.empty M.empty - applyEvent (TaskAdded _ _) (ActiveTask _ _ _ _) = - error "Cannot add task which already exists" - applyEvent (RecordedWorkUnit _ _ _ _ _) NewTask = - error "Cannot record work on inactive task" - applyEvent (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) task@(ActiveTask _ _ _ workUnits) = - task { taskWorkUnits = M.insert wuDay (WorkUnit wuId wuComment wuDuration wuUserId) workUnits } - applyEvent (UserCreated _ _ _ _) task = task - applyEvent (TaskStarred _) task = task - applyEvent (TaskUnstarred _) task = task - applyEvent (UserRegistered _) task = task + applyEvent (ProjectEvent _) task = + task + + applyEvent (TaskEvent taskEvent) project_ = + go taskEvent project_ + where + go (TaskAdded pId tsd _ _ _) UninitializedTask = + ActiveTask pId tsd T.empty M.empty + go (TaskAdded _ _ _ _ _) (ActiveTask _ _ _ _) = + error "Cannot add task which already exists" + go (TaskStarred _) task = task + go (TaskUnstarred _) task = task + go (RecordedWorkUnit _ _ _ _ _) UninitializedTask = + error "Cannot record work on uninitialized task" + go (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) task@(ActiveTask _ _ _ workUnits) = + task { taskWorkUnits = M.insert wuDay (WorkUnit wuId wuComment wuDuration wuUserId) workUnits } + + applyEvent (UserEvent _) task = + task + + applyEvent (SiteEvent _) task = + task + instance Eventable User Event where - applyEvent (ProjectCreated _ _) user = user - applyEvent (ProjectRenamed _) user = user - applyEvent (TaskAdded _ _) user = user - applyEvent (RecordedWorkUnit _ _ _ _ _) user = user - applyEvent (TaskStarred _) user = user - applyEvent (TaskUnstarred _) user = user - applyEvent (UserCreated _ _ _ _) (ActiveUser _ _ _ _) = - error "User already exists" - applyEvent (UserCreated ucUserName ucPassword ucFirstName ucLastName) UncreatedUser = - ActiveUser ucUserName ucPassword ucFirstName ucLastName - applyEvent (UserRegistered _) user = user + applyEvent (ProjectEvent _) user = + user + + applyEvent (TaskEvent _) user = + user + + applyEvent (UserEvent userEvent) user = + go userEvent user + where + go (UserCreated _ _ _ _) (ActiveUser _ _ _ _) = + error "User already exists" + go (UserCreated ucUserName ucPassword ucFirstName ucLastName) UninitializedUser = + ActiveUser ucUserName ucPassword ucFirstName ucLastName + + applyEvent (SiteEvent _) user = + user + instance Eventable Site Event where - applyEvent (ProjectCreated _ _) site = site - applyEvent (ProjectRenamed _) site = site - applyEvent (TaskAdded _ _) site = site - applyEvent (RecordedWorkUnit _ _ _ _ _) site = site - applyEvent (TaskStarred _) site = site - applyEvent (TaskUnstarred _) site = site - applyEvent (UserCreated _ _ _ _) site = site - applyEvent (UserRegistered ucUserName) site = - site { sUserNames = S.insert ucUserName $ sUserNames site } + + applyEvent (ProjectEvent _) site = + site + + applyEvent (TaskEvent _) site = + site + + applyEvent (UserEvent _) site = + site + + applyEvent (SiteEvent siteEvent) site_ = + go siteEvent site_ + where + go (UserRegistered ucUserName) site = + site { sUserNames = S.insert ucUserName $ sUserNames site } diff --git a/src/CQRSExample/Json.hs b/src/CQRSExample/Json.hs --- a/src/CQRSExample/Json.hs +++ b/src/CQRSExample/Json.hs @@ -1,124 +1,58 @@ module CQRSExample.Json - ( jsonServerPart + ( qProjectListJson + , qTaskListJson + , qTimesheetJson ) where -import Control.Applicative (optional) -import Control.Monad (liftM, void) -import Control.Monad.Trans.Class (lift) -import CQRSExample.Command (logWork, createProject, createTask, starTask, unstarTask) -import CQRSExample.Events (Event) -import CQRSExample.Query -import Data.Aeson (ToJSON, encode, toJSON) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import Data.CQRS (EventStore, runTransactionT) -import Data.CQRS.GUID (GUID, hexEncode, hexDecode) +import Control.Monad (liftM) +import Data.Aeson (ToJSON, Value, toJSON) +import Data.CQRS.GUID (GUID, hexEncode) import Data.List (groupBy) +import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (fromJust) +import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE import Data.Time.Calendar (Day) -import Data.Time.Format (parseTime) import Database.HDBC (IConnection) -import Happstack.Lite -import Happstack.Server.RqData (lookRead) -import System.Locale (defaultTimeLocale) +import CQRSExample.Aggregates (UserId) +import qualified CQRSExample.Duration as D +import CQRSExample.Query + -- Instances. instance ToJSON Day where toJSON d = toJSON $ show d --- Parse request parameter to date. Fails the request --- if the parameter is absent. -lookDay :: String -> ServerPart Day -lookDay pn = do - p <- lookText pn - case parseTime defaultTimeLocale "%F" $ TL.unpack $ p of - Just d -> return d - Nothing -> fail $ "Missing parameter '" ++ pn ++ "'" - --- Retrieve a GUID parameter. -lookGUID :: String -> ServerPart (Maybe GUID) -lookGUID name = do - bs <- optional $ lookBS name - case bs of - Nothing -> return Nothing - Just bs' -> return $ hexDecode $ BS.concat $ BSL.toChunks $ bs' - --- Serve JSON ok response. -okJson :: ToJSON a => a -> ServerPart Response -okJson a = ok $ toResponseBS "text/json" $ encode a - --- Serve a list generated by a monadic action as a JSON response. -listJson :: (IConnection c, ToJSON b) => c -> (c -> IO [a]) -> (a -> b) -> ServerPart Response -listJson connection lister f = do - p <- liftM (map f) $ lift $ lister connection - okJson $ p - --- Serve JSON project list. -projectsJson :: IConnection c => c -> EventStore Event -> ServerPart Response -projectsJson connection eventStore = - msum [ method GET >> getProjects - , method POST >> postProjects - ] - where - getProjects :: ServerPart Response - getProjects = do - (listJson connection qProjectList - (\(g,pn,psd) -> - M.fromList [ (T.pack "id" , TE.decodeUtf8 $ hexEncode g) - , (T.pack "name" , pn) - , (T.pack "short_desc", psd) - ])) - postProjects = do - pn <- fmap TL.toStrict $ lookText "name" - pd <- fmap TL.toStrict $ lookText "shortDescription" - pid <- lift $ runTransactionT eventStore $ do - createProject pn pd - ok $ toResponse $ hexEncode pid +-- Generate a list of JSONable values. +qListToJson :: (IConnection c, ToJSON b) => (c -> IO [a]) -> (a -> b) -> c -> IO [b] +qListToJson lister f conn = liftM (map f) $ lister conn --- Serve JSON task list. -tasksJson :: IConnection c => c -> EventStore Event -> String -> ServerPart Response -tasksJson connection eventStore userName = - msum [ method GET >> getTasks - , method POST >> postTasks - ] - where - getTasks :: ServerPart Response - getTasks = do - projectId <- lookGUID "projectId" - (listJson connection (qTaskList userName projectId) - (\(g,tsd,starred) -> - M.fromList [ (T.pack "id" , toJSON $ TE.decodeUtf8 $ hexEncode g) - , (T.pack "short_description", toJSON $ tsd) - , (T.pack "starred" , toJSON $ starred) - ])) +-- JSON queries. +qProjectListJson :: (IConnection c) => c -> IO [Map Text Text] +qProjectListJson = + (qListToJson qProjectList + (\(g,pn,psd) -> + M.fromList [ (T.pack "id" , TE.decodeUtf8 $ hexEncode g) + , (T.pack "name" , pn) + , (T.pack "short_desc", psd) + ])) - postTasks :: ServerPart Response - postTasks = do - mpid <- fmap (hexDecode . BS.concat . BSL.toChunks) $ lookBS "projectId" - case mpid of - Nothing -> fail "Invalid project ID" - Just pid -> do - tsd <- fmap TL.toStrict $ lookText "shortDescription" - tid <- lift $ runTransactionT eventStore $ do - createTask pid tsd - ok $ toResponse $ hexEncode tid +qTaskListJson :: (IConnection c) => UserId -> Maybe GUID -> c -> IO [Map Text Value] +qTaskListJson userId mProjectId = + (qListToJson (qTaskList userId mProjectId) + (\(g,tsd,starred) -> + M.fromList [ (T.pack "id" , toJSON $ TE.decodeUtf8 $ hexEncode g) + , (T.pack "short_description", toJSON $ tsd) + , (T.pack "starred" , toJSON $ starred) + ])) --- Serve JSON time sheet. -timeSheetJson :: IConnection c => c -> String -> ServerPart Response -timeSheetJson connection userName = do - fromDate <- lookDay "fromDate" - toDate <- lookDay "toDate" +qTimesheetJson :: (IConnection c) => Day -> Day -> UserId -> c -> IO [Map Text Value] +qTimesheetJson fromDate toDate userId connection = do -- Generate the time sheet data. - timeSheet <- lift $ qTimeSheet fromDate toDate userName connection - -- Group by tasks to make the front end manipulation a little easier. - let groupedTimeSheet = - groupBy (\(tid1,_,_,_) (tid2,_,_,_) -> (tid1==tid2)) timeSheet + timeSheet <- fmap g $ qTimeSheet fromDate toDate userId connection -- Generate the JSON data. - okJson $ map + return $ map (\entries -> case entries of [] -> M.fromList [] @@ -128,52 +62,7 @@ , (T.pack "timeSheet", toJSON $ map (\(_,_,day,total) -> M.fromList [ (T.pack "date", toJSON $ day) - , (T.pack "total", toJSON total) ] ) entries) ]) - groupedTimeSheet - --- Stars server part. -starsServerPart :: IConnection c => c -> EventStore Event -> String -> ServerPart Response -starsServerPart connection eventStore userName = do - msum [ method POST >> postStars - ] + , (T.pack "total", toJSON $ D.toMinutes total) ] ) entries) ]) + timeSheet where - postStars :: ServerPart Response - postStars = do - mTaskId <- fmap (hexDecode . BS.concat . BSL.toChunks) $ lookBS "taskId" - case mTaskId of - Nothing -> fail "Invalid task ID" - Just taskId -> do - mUserId <- lift $ qUserIdFromUserName connection (T.pack userName) -- TODO: Move this lookup to the authentication server part. - case mUserId of - Nothing -> fail "Invalid user name" - Just userId -> do - starredS <- lookBS "starred" - case starredS of - "true" -> lift $ runTransactionT eventStore $ void $ starTask taskId userId - "false" -> lift $ runTransactionT eventStore $ void $ unstarTask taskId userId - _ -> fail "Invalid input" - ok $ toResponse ("OK" :: String) - --- Log work. -logWorkPost :: EventStore Event -> ServerPart Response -logWorkPost eventStore = do - -- FIXME: Avoid fromJust + lookRead! This is extremely crashy. - taskId <- liftM (fromJust . hexDecode . BS.concat . BSL.toChunks) $ lookBS "taskId" - duration <- lookRead "duration" - comment <- lookText "comment" - date <- lookDay "date" - let userId = fromJust $ hexDecode "" -- FIXME: Use USER ID of authenticated user! - lift $ runTransactionT eventStore $ do - void $ logWork taskId userId date duration (TL.toStrict comment) - ok $ toResponse ("" :: String) - --- Serve JSON data. -jsonServerPart :: IConnection c => c -> EventStore Event -> String -> ServerPart Response -jsonServerPart conn eventStore userName = - msum - [ dir "projects" $ projectsJson conn eventStore - , dir "tasks" $ tasksJson conn eventStore userName - , dir "stars" $ starsServerPart conn eventStore userName - , dir "time-sheet" $ timeSheetJson conn userName - , dir "do-log-work" $ logWorkPost eventStore - ] + g = groupBy (\(tid1,_,_,_) (tid2,_,_,_) -> (tid1==tid2)) diff --git a/src/CQRSExample/Main.hs b/src/CQRSExample/Main.hs --- a/src/CQRSExample/Main.hs +++ b/src/CQRSExample/Main.hs @@ -1,70 +1,85 @@ +import Blaze.ByteString.Builder (Builder) +import Blaze.ByteString.Builder.Char8 (fromText) import Control.Concurrent (forkIO, threadDelay) -import Control.Monad (void, liftM) +import Control.Concurrent.Chan (Chan, newChan, writeList2Chan) +import Control.Monad (void) import Data.CQRS import Data.CQRS.EventStore.Backend.Sqlite3 (openSqliteEventStore) -import Data.Foldable (foldMap) +import qualified Data.Set as S +import Data.Text (Text) import qualified Data.Text as T import Database.HDBC (IConnection) import Database.HDBC.Sqlite3 (connectSqlite3) -import Happstack.Lite -import CQRSExample.Command (siteInitialization) -import CQRSExample.Controller.Auth +import Network.Wai.EventSource (ServerEvent(..)) +import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort) +import Prelude hiding (mapM) + +import CQRSExample.Command import CQRSExample.Events import CQRSExample.Instances () -import CQRSExample.Json (jsonServerPart) import CQRSExample.Query - -sqliteFile :: String -sqliteFile = "example.db" +import CQRSExample.Wai +import CQRSExample.WaiAuth -eventSourcingThread :: IConnection c => c -> EventStore Event -> IO () -eventSourcingThread connection eventStore = do +-- Source of refresh events to the browser. +eventSourcingThread :: IConnection c => c -> Chan ServerEvent -> EventStore Event -> IO () +eventSourcingThread connection jsonEvents eventStore = do loop where loop = do putStrLn "Sourcing events..." - reactToUnseenEvents connection eventStore + refresh <- reactToUnseenEvents connection eventStore + -- Issue refresh events to browser. + writeList2Chan jsonEvents (map (toServerEvent . fromText . convertRefresh) $ S.toList refresh) -- Wait 1 second threadDelay 1000000 -- Go again. loop + -- Convert refresh values to JSON for browser. + convertRefresh :: Refresh -> Text + convertRefresh RefreshProjects = "refresh-projects" + convertRefresh RefreshTasks = "refresh-tasks" + convertRefresh RefreshTimesheet = "refresh-timesheet" + -- Convert a value to a server event. + toServerEvent :: Builder -> ServerEvent + toServerEvent j = ServerEvent Nothing Nothing [j] -- Check user. -checkUser :: IConnection c => c -> String -> String -> IO Bool +checkUser :: IConnection c => c -> String -> String -> IO (Maybe AuthenticatedUser) checkUser c u p = do - p' <- liftM (foldMap T.unpack) $ qFindUserPassword c (T.pack u) - return $ (==) p p' - --- Serve. -myApp :: IConnection c => c -> EventStore Event -> ServerPart Response -myApp conn eventStore = msum - [ dir "js" $ serveDirectory EnableBrowsing [ ] "static/js" - , dir "css" $ serveDirectory EnableBrowsing [ ] "static/css" - , dir "json" $ basicAuth "Restricted Area" (checkUser conn) $ jsonServerPart conn eventStore - , serveDirectory EnableBrowsing [ "index.html" ] "static" - ] + user <- qFindUser c $ T.pack u + case user of + Just (userId, p') -> + return $ if p == T.unpack p' then Just (AuthenticatedUser u userId) else Nothing + Nothing -> + return Nothing --- -test1 :: IO () -test1 = +-- Start serving the application. +startServing :: IO () +startServing = do let queryDbFile = "query.db" + let sqliteFile = "example.db" -- Connect to query database conn <- connectSqlite3 queryDbFile setupQueryDatabase conn -- Perform any necessary setup. - -- TODO: Should really do a "disconnect" too. + -- Queue of json events to send to browser. + jsonEvents <- newChan -- Start sourcing events. _ <- forkIO $ do withEventStore (openSqliteEventStore sqliteFile) $ do - eventSourcingThread conn + eventSourcingThread conn jsonEvents -- Web serving thread. + let mySettings = defaultSettings { settingsPort = 8000 } void $ forkIO $ do withEventStore (openSqliteEventStore sqliteFile) $ \eventStore -> - serve Nothing $ myApp conn eventStore + runSettings mySettings $ + basicAuth "Clockwork" (checkUser conn) $ + exampleWaiApplication conn eventStore jsonEvents -- Perform site initialization if necessary. withEventStore (openSqliteEventStore sqliteFile) $ \eventStore -> do @@ -73,8 +88,8 @@ main :: IO () main = do - putStrLn "Running test1..." - test1 + putStrLn "Starting..." + startServing putStrLn "Press to quit" _ <- getLine return () diff --git a/src/CQRSExample/Query.hs b/src/CQRSExample/Query.hs --- a/src/CQRSExample/Query.hs +++ b/src/CQRSExample/Query.hs @@ -1,27 +1,48 @@ module CQRSExample.Query - ( setupQueryDatabase - , qFindUserPassword + ( Refresh(..) + , setupQueryDatabase + , qFindUser , qProjectList , qTaskList , qTimeSheet - , qUserIdFromUserName , reactToUnseenEvents ) where import Control.Monad (liftM, void) -import CQRSExample.Aggregates (UserId) -import CQRSExample.Events (Event(..)) +import qualified Data.ByteString.Char8 as BS8 +import Data.Conduit (runResourceT, ($$)) +import qualified Data.Conduit.List as CL import Data.Convertible (Convertible(..), convError) import Data.CQRS (enumerateEventStore, GUID, EventStore) import qualified Data.CQRS.GUID as G import Data.CQRS.PersistedEvent (PersistedEvent(..)) -import Data.Enumerator (run_, (>>==)) -import qualified Data.Enumerator.List as EL import Data.Foldable (forM_) +import Data.Set (Set) +import qualified Data.Set as S import Data.Text (Text) import Data.Time.Calendar (Day) import Database.HDBC (IConnection, SqlValue(..), fromSql, quickQuery', run, runRaw, toSql, withTransaction) +import CQRSExample.Aggregates (UserId) +import CQRSExample.Duration (Duration) +import qualified CQRSExample.Duration as D +import CQRSExample.Events (Event(..), ProjectEvent(..), TaskEvent(..), UserEvent(..), SiteEvent(..)) + +-- Refresh event. +data Refresh = RefreshTasks + | RefreshProjects + | RefreshTimesheet + deriving (Show, Eq, Ord) + +-- Conversion between Duration and SQLValue. +instance Convertible Duration SqlValue where + safeConvert duration = Right $ toSql $ D.toSeconds duration + +instance Convertible SqlValue Duration where + safeConvert (SqlInteger i) = Right $ D.seconds i + safeConvert (SqlByteString s) = Right $ D.seconds $ read $ BS8.unpack s + safeConvert a = convError "Invalid source value" a + -- Conversion between GUID and SQLValue. instance Convertible GUID SqlValue where safeConvert g = Right $ toSql $ G.toByteString g @@ -46,17 +67,17 @@ setupQueryDatabase c = do runRaw c "CREATE TABLE IF NOT EXISTS gversion ( gversion INTEGER )" runRaw c "CREATE TABLE IF NOT EXISTS projects ( guid BLOB , name TEXT , short_desc TEXT )" - runRaw c "CREATE TABLE IF NOT EXISTS tasks ( guid BLOB , project_guid BLOB , short_desc TEXT , long_desc TEXT )" + runRaw c "CREATE TABLE IF NOT EXISTS tasks ( guid BLOB , project_guid BLOB , short_desc TEXT , long_desc TEXT , estimate INTEGER , user_guid BLOB , created_ts TEXT )" runRaw c "CREATE TABLE IF NOT EXISTS users ( user_id BLOB , user_name TEXT , user_pass TEXT , first_name TEXT , last_name TEXT )" runRaw c "CREATE TABLE IF NOT EXISTS work_units ( task_guid BLOB , wu_guid BLOB , wu_date TEXT , wu_duration INTEGER , wu_comment TEXT , user_id BLOB )" - runRaw c "CREATE TABLE IF NOT EXISTS tasks_starred_by ( task_id BLOB, user_id BLOB , user_name TEXT )" + runRaw c "CREATE TABLE IF NOT EXISTS tasks_starred_by ( task_id BLOB, user_id BLOB )" -- Find user password from database. -qFindUserPassword :: IConnection c => c -> Text -> IO (Maybe Text) -qFindUserPassword c userName = fmap extract1 $ smq c "SELECT user_pass FROM users WHERE user_name = ?" [ toSql userName ] convert +qFindUser :: IConnection c => c -> Text -> IO (Maybe (GUID, Text)) +qFindUser c userName = fmap extract1 $ smq c "SELECT U.user_id, U.user_pass FROM users U WHERE U.user_name = ?" [ toSql userName ] convert where - convert :: [SqlValue] -> Text - convert [p] = fromSql p + convert :: [SqlValue] -> (GUID, Text) + convert [uid, p] = (fromSql uid, fromSql p) convert _ = error "Invalid number of columns in SQL query result" -- Query project list @@ -68,13 +89,13 @@ convert _ = error "Invalid number of columns in SQL query result" -- Query task list -qTaskList :: IConnection c => String -> Maybe GUID -> c -> IO [(GUID, Text, Bool)] -qTaskList userName mProjectId c = +qTaskList :: IConnection c => UserId -> Maybe GUID -> c -> IO [(GUID, Text, Bool)] +qTaskList userId mProjectId c = case mProjectId of Nothing -> - smq c "SELECT T.guid, T.short_desc, TS.user_id IS NULL FROM tasks T LEFT OUTER JOIN tasks_starred_by TS ON T.guid = TS.task_id WHERE (TS.user_name = ? OR TS.user_name IS NULL)" [ toSql userName ] convert + smq c "SELECT T.guid, T.short_desc, TS.user_id IS NULL FROM tasks T LEFT OUTER JOIN tasks_starred_by TS ON T.guid = TS.task_id WHERE (TS.user_id = ? OR TS.user_id IS NULL)" [ toSql userId ] convert Just projectId -> - smq c "SELECT T.guid, T.short_desc, TS.user_id IS NULL FROM tasks T LEFT OUTER JOIN tasks_starred_by TS ON T.guid = TS.task_id WHERE (TS.user_name = ? OR TS.user_name IS NULL) AND T.project_guid = ?" [ toSql userName, toSql projectId ] convert + smq c "SELECT T.guid, T.short_desc, TS.user_id IS NULL FROM tasks T LEFT OUTER JOIN tasks_starred_by TS ON T.guid = TS.task_id WHERE (TS.user_id = ? OR TS.user_id IS NULL) AND T.project_guid = ?" [ toSql userId, toSql projectId ] convert where convert :: [SqlValue] -> (GUID,Text,Bool) convert [ guid, short_desc, starred_by_user ] = @@ -88,48 +109,32 @@ -- Query work units in a date interval. The result is a list of tasks -- (IDs, short description), with daily totals (in minutes) for each task. -qTimeSheet :: IConnection c => Day -> Day -> String -> c -> IO [(GUID, Text, Maybe Day, Int)] -qTimeSheet startDate endDate userName c = - (smq c "SELECT T.guid, W.wu_date, T.short_desc, COALESCE(SUM(W.wu_duration),0) FROM tasks T LEFT OUTER JOIN work_units W ON W.task_guid=T.guid LEFT OUTER JOIN tasks_starred_by ST ON ST.task_id=T.guid WHERE ((W.wu_duration IS NOT NULL) AND (W.wu_date>=? AND W.wu_date Day -> Day -> UserId -> c -> IO [(GUID, Text, Maybe Day, Duration)] +qTimeSheet startDate endDate userId c = + (smq c "SELECT T.guid, W.wu_date, T.short_desc, COALESCE(SUM(W.wu_duration),0) FROM tasks T LEFT OUTER JOIN work_units W ON W.task_guid=T.guid LEFT OUTER JOIN tasks_starred_by ST ON ST.task_id=T.guid WHERE ((W.wu_duration IS NOT NULL) AND (W.wu_date>=? AND W.wu_date (GUID, Text, Maybe Day, Int) + convert :: [SqlValue] -> (GUID, Text, Maybe Day, Duration) convert [ taskId, day, taskShortDesc, total ] = (fromSql taskId, fromSql taskShortDesc, fromSql day, fromSql total) convert _ = error "Invalid columns in SQL query result" --- Get user name for a given user ID. -qUserNameFromUserId :: IConnection c => c -> GUID -> IO (Maybe Text) -qUserNameFromUserId c userId = fmap extract1 $ smq c "SELECT U.user_name FROM users U WHERE U.user_id = ?" [ toSql userId ] convert - where - convert :: [SqlValue] -> Text - convert [u] = fromSql u - convert _ = error "Invalid columns in SQL query result" - --- Get user ID from user name. -qUserIdFromUserName :: IConnection c => c -> Text -> IO (Maybe GUID) -qUserIdFromUserName c userName = fmap extract1 $ smq c "SELECT U.user_id FROM users U WHERE U.user_name = ?" [ toSql $ userName ] convert - where - convert :: [SqlValue] -> GUID - convert [u] = fromSql u - convert _ = error "Invalid columns in SQL query result" - -- Event sourcing. -reactToUnseenEvents :: IConnection c => c -> EventStore Event -> IO () +reactToUnseenEvents :: IConnection c => c -> EventStore Event -> IO (Set Refresh) reactToUnseenEvents connection eventStore = withTransaction connection $ \_ -> do -- Find the version number to start at. startVersion <- getStartVersion -- Enumerate all the events form the event store since last run. - evs <- run_ (EL.consume >>== enumerateEventStore eventStore startVersion) + evs <- runResourceT $ enumerateEventStore eventStore startVersion $$ CL.consume -- React to all the events. forM_ evs $ reactToEvent connection -- Update the global version number. updateStartVersion $ startVersion + length evs -- Done. - return () + return $ S.fromList $ calculateRefresh $ evs where getStartVersion :: IO Int @@ -145,6 +150,19 @@ _ <- run connection "INSERT INTO gversion (gversion) VALUES (?);" [ toSql newStartVersion ] return () +calculateRefresh :: [PersistedEvent Event] -> [Refresh] +calculateRefresh pes = concat $ map (f . peEvent) pes + where + f (ProjectEvent _) = [RefreshProjects] + f (TaskEvent te) = fte te + f (UserEvent _) = [] + f (SiteEvent _) = [] + + fte (TaskAdded _ _ _ _ _) = [RefreshTasks] + fte (TaskStarred _) = [RefreshTasks, RefreshTimesheet] + fte (TaskUnstarred _) = [RefreshTasks, RefreshTimesheet] + fte (RecordedWorkUnit _ _ _ _ _) = [RefreshTimesheet] + reactToEvent :: IConnection c => c -> PersistedEvent Event -> IO () reactToEvent connection ev = do let gv = peGlobalVer ev @@ -154,26 +172,42 @@ where g = peAggregateGUID ev - react (ProjectCreated pn psd) = do + reactProject (ProjectCreated pn psd) = do go "INSERT INTO projects ( guid , name , short_desc ) VALUES ( ? , ? , ? );" [ toSql g , toSql pn , toSql psd ] - react (ProjectRenamed pn) = do + reactProject (ProjectRenamed pn) = do go "UPDATE projects SET name = ? WHERE guid = ?;" [ toSql pn , toSql g ] - react (TaskAdded pid tsd) = do - go "INSERT INTO tasks ( guid , project_guid , short_desc ) VALUES (?, ?, ?);" + reactTask (TaskAdded pid tsd est uid ts) = do + go "INSERT INTO tasks ( guid , project_guid , short_desc , estimate , user_guid , created_ts) VALUES (?, ?, ?, ? , ?, ?);" [ toSql g , toSql pid - , toSql tsd ] + , toSql tsd + , toSql est + , toSql uid + , toSql ts + ] - react (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) = do + reactTask (TaskStarred userId) = do + go "INSERT INTO tasks_starred_by ( task_id , user_id ) VALUES (?, ?);" + [ toSql g + , toSql userId + ] + + reactTask (TaskUnstarred userId) = do + go "DELETE FROM tasks_starred_by WHERE task_id = ? AND user_id = ?;" + [ toSql g + , toSql userId + ] + + reactTask (RecordedWorkUnit wuId wuDay wuDuration wuComment wuUserId) = do go "INSERT INTO work_units ( task_guid , wu_guid , wu_date , wu_duration , wu_comment , user_id ) VALUES ( ? , ? , ? , ? , ? , ? );" [ toSql g , toSql wuId @@ -183,7 +217,7 @@ , toSql wuUserId ] - react (UserCreated ucUserName ucPassword ucFirstName ucLastName) = do + reactUser (UserCreated ucUserName ucPassword ucFirstName ucLastName) = do go "INSERT INTO users ( user_id , user_name , user_pass, first_name , last_name ) VALUES ( ? , ? , ? , ? , ? );" [ toSql g , toSql ucUserName @@ -192,23 +226,13 @@ , toSql ucLastName ] - react (TaskStarred userId) = do - mUserName <- qUserNameFromUserId connection userId - forM_ mUserName $ \userName -> do - go "INSERT INTO tasks_starred_by ( task_id , user_id , user_name ) VALUES (?, ?, ?);" - [ toSql g - , toSql userId - , toSql $ userName - ] - - react (TaskUnstarred userId) = do - go "DELETE FROM tasks_starred_by WHERE task_id = ? AND user_id = ?;" - [ toSql g - , toSql userId - ] - - react (UserRegistered _) = do + reactSite (UserRegistered _) = return () -- No need to record + + react (ProjectEvent p) = reactProject p + react (TaskEvent e) = reactTask e + react (UserEvent e) = reactUser e + react (SiteEvent e) = reactSite e go :: String -> [SqlValue] -> IO () go sql parameters = void $ run connection sql parameters diff --git a/src/CQRSExample/Wai.hs b/src/CQRSExample/Wai.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/Wai.hs @@ -0,0 +1,108 @@ +module CQRSExample.Wai + ( AuthenticatedUser(..) + , exampleWaiApplication + ) where + +import Control.Concurrent.Chan (Chan) +import Control.Monad (void) +import Control.Monad.Trans.Class (lift) +import Data.Aeson (ToJSON(..), encode) +import Data.CQRS +import Data.CQRS.GUID (hexEncode) +import Data.Text (Text) +import Database.HDBC (IConnection) +import Network.HTTP.Types (status200, status404, status400, status501, StdMethod(..), parseMethod) +import Network.Wai (Application, Request, Response, pathInfo, responseLBS, requestMethod) +import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) +import Network.Wai.EventSource (eventSourceApp, ServerEvent(..)) +import Prelude hiding (mapM) + +import CQRSExample.Aggregates (UserId) +import CQRSExample.Command +import CQRSExample.Events +import CQRSExample.Instances () +import CQRSExample.Json +import CQRSExample.WaiParameters + +data AuthenticatedUser = -- TODO: This doesn't really belong here. + AuthenticatedUser { auUserName :: String + , auUserId :: UserId + } + +exampleWaiApplication :: IConnection c => c -> EventStore Event -> Chan ServerEvent -> AuthenticatedUser -> Application +exampleWaiApplication conn eventStore serverEvents user req = + case parseMethod (requestMethod req) of + Right method -> route method + Left _ -> return $ responseLBS status501 [] "" + + where + + userId = auUserId user + + route method = do + case (method,pathInfo req) of + (GET , "events" : _) -> eventSourceApp serverEvents req + (_ , "json" : "projects" : _) -> runParameters (appJsonProjects method) req + (_ , "json" : "tasks" : _) -> runParameters (appJsonTasks method) req + (_ , "json" : "time-sheet" : _) -> runParameters (appJsonTimesheet method) req + (_ , "json" : "stars" : _) -> runParameters (appStars method) req + (GET , _) -> staticApp defaultFileServerSettings req + _ -> return notFound + + -- Projects + appJsonProjects GET = + lift $ lift $ qProjectListJson conn >>= returnJson + appJsonProjects POST = do + pn <- requireText "name" + pd <- requireText "shortDescription" + pid <- lift $ lift $ runTransactionT eventStore $ do + createProject pn pd + returnJson $ hexEncode pid + appJsonProjects _ = badRequest + + -- Tasks + appJsonTasks GET = do + mProjectId <- lookGUID "projectId" + lift $ lift $ qTaskListJson userId mProjectId conn >>= returnJson + appJsonTasks POST = do + pid <- requireGUID "projectId" + estimate <- requireDuration "estimate" + tsd <- requireText "shortDescription" + tid <- lift $ lift $ runTransactionT eventStore $ do + createTask pid tsd estimate userId + returnJson $ hexEncode tid + appJsonTasks _ = badRequest + + -- Timesheet + appJsonTimesheet GET = do + fromDate <- requireDay "fromDate" + toDate <- requireDay "toDate" + lift $ lift $ qTimesheetJson fromDate toDate userId conn >>= returnJson + appJsonTimesheet POST = do + taskId <- requireGUID "taskId" + duration <- requireDuration "duration" + comment <- requireText "comment" + date <- requireDay "date" + lift $ lift $ runTransactionT eventStore $ do + void $ logWork taskId userId date duration comment + returnJson ("OK" :: Text) + appJsonTimesheet _ = badRequest + + -- Stars + appStars POST = do + taskId <- requireGUID "taskId" + starred <- requireBool "starred" + lift $ lift $ runTransactionT eventStore $ void $ do + case starred of + True -> starTask taskId userId + False -> unstarTask taskId userId + returnJson ("OK" :: Text) + appStars _ = badRequest + + badRequest = return $ responseLBS status400 [] "" + +returnJson :: Monad m => ToJSON a => a -> m Response +returnJson a = return $ responseLBS status200 [("Content-Type", "text/json")] $ encode a + +notFound :: Response +notFound = responseLBS status404 [("Content-Type", "text/plain")] "404 - Not Found" diff --git a/src/CQRSExample/WaiAuth.hs b/src/CQRSExample/WaiAuth.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/WaiAuth.hs @@ -0,0 +1,38 @@ +module CQRSExample.WaiAuth + ( basicAuth + ) where + +import Control.Monad.Trans.Class (lift) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Base64 as B64 +import Data.Foldable (foldMap) +import Network.HTTP.Types (status401) +import Network.Wai (Application, Request, Response, responseLBS, requestHeaders) + +-- | Support for Basic Auth. +basicAuth :: String -> (String -> String -> IO (Maybe a)) -> (a -> Application) -> Application +basicAuth realmName authMap app req = do + let aHeader = lookup "authorization" $ requestHeaders req + case foldMap parseHeader aHeader of + (name, ':':password) -> do + found <- lift $ authMap name password + case found of + Just a -> app a req + Nothing -> err + _ -> err + where + -- TODO: Redo this hack. + parseHeader = break (':'==) . f . B64.decode . B.drop 6 + f (Left _) = "error" + f (Right s) = B8.unpack s + err = return $ unauthorized realmName + +-- Generate an "unauthorized" response. +unauthorized :: String -> Response +unauthorized realmName = + responseLBS status401 + [ ("Content-Type", "text/plain") + , ("WWW-Authenticate", B8.pack $ "Basic realm=\"" ++ realmName ++ "\"") + ] + "Not authorized" diff --git a/src/CQRSExample/WaiParameters.hs b/src/CQRSExample/WaiParameters.hs new file mode 100644 --- /dev/null +++ b/src/CQRSExample/WaiParameters.hs @@ -0,0 +1,96 @@ +module CQRSExample.WaiParameters + ( runParameters + , lookGUID + , requireBool + , requireDay + , requireDuration + , requireGUID + , requireText + ) where + +import Control.Applicative ((<*>)) +import Control.Monad (liftM) +import Control.Monad.Trans.Resource (ResourceT) +import Control.Monad.Trans.Reader (ask, ReaderT, runReaderT) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import Data.Conduit (($$)) +import Data.CQRS +import Data.CQRS.GUID (hexDecode) +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import Data.Time (Day) +import Data.Time.Format (parseTime) +import Network.HTTP.Types (Query) +import Network.Wai (Application, Request, Response, queryString, requestBody) +import Network.Wai.Parse (lbsSink, parseRequestBody, Param) +import Prelude hiding (mapM) +import System.Locale (defaultTimeLocale) + +import CQRSExample.Duration (Duration) +import qualified CQRSExample.Duration as D + +-- Type of the monad. +type ParametersT = ReaderT ([Param], Query) + +runParameters :: ParametersT (ResourceT IO) Response -> Application +runParameters r req = do + -- TODO: Impose a max body length. + (params, _) <- requestBody req $$ parseRequestBody lbsSink req + runReaderT r (params, queryString req) + +look :: Monad m => ByteString -> ParametersT m (Maybe ByteString) +look n = do + (ps, qs) <- ask + let mq = lookup n qs + let mp = lookup n ps + return $ maybe mp id mq + +required :: Monad m => ByteString -> ParametersT m (Maybe a) -> ParametersT m a +required n = flip (>>=) require + where + require (Just a) = return a + require Nothing = fail $ "Missing/invalid parameter '" ++ (B8.unpack n) ++ "'" + +lookText :: Monad m => ByteString -> ParametersT m (Maybe Text) +lookText n = liftM (maybe Nothing decode) $ look n + where decode = either (const Nothing) Just . TE.decodeUtf8' + +requireText :: Monad m => ByteString -> ParametersT m Text +requireText = required <*> lookText + +lookGUID :: Monad m => ByteString -> ParametersT m (Maybe GUID) +lookGUID n = liftM (maybe Nothing hexDecode) $ look n + +requireGUID :: Monad m => ByteString -> ParametersT m GUID +requireGUID = required <*> lookGUID + +lookInteger :: Monad m => ByteString -> ParametersT m (Maybe Integer) +lookInteger n = liftM (maybe Nothing (f . B8.readInteger)) $ look n + where + f (Just (x, "")) = Just x + f _ = Nothing + +requiredInteger :: Monad m => ByteString -> ParametersT m Integer +requiredInteger = required <*> lookInteger + +requireDuration :: Monad m => ByteString -> ParametersT m Duration +requireDuration n = liftM D.minutes $ requiredInteger n + +lookDay :: Monad m => ByteString -> ParametersT m (Maybe Day) +lookDay n = liftM (maybe Nothing parseDay) $ look n + where parseDay = parseTime defaultTimeLocale "%F" . B8.unpack + +requireDay :: Monad m => ByteString -> ParametersT m Day +requireDay = required <*> lookDay + +lookBool :: Monad m => ByteString -> ParametersT m (Maybe Bool) +lookBool n = liftM f $ look n + where + f (Just "true") = Just True + f (Just "false") = Just False + f _ = Nothing + +requireBool :: Monad m => ByteString -> ParametersT m Bool +requireBool = required <*> lookBool +