309 lines
8.0 KiB
Haskell
309 lines
8.0 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
|
|
import WooCommerce (WooToken(w_id))
|
|
|
|
-- | 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
|
|
, qtoken :: T.Text
|
|
, qtax :: Double
|
|
, qvat :: Double
|
|
, qtip :: Double
|
|
} deriving (Eq, Show, Generic)
|
|
|
|
instance ToJSON ZGoOrder where
|
|
toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC tk qT qV tip) =
|
|
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
|
|
, "token" .= tk
|
|
, "taxAmount" .= qT
|
|
, "vatAmount" .= qV
|
|
, "tipAmount" .= tip
|
|
]
|
|
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
|
|
, "token" .= tk
|
|
, "taxAmount" .= qT
|
|
, "vatAmount" .= qV
|
|
, "tipAmount" .= tip
|
|
]
|
|
|
|
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"
|
|
tk <- obj .: "token"
|
|
qT <- obj .: "taxAmount"
|
|
qV <- obj .: "vatAmount"
|
|
tip <- obj .: "tipAmount"
|
|
pure $
|
|
ZGoOrder
|
|
(if not (null i)
|
|
then Just (read i :: ObjectId)
|
|
else Nothing)
|
|
a
|
|
s
|
|
ts
|
|
c
|
|
cur
|
|
p
|
|
t
|
|
tZ
|
|
l
|
|
pd
|
|
eI
|
|
sC
|
|
tk
|
|
qT
|
|
qV
|
|
tip
|
|
|
|
instance Val ZGoOrder where
|
|
val (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk qT qV tip) =
|
|
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
|
|
, "token" =: tk
|
|
, "taxAmount" =: qT
|
|
, "vatAmount" =: qV
|
|
, "tipAmount" =: tip
|
|
]
|
|
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
|
|
, "token" =: tk
|
|
, "taxAmount" =: qT
|
|
, "vatAmount" =: qV
|
|
, "tipAmount" =: tip
|
|
]
|
|
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
|
|
tk <- B.lookup "token" d
|
|
qT <- B.lookup "taxAmount" d
|
|
qV <- B.lookup "vatAmount" d
|
|
tip <- B.lookup "tipAmount" d
|
|
Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk qT qV tip)
|
|
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 ()
|
|
|
|
insertWooOrder :: ZGoOrder -> Action IO Database.MongoDB.Value
|
|
insertWooOrder o = do
|
|
let order = val $ updateOrderTotals o
|
|
case order of
|
|
Doc d -> insert "orders" d
|
|
_ -> fail "Couldn't parse order"
|
|
|
|
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)
|
|
(qtoken o)
|
|
(qtax o)
|
|
(qvat o)
|
|
(qtip o)
|
|
where
|
|
newTotal :: ZGoOrder -> Double
|
|
newTotal x = foldr tallyItems 0 (qlines x) + qtax o + qvat o + qtip o
|
|
tallyItems :: LineItem -> Double -> Double
|
|
tallyItems y z = (lqty y * lcost y) + z
|
|
|
|
setOrderToken :: T.Text -> ZGoOrder -> ZGoOrder
|
|
setOrderToken token (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk qT qV tip) =
|
|
ZGoOrder i a s ts c cur p t tZ l pd eI sC token qT qV tip
|
|
|
|
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 "0" = return Nothing
|
|
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)
|