Unified Address support #8
2 changed files with 73 additions and 56 deletions
30
src/Order.hs
30
src/Order.hs
|
|
@ -210,9 +210,9 @@ instance Val LineItem where
|
||||||
cast' _ = Nothing
|
cast' _ = Nothing
|
||||||
|
|
||||||
-- Database actions
|
-- Database actions
|
||||||
upsertOrder :: ZGoOrder -> Action IO ()
|
upsertOrder :: ZGoOrder -> Double -> Double -> Action IO ()
|
||||||
upsertOrder o = do
|
upsertOrder o taxRate vatRate = do
|
||||||
let order = val $ updateOrderTotals o
|
let order = val $ updateOrderTotals o taxRate vatRate
|
||||||
case order of
|
case order of
|
||||||
Doc d ->
|
Doc d ->
|
||||||
if isJust (q_id o)
|
if isJust (q_id o)
|
||||||
|
|
@ -222,14 +222,14 @@ upsertOrder o = do
|
||||||
|
|
||||||
insertWooOrder :: ZGoOrder -> Action IO Database.MongoDB.Value
|
insertWooOrder :: ZGoOrder -> Action IO Database.MongoDB.Value
|
||||||
insertWooOrder o = do
|
insertWooOrder o = do
|
||||||
let order = val $ updateOrderTotals o
|
let order = val $ updateOrderTotals o 0 0
|
||||||
case order of
|
case order of
|
||||||
Doc d -> insert "orders" d
|
Doc d -> insert "orders" d
|
||||||
_ -> fail "Couldn't parse order"
|
_ -> fail "Couldn't parse order"
|
||||||
|
|
||||||
upsertXeroOrder :: ZGoOrder -> Action IO ()
|
upsertXeroOrder :: ZGoOrder -> Action IO ()
|
||||||
upsertXeroOrder o = do
|
upsertXeroOrder o = do
|
||||||
let order = val $ updateOrderTotals o
|
let order = val $ updateOrderTotals o 0 0
|
||||||
case order of
|
case order of
|
||||||
Doc d ->
|
Doc d ->
|
||||||
upsert
|
upsert
|
||||||
|
|
@ -242,8 +242,8 @@ upsertXeroOrder o = do
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
-- | Function to update order totals from items
|
-- | Function to update order totals from items
|
||||||
updateOrderTotals :: ZGoOrder -> ZGoOrder
|
updateOrderTotals :: ZGoOrder -> Double -> Double -> ZGoOrder
|
||||||
updateOrderTotals o =
|
updateOrderTotals o taxRate vatRate =
|
||||||
ZGoOrder
|
ZGoOrder
|
||||||
(q_id o)
|
(q_id o)
|
||||||
(qaddress o)
|
(qaddress o)
|
||||||
|
|
@ -252,9 +252,9 @@ updateOrderTotals o =
|
||||||
(qclosed o)
|
(qclosed o)
|
||||||
(qcurrency o)
|
(qcurrency o)
|
||||||
(qprice o)
|
(qprice o)
|
||||||
(newTotal o)
|
(newTotal o taxRate vatRate)
|
||||||
(if qprice o /= 0
|
(if qprice o /= 0
|
||||||
then roundZec (newTotal o / qprice o)
|
then roundZec (newTotal o taxRate vatRate / qprice o)
|
||||||
else 0)
|
else 0)
|
||||||
(qlines o)
|
(qlines o)
|
||||||
(qpaid o)
|
(qpaid o)
|
||||||
|
|
@ -265,8 +265,13 @@ updateOrderTotals o =
|
||||||
(qvat o)
|
(qvat o)
|
||||||
(qtip o)
|
(qtip o)
|
||||||
where
|
where
|
||||||
newTotal :: ZGoOrder -> Double
|
updateTax :: ZGoOrder -> Double -> Double
|
||||||
newTotal x = foldr tallyItems 0 (qlines x) + qtax o + qvat o + qtip o
|
updateTax x t = roundFiat $ itemsTotal (qlines x) * t / 100.0
|
||||||
|
itemsTotal :: [LineItem] -> Double
|
||||||
|
itemsTotal = foldr tallyItems 0
|
||||||
|
newTotal :: ZGoOrder -> Double -> Double -> Double
|
||||||
|
newTotal x tR vR =
|
||||||
|
itemsTotal (qlines x) + updateTax x tR + updateTax x vR + qtip x
|
||||||
tallyItems :: LineItem -> Double -> Double
|
tallyItems :: LineItem -> Double -> Double
|
||||||
tallyItems y z = (lqty y * lcost y) + z
|
tallyItems y z = (lqty y * lcost y) + z
|
||||||
|
|
||||||
|
|
@ -306,3 +311,6 @@ markOrderPaid (i, a) = do
|
||||||
-- | Helper function to round to 8 decimal places
|
-- | Helper function to round to 8 decimal places
|
||||||
roundZec :: Double -> Double
|
roundZec :: Double -> Double
|
||||||
roundZec n = fromInteger (round $ n * (10 ^ 8)) / (10.0 ^^ 8)
|
roundZec n = fromInteger (round $ n * (10 ^ 8)) / (10.0 ^^ 8)
|
||||||
|
|
||||||
|
roundFiat :: Double -> Double
|
||||||
|
roundFiat n = fromInteger (round $ n * (10 ^ 2)) / (10.0 ^^ 2)
|
||||||
|
|
|
||||||
|
|
@ -768,7 +768,7 @@ routes pipe config = do
|
||||||
_ <-
|
_ <-
|
||||||
liftAndCatchIO $
|
liftAndCatchIO $
|
||||||
run $
|
run $
|
||||||
upsertOrder newOrder
|
upsertOrder newOrder 0 0
|
||||||
finalOrder <-
|
finalOrder <-
|
||||||
liftAndCatchIO $
|
liftAndCatchIO $
|
||||||
run $
|
run $
|
||||||
|
|
@ -1437,6 +1437,18 @@ routes pipe config = do
|
||||||
case cast' . Doc =<< user of
|
case cast' . Doc =<< user of
|
||||||
Nothing -> status unauthorized401
|
Nothing -> status unauthorized401
|
||||||
Just u -> do
|
Just u -> do
|
||||||
|
owner <- liftAndCatchIO $ run $ findOwner (uaddress u)
|
||||||
|
case cast' . Doc =<< owner of
|
||||||
|
Nothing -> status badRequest400
|
||||||
|
Just o -> do
|
||||||
|
let taxRate =
|
||||||
|
if otax o
|
||||||
|
then otaxValue o
|
||||||
|
else 0
|
||||||
|
let vatRate =
|
||||||
|
if ovat o
|
||||||
|
then ovatValue o
|
||||||
|
else 0
|
||||||
dbOrder <-
|
dbOrder <-
|
||||||
liftAndCatchIO $ run (findOrderById $ maybe "0" show (q_id q))
|
liftAndCatchIO $ run (findOrderById $ maybe "0" show (q_id q))
|
||||||
case cast' . Doc =<< dbOrder of
|
case cast' . Doc =<< dbOrder of
|
||||||
|
|
@ -1448,11 +1460,20 @@ routes pipe config = do
|
||||||
t <- liftIO generateToken
|
t <- liftIO generateToken
|
||||||
_ <-
|
_ <-
|
||||||
liftAndCatchIO $
|
liftAndCatchIO $
|
||||||
run (upsertOrder $ setOrderToken (T.pack t) q)
|
run
|
||||||
|
(upsertOrder
|
||||||
|
(setOrderToken (T.pack t) q)
|
||||||
|
taxRate
|
||||||
|
vatRate)
|
||||||
status created201
|
status created201
|
||||||
else do
|
else do
|
||||||
_ <-
|
_ <-
|
||||||
liftAndCatchIO $ access pipe master dbName (upsertOrder q)
|
liftAndCatchIO $
|
||||||
|
access
|
||||||
|
pipe
|
||||||
|
master
|
||||||
|
dbName
|
||||||
|
(upsertOrder q taxRate vatRate)
|
||||||
status created201
|
status created201
|
||||||
else status forbidden403
|
else status forbidden403
|
||||||
Just dbO -> do
|
Just dbO -> do
|
||||||
|
|
@ -1465,12 +1486,20 @@ routes pipe config = do
|
||||||
t <- liftIO generateToken
|
t <- liftIO generateToken
|
||||||
_ <-
|
_ <-
|
||||||
liftAndCatchIO $
|
liftAndCatchIO $
|
||||||
run (upsertOrder $ setOrderToken (T.pack t) q)
|
run
|
||||||
|
(upsertOrder
|
||||||
|
(setOrderToken (T.pack t) q)
|
||||||
|
taxRate
|
||||||
|
vatRate)
|
||||||
status created201
|
status created201
|
||||||
else do
|
else do
|
||||||
_ <-
|
_ <-
|
||||||
liftAndCatchIO $
|
liftAndCatchIO $
|
||||||
access pipe master dbName (upsertOrder q)
|
access
|
||||||
|
pipe
|
||||||
|
master
|
||||||
|
dbName
|
||||||
|
(upsertOrder q taxRate vatRate)
|
||||||
status created201
|
status created201
|
||||||
else status forbidden403
|
else status forbidden403
|
||||||
else status forbidden403
|
else status forbidden403
|
||||||
|
|
@ -1538,26 +1567,6 @@ routes pipe config = do
|
||||||
Just tP -> do
|
Just tP -> do
|
||||||
status ok200
|
status ok200
|
||||||
Web.Scotty.json $ toJSON (tP :: LangComponent)
|
Web.Scotty.json $ toJSON (tP :: LangComponent)
|
||||||
where
|
|
||||||
saveOrder :: Pipe -> T.Text -> User -> ZGoOrder -> ActionM ()
|
|
||||||
saveOrder pipe dbName u q = do
|
|
||||||
if uaddress u == qaddress q
|
|
||||||
then do
|
|
||||||
if qtoken q == ""
|
|
||||||
then do
|
|
||||||
t <- liftIO generateToken
|
|
||||||
_ <-
|
|
||||||
liftAndCatchIO $
|
|
||||||
access
|
|
||||||
pipe
|
|
||||||
master
|
|
||||||
dbName
|
|
||||||
(upsertOrder $ setOrderToken (T.pack t) q)
|
|
||||||
status created201
|
|
||||||
else do
|
|
||||||
_ <- liftAndCatchIO $ access pipe master dbName (upsertOrder q)
|
|
||||||
status created201
|
|
||||||
else status forbidden403
|
|
||||||
{-post "/api/setlang" $ do-}
|
{-post "/api/setlang" $ do-}
|
||||||
{-langComp <- jsonData-}
|
{-langComp <- jsonData-}
|
||||||
{-_ <--}
|
{-_ <--}
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue