Event sourcing in haskell

IssueTracker.hs

{-# LANGUAGE OverloadedStrings #-}

module IssueTracker where

newtype RepositoryId = RepositoryId String deriving (Eq, Show)
newtype OccuredOn = OccuredOn String deriving (Eq, Show)
newtype UserId = UserId String deriving (Eq, Show)
newtype Label = Label String deriving (Eq, Show)
newtype DateTime = DateTime String deriving (Eq, Show)
newtype MilestoneId = MilestoneId String deriving (Eq, Show)

data State = Empty
           | OpenIssue
           | ClosedIssue
           deriving (Show)

data Error = UnsupportedBehavior
             deriving (Show)

data CommandHeader   = CommandHeader RepositoryId UserId deriving (Show)
data Command         = Submit
                       {
                         commandHeader              :: CommandHeader
                       , submitedTitle              :: String
                       , submittedOptionalComment   :: Maybe String
                       , submittedAssignees         :: [UserId]
                       , submittedLabels            :: [Label]
                       , submitedMilestone          :: Maybe MilestoneId
                       }
                     | Close        { commandHeader :: CommandHeader, submittedOpiotnalComment :: Maybe String }
                     | Comment      { commandHeader :: CommandHeader, submittedComment         :: String }
                     | Reopen       { commandHeader :: CommandHeader, submittedOptionalComment :: Maybe String }
                     | Plan         { commandHeader :: CommandHeader, submittedMilestone       :: MilestoneId }
                     | Categorise   { commandHeader :: CommandHeader, submittedLabel           :: Label }
                     | Uncategorise { commandHeader :: CommandHeader, submittedLabel           :: Label }
                     deriving (Show)

data EventHeader  = EventHeader RepositoryId UserId OccuredOn deriving (Show)
data Event        = Created       { eventHeader :: EventHeader, title     :: String }
                  | Commented     { eventHeader :: EventHeader, comment   :: String }
                  | Assigned      { eventHeader :: EventHeader, assignee  :: UserId }
                  | Planned       { eventHeader :: EventHeader, milestone :: MilestoneId }
                  | Categorised   { eventHeader :: EventHeader, label     :: Label }
                  | Uncategorised { eventHeader :: EventHeader, label     :: Label }
                  | Closed        { eventHeader :: EventHeader }
                  deriving (Show)

-- Execute behavior on given state
(!) :: Command -> State -> Either Error ([Event], State)
(!) (Submit (CommandHeader repositoryId userId) title comment assignees labels milestone) Empty
   = Right $ ([ Created (EventHeader repositoryId userId (OccuredOn "now")) title ], OpenIssue)


-- Projection is a foldl on events. Imagine we want to display the Issue page on github, we need all information. 
-- viewIssue [Created (EventHeader (RepositoryId "123") (UserId "123") (OccuredOn "now")) "This is my issue"]
data IssueView = IssueView {
                             issueTitle        :: String
                           , issueAuthor       :: UserId
                           , issueLabels       :: [Label]
                           , issueAssigness    :: [UserId]
                           , issueMilestones   :: [MilestoneId]
                           , issueConversation :: [String]
                           }
                           deriving (Show)
viewIssue :: [Event] -> IssueView
viewIssue (Created (EventHeader repositoryId userId occuredOn) title:xs) =
  foldl applyEvent initialState xs
  where
    applyEvent issue (Commented _ comment) = issue

    applyEvent (IssueView title author labels assignees milestones conversation) (Assigned _ assignee)
      = IssueView title author labels ([assignee] ++ assignees) milestones conversation

    applyEvent (IssueView title author labels assignees milestones conversation) (Planned _ milestone)
      = IssueView title author labels assignees ([milestone] ++ milestones) conversation

    initialState = IssueView title userId [] [] [] []

-- exec CloseIssue OpenIssue= Right ([Closed], ClosedIssue)
-- exec _ _ = Left UnsupportedBehavior