「13.3.7 注文の印刷」から

営業時間の件

アダプタ関数ではなくロジックに書いてもいいのでは

おそらくメインのロジックをいじりたくないのでは

イベントのとりこぼしがありうるシステム構成でとりこぼしたときにどうするか

13.1.3 のセクションでは、ロギングや監査をアダプター関数方式で差し込めることを示唆している

同様の方法でOKかな

コンテンキスト同士をつなぐのは「7.9 長時間稼働するワークフロー」かな

Claude に頼んで作ってもらった、「注文確定」の完全なドメインモデル

code:OrderTaking.Domain.md

context: Order-Taking

// ----------------------

// 共通の単純型

// ----------------------

// 文字列型（50文字制限）

data String50 = string of at most 50 characters

// 電子メールアドレス

data EmailAddress = string in valid email format

// ZIP/郵便番号

data ZipCode = string of 5 digits

// 注文ID

data OrderId = undefined OR OrderId of string

// 顧客ID

data CustomerId = CustomerId of string

// ----------------------

// 製品関連の型

// ----------------------

// 製品コード

data ProductCode = WidgetCode OR GizmoCode

data WidgetCode = string starting with "W" then 4 digits

data GizmoCode = string starting with "G" then 3 digits

// 注文数量

data OrderQuantity = UnitQuantity OR KilogramQuantity

data UnitQuantity = integer between 1 and 1000

data KilogramQuantity = decimal between 0.05 and 100.00

// 価格

data Price = Price of decimal

data BillingAmount = BillingAmount of decimal

// ----------------------

// 顧客情報

// ----------------------

data PersonalName = {

FirstName: String50

LastName: String50

}

data CustomerInfo = {

Name: PersonalName

EmailAddress: EmailAddress

VipStatus: VipStatus

}

data VipStatus = Normal OR Vip

// ----------------------

// 住所

// ----------------------

data Address = {

AddressLine1: String50

AddressLine2: String50 option

AddressLine3: String50 option

AddressLine4: String50 option

City: String50

ZipCode: ZipCode

}

// ----------------------

// 注文のライフサイクル

// ----------------------

// ----- 未検証の状態-----

data UnvalidatedOrder = {

OrderId: string

CustomerInfo: UnvalidatedCustomerInfo

ShippingAddress: UnvalidatedAddress

BillingAddress: UnvalidatedAddress

Lines: list of UnvalidatedOrderLine

}

data UnvalidatedCustomerInfo = {

FirstName: string

LastName: string

EmailAddress: string

VipStatus: string

}

data UnvalidatedAddress = {

AddressLine1: string

AddressLine2: string option

AddressLine3: string option

AddressLine4: string option

City: string

ZipCode: string

}

data UnvalidatedOrderLine = {

OrderLineId: string

ProductCode: string

Quantity: decimal

}

// ----- 検証済みの状態-----

data ValidatedOrder = {

OrderId: OrderId

CustomerInfo: CustomerInfo

ShippingAddress: Address

BillingAddress: Address

Lines: list of ValidatedOrderLine

}

data ValidatedOrderLine = {

OrderLineId: OrderLineId

ProductCode: ProductCode

Quantity: OrderQuantity

}

data OrderLineId = OrderLineId of string

// ----- 価格計算済みの状態-----

data PricedOrder = {

OrderId: OrderId

CustomerInfo: CustomerInfo

ShippingAddress: Address

BillingAddress: Address

Lines: list of PricedOrderLine

AmountToBill: BillingAmount

}

data PricedOrderLine = {

OrderLineId: OrderLineId

ProductCode: ProductCode

Quantity: OrderQuantity

LinePrice: Price

}

// ----------------------

// コマンド（入力）

// ----------------------

data PlaceOrder = {

OrderForm: UnvalidatedOrder

Timestamp: DateTime

UserId: string

// その他のメタデータ...

}

// ----------------------

// イベント（出力）

// ----------------------

data PlaceOrderEvent =

| OrderPlaced of OrderPlaced

| BillableOrderPlaced of BillableOrderPlaced

| OrderAcknowledgmentSent of OrderAcknowledgmentSent

data OrderPlaced = {

OrderId: OrderId

CustomerInfo: CustomerInfo

ShippingAddress: Address

BillingAddress: Address

AmountToBill: BillingAmount

Lines: list of PricedOrderLine

}

data BillableOrderPlaced = {

OrderId: OrderId

BillingAddress: Address

AmountToBill: BillingAmount

}

data OrderAcknowledgmentSent = {

OrderId: OrderId

EmailAddress: EmailAddress

}

// ----------------------

// エラー型

// ----------------------

data ValidationError =

| CustomerNameMissing

| CustomerNameTooLong

| CustomerEmailMissing

| CustomerEmailInvalidFormat

| CustomerVipStatusMissing

| ShippingAddressMissing

| ShippingAddressInvalid

| BillingAddressMissing

| BillingAddressInvalid

| OrderLineMissing

| OrderLineInvalid of OrderLineError

data OrderLineError =

| ProductCodeMissing

| ProductCodeInvalidFormat

| ProductNotFound of ProductCode

| QuantityMissing

| QuantityInvalid

| QuantityOutOfRange

data PricingError =

| ProductPriceNotFound of ProductCode

data RemoteServiceError =

| ServiceNotAvailable of ServiceName

| ServiceTimeout of ServiceName

data ServiceName = string

data PlaceOrderError =

| Validation of ValidationError

| Pricing of PricingError

| RemoteService of RemoteServiceError

// ----------------------

// 外部サービス（依存関係）

// ----------------------

// 製品カタログサービス

type CheckProductCodeExists = ProductCode -> bool

// 住所検証サービス

type CheckAddressExists = UnvalidatedAddress -> CheckedAddress

data CheckedAddress = CheckedAddress of UnvalidatedAddress

// 価格取得サービス

type GetProductPrice = ProductCode -> Price

// 確認メール送信サービス

type SendOrderAcknowledgment = PricedOrder -> OrderAcknowledgmentSent

// ----------------------

// ワークフロー

// ----------------------

workflow "Place Order" =

input: PlaceOrder

output:

Success: list of PlaceOrderEvent

Failure: PlaceOrderError

// ステップ1: 検証

do ValidateOrder

If order is invalid then:

return ValidationError

// ステップ2: 価格計算

do PriceOrder

If pricing fails then:

return PricingError

// ステップ3: 確認書作成

do CreateEvents

// ステップ4: 確認メール送信（副作用）

do SendAcknowledgmentToCustomer

substep "ValidateOrder" =

input: UnvalidatedOrder

output: ValidatedOrder OR ValidationError

dependencies: CheckProductCodeExists, CheckAddressExists

// 顧客情報の検証

validate customer name (not empty, not too long)

validate customer email (valid format)

validate customer VIP status

// 住所の検証

validate shipping address exists

validate billing address exists

// 注文行の検証

for each line:

validate product code syntax

check that product code exists in ProductCatalog

validate quantity is in valid range

if everything is valid then:

return ValidatedOrder

else:

return ValidationError

substep "PriceOrder" =

input: ValidatedOrder

output: PricedOrder OR PricingError

dependencies: GetProductPrice

for each line:

get the price for the product from ProductCatalog

if price not found then:

return PricingError

calculate line price = quantity * unit price

calculate amount to bill = sum of all line prices

return PricedOrder with all prices set

substep "CreateEvents" =

input: PricedOrder

output: list of PlaceOrderEvent

create OrderPlaced event

create BillableOrderPlaced event (for billing context)

create OrderAcknowledgmentSent event (for customer communication)

substep "SendAcknowledgmentToCustomer" =

input: PricedOrder

output: OrderAcknowledgmentSent OR RemoteServiceError

dependencies: SendOrderAcknowledgment

create acknowledgment letter with order details

send acknowledgment email to customer

if successful then:

return OrderAcknowledgmentSent

else:

return RemoteServiceError

上記のドメインモデルをもとにClaudeにHaskellのコードを書かせてみた

微妙な修正(プラグマの追加とderivingの修正とliftIOの削除など)だけでコンパイルの通るコードが出てきた！

ただ、お手本になるようなリポジトリがGitHub上でいくつも見つかるのでカンニングしてる説は否めない

code:ClaudeGenerated.hs

module OrderTaking.Domain

( -- * Common Simple Types

String50(..)

, EmailAddress(..)

, ZipCode(..)

, OrderId(..)

, CustomerId(..)

-- * Product Types

, ProductCode(..)

, WidgetCode(..)

, GizmoCode(..)

, OrderQuantity(..)

, UnitQuantity(..)

, KilogramQuantity(..)

, Price(..)

, BillingAmount(..)

-- * Customer Information

, PersonalName(..)

, CustomerInfo(..)

, VipStatus(..)

-- * Address

, Address(..)

-- * Order Lifecycle

, UnvalidatedOrder(..)

, UnvalidatedCustomerInfo(..)

, UnvalidatedAddress(..)

, UnvalidatedOrderLine(..)

, ValidatedOrder(..)

, ValidatedOrderLine(..)

, OrderLineId(..)

, PricedOrder(..)

, PricedOrderLine(..)

-- * Commands

, PlaceOrder(..)

-- * Events

, PlaceOrderEvent(..)

, OrderPlaced(..)

, BillableOrderPlaced(..)

, OrderAcknowledgmentSent(..)

-- * Errors

, ValidationError(..)

, OrderLineError(..)

, PricingError(..)

, RemoteServiceError(..)

, ServiceName(..)

, PlaceOrderError(..)

-- * Services

, CheckProductCodeExists

, CheckAddressExists

, CheckedAddress(..)

, GetProductPrice

, SendOrderAcknowledgment

-- * Workflow

, PlaceOrderWorkflow

, placeOrderWorkflow

-- * Smart Constructors

, mkString50

, mkEmailAddress

, mkZipCode

, mkWidgetCode

, mkGizmoCode

, mkUnitQuantity

, mkKilogramQuantity

) where

import Data.Text (Text)

import qualified Data.Text as T

import Data.Time (UTCTime)

import Data.Decimal (Decimal)

import Control.Monad.Except (ExceptT, throwError, runExceptT)

import Control.Monad.IO.Class (MonadIO)

import Text.Regex.TDFA ((=~))

-- ----------------------

-- Common Simple Types

-- ----------------------

newtype String50 = String50 Text

deriving stock (Show, Eq, Ord)

deriving newtype (Semigroup, Monoid)

newtype EmailAddress = EmailAddress Text

deriving stock (Show, Eq, Ord)

newtype ZipCode = ZipCode Text

deriving stock (Show, Eq, Ord)

newtype OrderId = OrderId Text

deriving stock (Show, Eq, Ord)

newtype CustomerId = CustomerId Text

deriving stock (Show, Eq, Ord)

-- ----------------------

-- Product Types

-- ----------------------

data ProductCode

= WidgetProductCode WidgetCode

| GizmoProductCode GizmoCode

deriving stock (Show, Eq, Ord)

newtype WidgetCode = WidgetCode Text

deriving stock (Show, Eq, Ord)

newtype GizmoCode = GizmoCode Text

deriving stock (Show, Eq, Ord)

data OrderQuantity

= UnitOrderQuantity UnitQuantity

| KilogramOrderQuantity KilogramQuantity

deriving stock (Show, Eq, Ord)

newtype UnitQuantity = UnitQuantity Int

deriving stock (Show, Eq, Ord)

deriving newtype (Num)

newtype KilogramQuantity = KilogramQuantity Decimal

deriving stock (Show, Eq, Ord)

deriving newtype (Num)

newtype Price = Price Decimal

deriving stock (Show, Eq, Ord)

deriving newtype (Num)

newtype BillingAmount = BillingAmount Decimal

deriving stock (Show, Eq, Ord)

deriving newtype (Num, Semigroup, Monoid)

-- ----------------------

-- Customer Information

-- ----------------------

data PersonalName = PersonalName

{ firstName :: String50

, lastName :: String50

} deriving stock (Show, Eq)

data CustomerInfo = CustomerInfo

{ customerName :: PersonalName

, emailAddress :: EmailAddress

, vipStatus :: VipStatus

} deriving stock (Show, Eq)

data VipStatus = Normal | Vip

deriving stock (Show, Eq, Ord)

-- ----------------------

-- Address

-- ----------------------

data Address = Address

{ addressLine1 :: String50

, addressLine2 :: Maybe String50

, addressLine3 :: Maybe String50

, addressLine4 :: Maybe String50

, city :: String50

, zipCode :: ZipCode

} deriving stock (Show, Eq)

-- ----------------------

-- Order Lifecycle

-- ----------------------

-- Unvalidated State

data UnvalidatedOrder = UnvalidatedOrder

{ unvalidatedOrderId :: Text

, unvalidatedCustomerInfo :: UnvalidatedCustomerInfo

, unvalidatedShippingAddress :: UnvalidatedAddress

, unvalidatedBillingAddress :: UnvalidatedAddress

} deriving stock (Show, Eq)

data UnvalidatedCustomerInfo = UnvalidatedCustomerInfo

{ unvalidatedFirstName :: Text

, unvalidatedLastName :: Text

, unvalidatedEmailAddress :: Text

, unvalidatedVipStatus :: Text

} deriving stock (Show, Eq)

data UnvalidatedAddress = UnvalidatedAddress

{ unvalidatedAddressLine1 :: Text

, unvalidatedAddressLine2 :: Maybe Text

, unvalidatedAddressLine3 :: Maybe Text

, unvalidatedAddressLine4 :: Maybe Text

, unvalidatedCity :: Text

, unvalidatedZipCode :: Text

} deriving stock (Show, Eq)

data UnvalidatedOrderLine = UnvalidatedOrderLine

{ unvalidatedOrderLineId :: Text

, unvalidatedProductCode :: Text

, unvalidatedQuantity :: Decimal

} deriving stock (Show, Eq)

-- Validated State

data ValidatedOrder = ValidatedOrder

{ validatedOrderId :: OrderId

, validatedCustomerInfo :: CustomerInfo

, validatedShippingAddress :: Address

, validatedBillingAddress :: Address

} deriving stock (Show, Eq)

data ValidatedOrderLine = ValidatedOrderLine

{ validatedOrderLineId :: OrderLineId

, validatedProductCode :: ProductCode

, validatedQuantity :: OrderQuantity

} deriving stock (Show, Eq)

newtype OrderLineId = OrderLineId Text

deriving stock (Show, Eq, Ord)

-- Priced State

data PricedOrder = PricedOrder

{ pricedOrderId :: OrderId

, pricedCustomerInfo :: CustomerInfo

, pricedShippingAddress :: Address

, pricedBillingAddress :: Address

, amountToBill :: BillingAmount

} deriving stock (Show, Eq)

data PricedOrderLine = PricedOrderLine

{ pricedOrderLineId :: OrderLineId

, pricedProductCode :: ProductCode

, pricedQuantity :: OrderQuantity

, linePrice :: Price

} deriving stock (Show, Eq)

-- ----------------------

-- Commands

-- ----------------------

data PlaceOrder = PlaceOrder

{ orderForm :: UnvalidatedOrder

, timestamp :: UTCTime

, userId :: Text

} deriving stock (Show, Eq)

-- ----------------------

-- Events

-- ----------------------

data PlaceOrderEvent

= OrderPlacedEvent OrderPlaced

| BillableOrderPlacedEvent BillableOrderPlaced

| OrderAcknowledgmentSentEvent OrderAcknowledgmentSent

deriving stock (Show, Eq)

data OrderPlaced = OrderPlaced

{ orderPlacedId :: OrderId

, orderPlacedCustomerInfo :: CustomerInfo

, orderPlacedShippingAddress :: Address

, orderPlacedBillingAddress :: Address

, orderPlacedAmountToBill :: BillingAmount

} deriving stock (Show, Eq)

data BillableOrderPlaced = BillableOrderPlaced

{ billableOrderId :: OrderId

, billableBillingAddress :: Address

, billableAmountToBill :: BillingAmount

} deriving stock (Show, Eq)

data OrderAcknowledgmentSent = OrderAcknowledgmentSent

{ acknowledgmentOrderId :: OrderId

, acknowledgmentEmailAddress :: EmailAddress

} deriving stock (Show, Eq)

-- ----------------------

-- Error Types

-- ----------------------

data ValidationError

= CustomerNameMissing

| CustomerNameTooLong

| CustomerEmailMissing

| CustomerEmailInvalidFormat

| CustomerVipStatusMissing

| ShippingAddressMissing

| ShippingAddressInvalid

| BillingAddressMissing

| BillingAddressInvalid

| OrderLineMissing

| OrderLineInvalidError OrderLineError

deriving stock (Show, Eq)

data OrderLineError

= ProductCodeMissing

| ProductCodeInvalidFormat

| ProductNotFound ProductCode

| QuantityMissing

| QuantityInvalid

| QuantityOutOfRange

deriving stock (Show, Eq)

data PricingError

= ProductPriceNotFound ProductCode

deriving stock (Show, Eq)

data RemoteServiceError

= ServiceNotAvailable ServiceName

| ServiceTimeout ServiceName

deriving stock (Show, Eq)

newtype ServiceName = ServiceName Text

deriving stock (Show, Eq)

data PlaceOrderError

= ValidationError ValidationError

| PricingError PricingError

| RemoteServiceError RemoteServiceError

deriving stock (Show, Eq)

-- ----------------------

-- External Services

-- ----------------------

type CheckProductCodeExists = ProductCode -> IO Bool

newtype CheckedAddress = CheckedAddress UnvalidatedAddress

deriving stock (Show, Eq)

type CheckAddressExists = UnvalidatedAddress -> IO CheckedAddress

type GetProductPrice = ProductCode -> IO (Maybe Price)

type SendOrderAcknowledgment = PricedOrder -> IO OrderAcknowledgmentSent

-- ----------------------

-- Smart Constructors

-- ----------------------

mkString50 :: Text -> Either Text String50

mkString50 text

| T.length text <= 50 = Right (String50 text)

| otherwise = Left "String must be 50 characters or less"

mkEmailAddress :: Text -> Either Text EmailAddress

mkEmailAddress email

| isValidEmail email = Right (EmailAddress email)

| otherwise = Left "Invalid email format"

where

isValidEmail :: Text -> Bool

mkZipCode :: Text -> Either Text ZipCode

mkZipCode zip

| otherwise = Left "ZIP code must be exactly 5 digits"

mkWidgetCode :: Text -> Either Text WidgetCode

mkWidgetCode code

Right (WidgetCode code)

| otherwise = Left "Widget code must start with 'W' followed by 4 digits"

mkGizmoCode :: Text -> Either Text GizmoCode

mkGizmoCode code

Right (GizmoCode code)

| otherwise = Left "Gizmo code must start with 'G' followed by 3 digits"

mkUnitQuantity :: Int -> Either Text UnitQuantity

mkUnitQuantity qty

| qty >= 1 && qty <= 1000 = Right (UnitQuantity qty)

| otherwise = Left "Unit quantity must be between 1 and 1000"

mkKilogramQuantity :: Decimal -> Either Text KilogramQuantity

mkKilogramQuantity qty

| qty >= 0.05 && qty <= 100.00 = Right (KilogramQuantity qty)

| otherwise = Left "Kilogram quantity must be between 0.05 and 100.00"

-- ----------------------

-- Workflow Implementation

-- ----------------------

type PlaceOrderWorkflow m =

CheckProductCodeExists ->

CheckAddressExists ->

GetProductPrice ->

SendOrderAcknowledgment ->

PlaceOrder ->

placeOrderWorkflow :: MonadIO m => PlaceOrderWorkflow m

placeOrderWorkflow checkProduct checkAddress getPrice sendAck placeOrderCmd = do

result <- runExceptT $ do

-- Step 1: Validate Order

validatedOrder <- validateOrder checkProduct checkAddress (orderForm placeOrderCmd)

-- Step 2: Price Order

pricedOrder <- priceOrder getPrice validatedOrder

-- Step 3: Create Events

let events = createEvents pricedOrder

-- Step 4: Send Acknowledgment (side effect)

ack <- sendAcknowledgmentToCustomer sendAck pricedOrder

return result

validateOrder :: MonadIO m =>

CheckProductCodeExists ->

CheckAddressExists ->

UnvalidatedOrder ->

ExceptT PlaceOrderError m ValidatedOrder

validateOrder checkProduct checkAddress unvalidated = do

-- Validate customer info

customerInfo <- validateCustomerInfo (unvalidatedCustomerInfo unvalidated)

-- Validate addresses

shippingAddr <- validateAddress checkAddress (unvalidatedShippingAddress unvalidated)

billingAddr <- validateAddress checkAddress (unvalidatedBillingAddress unvalidated)

-- Validate order lines

validatedLines <- mapM (validateOrderLine checkProduct) (unvalidatedLines unvalidated)

-- Create order ID

orderId <- case mkString50 (unvalidatedOrderId unvalidated) of

Right s50 -> return (OrderId $ unString50 s50)

Left _ -> throwError (ValidationError CustomerNameTooLong)

return ValidatedOrder

{ validatedOrderId = orderId

, validatedCustomerInfo = customerInfo

, validatedShippingAddress = shippingAddr

, validatedBillingAddress = billingAddr

, validatedLines = validatedLines

}

where

unString50 (String50 t) = t

validateCustomerInfo :: Monad m => UnvalidatedCustomerInfo -> ExceptT PlaceOrderError m CustomerInfo

validateCustomerInfo unvalidated = do

firstName <- case mkString50 (unvalidatedFirstName unvalidated) of

Right s -> return s

Left _ -> throwError (ValidationError CustomerNameTooLong)

lastName <- case mkString50 (unvalidatedLastName unvalidated) of

Right s -> return s

Left _ -> throwError (ValidationError CustomerNameTooLong)

email <- case mkEmailAddress (unvalidatedEmailAddress unvalidated) of

Right e -> return e

Left _ -> throwError (ValidationError CustomerEmailInvalidFormat)

vip <- case unvalidatedVipStatus unvalidated of

"Normal" -> return Normal

"Vip" -> return Vip

_ -> throwError (ValidationError CustomerVipStatusMissing)

return CustomerInfo

{ customerName = PersonalName firstName lastName

, emailAddress = email

, vipStatus = vip

}

validateAddress :: MonadIO m => CheckAddressExists -> UnvalidatedAddress -> ExceptT PlaceOrderError m Address

validateAddress checkAddress unvalidated = do

-- Check if address exists (external service call)

_ <- liftIO $ checkAddress unvalidated

line1 <- case mkString50 (unvalidatedAddressLine1 unvalidated) of

Right s -> return s

Left _ -> throwError (ValidationError ShippingAddressInvalid)

line2 <- traverse (either (const $ throwError (ValidationError ShippingAddressInvalid)) return . mkString50)

(unvalidatedAddressLine2 unvalidated)

line3 <- traverse (either (const $ throwError (ValidationError ShippingAddressInvalid)) return . mkString50)

(unvalidatedAddressLine3 unvalidated)

line4 <- traverse (either (const $ throwError (ValidationError ShippingAddressInvalid)) return . mkString50)

(unvalidatedAddressLine4 unvalidated)

cityName <- case mkString50 (unvalidatedCity unvalidated) of

Right s -> return s

Left _ -> throwError (ValidationError ShippingAddressInvalid)

zip <- case mkZipCode (unvalidatedZipCode unvalidated) of

Right z -> return z

Left _ -> throwError (ValidationError ShippingAddressInvalid)

return Address

{ addressLine1 = line1

, addressLine2 = line2

, addressLine3 = line3

, addressLine4 = line4

, city = cityName

, zipCode = zip

}

validateOrderLine :: MonadIO m => CheckProductCodeExists -> UnvalidatedOrderLine -> ExceptT PlaceOrderError m ValidatedOrderLine

validateOrderLine checkProduct unvalidated = do

-- Validate product code

productCode <- validateProductCode (unvalidatedProductCode unvalidated)

-- Check if product exists

exists <- liftIO $ checkProduct productCode

if not exists

then throwError (ValidationError $ OrderLineInvalidError $ ProductNotFound productCode)

else return ()

-- Validate quantity

quantity <- validateQuantity productCode (unvalidatedQuantity unvalidated)

-- Create order line ID

lineId <- case mkString50 (unvalidatedOrderLineId unvalidated) of

Right s50 -> return (OrderLineId $ unString50 s50)

Left _ -> throwError (ValidationError $ OrderLineInvalidError QuantityInvalid)

return ValidatedOrderLine

{ validatedOrderLineId = lineId

, validatedProductCode = productCode

, validatedQuantity = quantity

}

where

unString50 (String50 t) = t

validateProductCode :: Monad m => Text -> ExceptT PlaceOrderError m ProductCode

validateProductCode code

| T.take 1 code == "W" =

case mkWidgetCode code of

Right w -> return (WidgetProductCode w)

Left _ -> throwError (ValidationError $ OrderLineInvalidError ProductCodeInvalidFormat)

| T.take 1 code == "G" =

case mkGizmoCode code of

Right g -> return (GizmoProductCode g)

Left _ -> throwError (ValidationError $ OrderLineInvalidError ProductCodeInvalidFormat)

| otherwise = throwError (ValidationError $ OrderLineInvalidError ProductCodeInvalidFormat)

validateQuantity :: Monad m => ProductCode -> Decimal -> ExceptT PlaceOrderError m OrderQuantity

validateQuantity productCode qty = case productCode of

WidgetProductCode _ ->

case mkUnitQuantity (round qty) of

Right uq -> return (UnitOrderQuantity uq)

Left _ -> throwError (ValidationError $ OrderLineInvalidError QuantityOutOfRange)

GizmoProductCode _ ->

case mkKilogramQuantity qty of

Right kq -> return (KilogramOrderQuantity kq)

Left _ -> throwError (ValidationError $ OrderLineInvalidError QuantityOutOfRange)

priceOrder :: MonadIO m => GetProductPrice -> ValidatedOrder -> ExceptT PlaceOrderError m PricedOrder

priceOrder getPrice validatedOrder = do

pricedLines <- mapM priceLine (validatedLines validatedOrder)

let totalAmount = BillingAmount $ sum $ map (\line -> let Price p = linePrice line in p) pricedLines

return PricedOrder

{ pricedOrderId = validatedOrderId validatedOrder

, pricedCustomerInfo = validatedCustomerInfo validatedOrder

, pricedShippingAddress = validatedShippingAddress validatedOrder

, pricedBillingAddress = validatedBillingAddress validatedOrder

, pricedLines = pricedLines

, amountToBill = totalAmount

}

where

priceLine validatedLine = do

maybePrce <- liftIO $ getPrice (validatedProductCode validatedLine)

price <- case maybePrce of

Nothing -> throwError (PricingError $ ProductPriceNotFound (validatedProductCode validatedLine))

Just p -> return p

let qty = validatedQuantity validatedLine

Price unitPrice = price

lineTotal = case qty of

UnitOrderQuantity (UnitQuantity u) -> Price (fromIntegral u * unitPrice)

KilogramOrderQuantity (KilogramQuantity k) -> Price (k * unitPrice)

return PricedOrderLine

{ pricedOrderLineId = validatedOrderLineId validatedLine

, pricedProductCode = validatedProductCode validatedLine

, pricedQuantity = qty

, linePrice = lineTotal

}

createEvents pricedOrder =

[ OrderPlacedEvent $ OrderPlaced

{ orderPlacedId = pricedOrderId pricedOrder

, orderPlacedCustomerInfo = pricedCustomerInfo pricedOrder

, orderPlacedShippingAddress = pricedShippingAddress pricedOrder

, orderPlacedBillingAddress = pricedBillingAddress pricedOrder

, orderPlacedAmountToBill = amountToBill pricedOrder

, orderPlacedLines = pricedLines pricedOrder

}

, BillableOrderPlacedEvent $ BillableOrderPlaced

{ billableOrderId = pricedOrderId pricedOrder

, billableBillingAddress = pricedBillingAddress pricedOrder

, billableAmountToBill = amountToBill pricedOrder

}

]

sendAcknowledgmentToCustomer :: MonadIO m => SendOrderAcknowledgment -> PricedOrder -> ExceptT PlaceOrderError m OrderAcknowledgmentSent

sendAcknowledgmentToCustomer sendAck pricedOrder = do

ack <- liftIO $ sendAck pricedOrder

return ack

-- Helper function to lift IO operations

liftIO :: MonadIO m => IO a -> ExceptT PlaceOrderError m a

liftIO = lift . liftIO