zgo-backend/src/Order.hs

251 lines
6.6 KiB
Haskell

{-# 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
, qexternalInvoice :: T.Text
, qshortCode :: T.Text
}
deriving (Eq, Show, Generic)
instance ToJSON ZGoOrder where
toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC) =
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
, "externalInvoice" .= eI
, "shortCode" .= sC
]
Nothing ->
object
[ "_id" .= ("" :: String)
, "address" .= a
, "session" .= s
, "timestamp" .= ts
, "closed" .= c
, "currency" .= cur
, "price" .= p
, "total" .= t
, "totalZec" .= tZ
, "lines" .= l
, "paid" .= paid
, "externalInvoice" .= eI
, "shortCode" .= sC
]
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"
eI <- obj .: "externalInvoice"
sC <- obj .: "shortCode"
pure $
ZGoOrder
(if not (null i)
then Just (read i)
else Nothing)
a
s
ts
c
cur
p
t
tZ
l
pd
eI
sC
instance Val ZGoOrder where
val (ZGoOrder i a s ts c cur p t tZ l pd eI sC) =
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
, "externalInvoice" =: eI
, "shortCode" =: sC
]
else Doc
[ "address" =: a
, "session" =: s
, "timestamp" =: ts
, "closed" =: c
, "currency" =: cur
, "price" =: p
, "total" =: t
, "totalZec" =: tZ
, "lines" =: l
, "paid" =: pd
, "externalInvoice" =: eI
, "shortCode" =: sC
]
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
eI <- B.lookup "externalInvoice" d
sC <- B.lookup "shortCode" d
Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC)
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 ()
upsertXeroOrder :: ZGoOrder -> Action IO ()
upsertXeroOrder o = do
let order = val $ updateOrderTotals o
case order of
Doc d -> upsert (select ["externalInvoice" =: qexternalInvoice o, "shortCode" =: qshortCode o] "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)
(qexternalInvoice o)
(qshortCode 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")
findXeroOrder :: T.Text -> T.Text -> T.Text -> Action IO (Maybe Document)
findXeroOrder a i s = findOne (select ["address" =: a, "externalInvoice" =: i, "shortCode" =: s] "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") {sort = ["timestamp" =: (negate 1 :: Int)]}
deleteOrder :: String -> Action IO ()
deleteOrder i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
markOrderPaid :: (String, Double) -> Action IO ()
markOrderPaid (i, a) = do
let
modify
(select ["_id" =: (read i :: B.ObjectId), "totalZec" =: a] "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)