{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} module Order where import Data.Aeson import qualified Data.Bson as B import Data.Maybe import qualified Data.Text as T import Data.Time.Clock import Database.MongoDB import GHC.Generics import Test.QuickCheck -- | Type to represent a ZGo order data ZGoOrder = ZGoOrder { q_id :: Maybe ObjectId , qaddress :: T.Text , qsession :: T.Text , qtimestamp :: UTCTime , qclosed :: Bool , qcurrency :: T.Text , qprice :: Double , qtotal :: Double , qtotalZec :: Double , qlines :: [LineItem] , qpaid :: Bool } deriving (Eq, Show, Generic) instance ToJSON ZGoOrder where toJSON (ZGoOrder i a s ts c cur p t tZ l paid) = case i of Just oid -> object [ "_id" .= show oid , "address" .= a , "session" .= s , "timestamp" .= ts , "closed" .= c , "currency" .= cur , "price" .= p , "total" .= t , "totalZec" .= tZ , "lines" .= l , "paid" .= paid ] Nothing -> object [ "_id" .= ("" :: String) , "address" .= a , "session" .= s , "timestamp" .= ts , "closed" .= c , "currency" .= cur , "price" .= p , "total" .= t , "totalZec" .= tZ , "lines" .= l , "paid" .= paid ] instance FromJSON ZGoOrder where parseJSON = withObject "Order" $ \obj -> do i <- obj .: "_id" a <- obj .: "address" s <- obj .: "session" ts <- obj .: "timestamp" c <- obj .: "closed" cur <- obj .: "currency" p <- obj .: "price" t <- obj .: "total" tZ <- obj .: "totalZec" l <- obj .: "lines" pd <- obj .: "paid" pure $ ZGoOrder (if not (null i) then Just (read i) else Nothing) a s ts c cur p t tZ l pd instance Val ZGoOrder where val (ZGoOrder i a s ts c cur p t tZ l pd) = if isJust i then Doc [ "_id" =: i , "address" =: a , "session" =: s , "timestamp" =: ts , "closed" =: c , "currency" =: cur , "price" =: p , "total" =: t , "totalZec" =: tZ , "lines" =: l , "paid" =: pd ] else Doc [ "address" =: a , "session" =: s , "timestamp" =: ts , "closed" =: c , "currency" =: cur , "price" =: p , "total" =: t , "totalZec" =: tZ , "lines" =: l , "paid" =: pd ] cast' (Doc d) = do i <- B.lookup "_id" d a <- B.lookup "address" d s <- B.lookup "session" d ts <- B.lookup "timestamp" d c <- B.lookup "closed" d cur <- B.lookup "currency" d p <- B.lookup "price" d t <- B.lookup "total" d tZ <- B.lookup "totalZec" d l <- B.lookup "lines" d pd <- B.lookup "paid" d Just (ZGoOrder i a s ts c cur p t tZ l pd) cast' _ = Nothing -- Type to represent an order line item data LineItem = LineItem { lqty :: Double , lname :: T.Text , lcost :: Double } deriving (Eq, Show) instance ToJSON LineItem where toJSON (LineItem q n c) = object ["qty" .= q, "name" .= n, "cost" .= c] instance FromJSON LineItem where parseJSON = withObject "LineItem" $ \obj -> do q <- obj .: "qty" n <- obj .: "name" c <- obj .: "cost" pure $ LineItem q n c instance Val LineItem where val (LineItem q n c) = Doc ["qty" =: q, "name" =: n, "cost" =: c] cast' (Doc d) = do q <- B.lookup "qty" d n <- B.lookup "name" d c <- B.lookup "cost" d Just (LineItem q n c) cast' _ = Nothing -- Database actions upsertOrder :: ZGoOrder -> Action IO () upsertOrder o = do let order = val $ updateOrderTotals o case order of Doc d -> if isJust (q_id o) then upsert (select ["_id" =: q_id o] "orders") d else insert_ "orders" d _ -> return () -- | Function to update order totals from items updateOrderTotals :: ZGoOrder -> ZGoOrder updateOrderTotals o = ZGoOrder (q_id o) (qaddress o) (qsession o) (qtimestamp o) (qclosed o) (qcurrency o) (qprice o) (newTotal o) (if qprice o /= 0 then roundZec (newTotal o / qprice o) else 0) (qlines o) (qpaid o) where newTotal :: ZGoOrder -> Double newTotal x = foldr tallyItems 0 (qlines x) tallyItems :: LineItem -> Double -> Double tallyItems y z = (lqty y * lcost y) + z findOrder :: T.Text -> Action IO (Maybe Document) findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders") findOrderById :: String -> Action IO (Maybe Document) findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders") findAllOrders :: T.Text -> Action IO [Document] findAllOrders a = rest =<< find (select ["address" =: a] "orders") deleteOrder :: String -> Action IO () deleteOrder i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "orders") markOrderPaid :: String -> Action IO () markOrderPaid i = modify (select ["_id" =: (read i :: B.ObjectId)] "orders") ["$set" =: ["paid" =: True]] -- | Helper function to round to 8 decimal places roundZec :: Double -> Double roundZec n = fromInteger (round $ n * (10 ^ 8)) / (10.0 ^^ 8)