zgo-backend/src/Order.hs

181 lines
4.4 KiB
Haskell
Raw Normal View History

2022-05-11 20:04:46 +00:00
{-# 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]
}
deriving (Eq, Show, Generic)
instance ToJSON ZGoOrder where
toJSON (ZGoOrder i a s ts c cur p t tZ l) =
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
]
Nothing ->
object
[ "_id" .= ("" :: String)
, "address" .= a
, "session" .= s
, "timestamp" .= ts
, "closed" .= c
, "currency" .= cur
, "price" .= p
, "total" .= t
, "totalZec" .= tZ
, "lines" .= l
]
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"
pure $
ZGoOrder
(if not (null i)
then Just (read i)
else Nothing)
a
s
ts
c
cur
p
t
tZ
l
instance Val ZGoOrder where
val (ZGoOrder i a s ts c cur p t tZ l) =
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
]
else Doc
[ "address" =: a
, "session" =: s
, "timestamp" =: ts
, "closed" =: c
, "currency" =: cur
, "price" =: p
, "total" =: t
, "totalZec" =: tZ
, "lines" =: l
]
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
Just (ZGoOrder i a s ts c cur p t tZ l)
cast' _ = Nothing
-- Type to represent an order line item
data LineItem =
LineItem
2022-05-19 13:24:52 +00:00
{ lqty :: Double
2022-05-11 20:04:46 +00:00
, lname :: T.Text
, lcost :: Double
}
deriving (Eq, Show)
instance ToJSON LineItem where
2022-05-19 13:24:52 +00:00
toJSON (LineItem q n c) = object ["qty" .= q, "name" .= n, "cost" .= c]
2022-05-11 20:04:46 +00:00
instance FromJSON LineItem where
parseJSON =
withObject "LineItem" $ \obj -> do
q <- obj .: "qty"
n <- obj .: "name"
c <- obj .: "cost"
2022-05-19 13:24:52 +00:00
pure $ LineItem q n c
2022-05-11 20:04:46 +00:00
instance Val LineItem where
2022-05-19 13:24:52 +00:00
val (LineItem q n c) = Doc ["qty" =: q, "name" =: n, "cost" =: c]
2022-05-11 20:04:46 +00:00
cast' (Doc d) = do
q <- B.lookup "qty" d
n <- B.lookup "name" d
c <- B.lookup "cost" d
2022-05-19 13:24:52 +00:00
Just (LineItem q n c)
2022-05-11 20:04:46 +00:00
cast' _ = Nothing
-- Database actions
upsertOrder :: ZGoOrder -> Action IO ()
upsertOrder o = do
let order = val o
case order of
2022-05-19 13:24:52 +00:00
Doc d ->
if isJust (q_id o)
then upsert (select ["_id" =: q_id o] "orders") d
else insert_ "orders" d
2022-05-11 20:04:46 +00:00
_ -> return ()
findOrder :: T.Text -> Action IO (Maybe Document)
2022-05-19 13:24:52 +00:00
findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders")
2022-05-11 20:04:46 +00:00
findOrderById :: String -> Action IO (Maybe Document)
findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
2022-05-12 19:59:29 +00:00
findAllOrders :: T.Text -> Action IO [Document]
findAllOrders a = rest =<< find (select ["address" =: a] "orders")
2022-05-11 20:04:46 +00:00
deleteOrder :: String -> Action IO ()
deleteOrder i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "orders")