Merge branch 'dev'

package.yaml

@@ -98,3 +98,5 @@ tests:
     - hspec-wai
     - securemem
     - time
+    - configurator
+    - scotty

src/Order.hs

@@ -26,11 +26,12 @@ data ZGoOrder =
     , 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) =
+  toJSON (ZGoOrder i a s ts c cur p t tZ l paid) =
     case i of
       Just oid ->
         object
@@ -44,6 +45,7 @@ instance ToJSON ZGoOrder where
           , "total" .= t
           , "totalZec" .= tZ
           , "lines" .= l
+          , "paid" .= paid
           ]
       Nothing ->
         object
@@ -57,6 +59,7 @@ instance ToJSON ZGoOrder where
           , "total" .= t
           , "totalZec" .= tZ
           , "lines" .= l
+          , "paid" .= paid
           ]
 
 instance FromJSON ZGoOrder where
@@ -72,6 +75,7 @@ instance FromJSON ZGoOrder where
       t <- obj .: "total"
       tZ <- obj .: "totalZec"
       l <- obj .: "lines"
+      pd <- obj .: "paid"
       pure $
         ZGoOrder
           (if not (null i)
@@ -86,9 +90,10 @@ instance FromJSON ZGoOrder where
           t
           tZ
           l
+          pd
 
 instance Val ZGoOrder where
-  val (ZGoOrder i a s ts c cur p t tZ l) =
+  val (ZGoOrder i a s ts c cur p t tZ l pd) =
     if isJust i
       then Doc
              [ "_id" =: i
@@ -101,6 +106,7 @@ instance Val ZGoOrder where
              , "total" =: t
              , "totalZec" =: tZ
              , "lines" =: l
+             , "paid" =: pd
              ]
       else Doc
              [ "address" =: a
@@ -112,6 +118,7 @@ instance Val ZGoOrder where
              , "total" =: t
              , "totalZec" =: tZ
              , "lines" =: l
+             , "paid" =: pd
              ]
   cast' (Doc d) = do
     i <- B.lookup "_id" d
@@ -124,7 +131,8 @@ instance Val ZGoOrder where
     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)
+    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
@@ -159,7 +167,7 @@ instance Val LineItem where
 -- Database actions
 upsertOrder :: ZGoOrder -> Action IO ()
 upsertOrder o = do
-  let order = val o
+  let order = val $ updateOrderTotals o
   case order of
     Doc d ->
       if isJust (q_id o)
@@ -167,6 +175,29 @@ upsertOrder o = do
         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 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")
 

src/ZGoBackend.hs

@@ -255,7 +255,7 @@ sendPin ::
   -> T.Text
   -> Action IO String
 sendPin nodeUser nodePwd nodeAddress addr pin = do
-  let payload =
+  let pd =
         [ Data.Aeson.String nodeAddress
         , Data.Aeson.Array
             (V.fromList
@@ -266,7 +266,7 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do
                    ]
                ])
         ]
-  r <- makeZcashCall nodeUser nodePwd "z_sendmany" payload
+  r <- makeZcashCall nodeUser nodePwd "z_sendmany" pd
   let sCode = getResponseStatus (r :: Response Object)
   if sCode == ok200
     then return "Pin sent!"
@@ -344,7 +344,7 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do
       simpleCorsResourcePolicy
         { corsRequestHeaders = ["Authorization", "Content-Type"]
         , corsMethods = "DELETE" : simpleMethods
-        , corsOrigins = Nothing
+        --, corsOrigins = Nothing
         }
   middleware $
     basicAuth
@@ -395,29 +395,16 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do
     --Delete user
   Web.Scotty.delete "/api/user/:id" $ do
     userId <- param "id"
+    let r = mkRegex "^[a-f0-9]{24}$"
+    if matchTest r userId
+      then do
         liftIO $ run (deleteUser userId)
         status ok200
-    --Get txs from DB that have less than 10 confirmations
+      else status unprocessableEntity422
-    {-get "/api/pending" $ do-}
-      {-sess <- param "session"-}
-      {-pending <- liftIO $ run (findPending sess)-}
-      {-case pending of-}
-        {-[] -> do-}
-          {-status noContent204-}
-        {-_ -> do-}
-          {-Web.Scotty.json-}
-            {-(object-}
-               {-[ "message" .= ("Found pending transactions" :: String)-}
-               {-, "txs" .= toJSON (map parseZGoTxBson pending)-}
-               {-])-}
   --Get current blockheight from Zcash node
   get "/api/blockheight" $ do
     blockInfo <- makeZcashCall nodeUser nodePwd "getblock" ["-1"]
     Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block))
-    --Get transactions associated with ZGo node
-    --get "/api/txs" $ do
-      --txs <- makeZcashCall "z_listreceivedbyaddress" [nodeAddress]
-      --Web.Scotty.json (result (getResponseBody txs :: RpcResponse [ZcashTx]))
   --Get the ZGo node's shielded address
   get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
   --Get owner by address
@@ -464,8 +451,12 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do
     --Delete item
   Web.Scotty.delete "/api/item/:id" $ do
     oId <- param "id"
+    let r = mkRegex "^[a-f0-9]{24}$"
+    if matchTest r oId
+      then do
         liftIO $ run (deleteItem oId)
         status ok200
+      else status unprocessableEntity422
     --Get price for Zcash
   get "/api/price" $ do
     curr <- param "currency"
@@ -473,7 +464,6 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do
     case pr of
       Nothing -> do
         status noContent204
-          --Web.Scotty.json (object ["message" .= ("No price" :: T.Text)])
       Just p -> do
         Web.Scotty.json
           (object
@@ -497,6 +487,9 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do
     --Get order by id for receipts
   get "/api/order/:id" $ do
     oId <- param "id"
+    let r = mkRegex "^[a-f0-9]{24}$"
+    if matchTest r oId
+      then do
         myOrder <- liftIO $ run (findOrderById oId)
         case myOrder of
           Nothing -> status noContent204
@@ -511,6 +504,7 @@ routes pipe db passkey nodeAddress nodeUser nodePwd = do
                      [ "message" .= ("Order found!" :: String)
                      , "order" .= toJSON (pOrder :: ZGoOrder)
                      ])
+      else status unprocessableEntity422
     --Get order by session
   get "/api/order" $ do
     sess <- param "session"

test/Spec.hs

@@ -8,6 +8,7 @@ import Control.Monad.IO.Class
 import qualified Data.Aeson as A
 import qualified Data.ByteString as B
 import Data.Char (isAscii)
+import Data.Configurator
 import Data.Either
 import Data.Maybe
 import Data.SecureMem
@@ -15,6 +16,7 @@ import qualified Data.Text as T
 import Data.Time
 import Data.Time.Calendar
 import Data.Time.Clock
+import Data.Time.Clock.POSIX
 import Database.MongoDB
 import Item
 import Network.HTTP.Simple
@@ -30,24 +32,19 @@ import Test.QuickCheck
 import Test.QuickCheck.Gen
 import Test.QuickCheck.Monadic
 import User
+import Web.Scotty
 import ZGoBackend
 import ZGoTx
 
-passkey :: SecureMem
-passkey = secureMemFromByteString "superSecret"
-
-nodeAddress :: T.Text
-nodeAddress =
-  "zs1xnpqd2tae9d95f8fhe4l0q7j44a5vf993m0pcnnvr56uqr4lgqlamesk5v4c5rhtvywc6lvlduy"
-
-dbUser :: T.Text
-dbUser = "zgo"
-
-dbPassword :: T.Text
-dbPassword = "zcashrules"
-
 main :: IO ()
-main =
+main = do
+  putStrLn "Reading config..."
+  config <- load ["zgo.cfg"]
+  let dbName = "test"
+  nodeAddress <- require config "nodeAddress"
+  nodeUser <- require config "nodeUser"
+  nodePwd <- require config "nodePassword"
+  passkey <- secureMemFromByteString <$> require config "passkey"
   hspec $ do
     describe "Helper functions" $ do
       describe "decodeHexText" $ do
@@ -84,7 +81,7 @@ main =
         it "should give a 7 digit" $ do
           length (T.unpack (unsafePerformIO generatePin)) `shouldBe` 7
     describe "API endpoints" $ do
-      beforeAll_ startAPI $ do
+      beforeAll_ (startAPI dbName passkey nodeAddress nodeUser nodePwd) $ do
         describe "Price endpoint" $ do
           it "returns a price for an existing currency" $ do
             req <- testGet "/api/price" [("currency", Just "usd")]
@@ -158,6 +155,10 @@ main =
             req <- testGet "/api/order/627ab3ea2b05a76be3000000" []
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+          it "get order with wrong id" $ do
+            req <- testGet "/api/order/6273hrb" []
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` unprocessableEntity422
           it "get all orders for owner" $ do
             req <- testGet "/api/allorders" [("address", Just "Zaddy")]
             res <- httpJSON req
@@ -239,16 +240,22 @@ main =
             isNothing q `shouldBe` True
         describe "Zcash transactions" $ do
           it "logins are added to db" $ \p -> do
-            _ <- access p master "test" (delete (select [] "txs"))
+            _ <-
-            _ <- scanZcash nodeAddress p "test"
+              access p master "test" (Database.MongoDB.delete (select [] "txs"))
+            _ <- scanZcash nodeAddress p "test" nodeUser nodePwd
             threadDelay 1000000
             t <- access p master "test" $ findOne (select [] "txs")
             let s = parseZGoTxBson =<< t
             let conf = maybe 0 confirmations s
             conf `shouldSatisfy` (> 0)
           it "payments are added to db" $ \p -> do
-            _ <- access p master "test" (delete (select [] "payments"))
+            _ <-
-            _ <- scanZcash nodeAddress p "test"
+              access
+                p
+                master
+                "test"
+                (Database.MongoDB.delete (select [] "payments"))
+            _ <- scanZcash nodeAddress p "test" nodeUser nodePwd
             threadDelay 1000000
             t <- access p master "test" $ findOne (select [] "payments")
             let s = (cast' . Doc) =<< t
@@ -277,6 +284,7 @@ main =
                    , "pin" =: upin myUser
                    , "validated" =: uvalidated myUser
                    ])
+            tstamp <- getCurrentTime
             let myPay =
                   Payment
                     Nothing
@@ -284,7 +292,7 @@ main =
                     False
                     ""
                     "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcb"
-                    1652811930
+                    ((round . utcTimeToPOSIXSeconds) tstamp)
                     0.005
                     "myrandom123tx464id"
                     "coolest memo ever!"
@@ -331,9 +339,14 @@ main =
                     0.00000001
                     "abcdef"
                     "Super Memo"
-            _ <- access p master "test" (delete (select [] "users"))
+            _ <-
+              access
+                p
+                master
+                "test"
+                (Database.MongoDB.delete (select [] "users"))
             _ <- access p master "test" (insert_ "txs" (encodeZGoTxBson myTx))
-            _ <- updateLogins nodeAddress p "test"
+            _ <- updateLogins nodeUser nodePwd nodeAddress p "test"
             threadDelay 1000000
             t <- access p master "test" $ findOne (select [] "users")
             case t of
@@ -399,14 +412,15 @@ testOwnerAdd o =
 testOrderAdd :: ZGoOrder -> Property
 testOrderAdd o =
   monadicIO $ do
-    req <- run $ testPostJson "/api/order" (A.toJSON o)
+    req <-
+      run $ testPostJson "/api/order" (A.object ["payload" A..= A.toJSON o])
     res <- httpLBS req
     assert $ getResponseStatus res == created201
 
 testItemAdd :: Item -> Property
 testItemAdd i = do
   monadicIO $ do
-    req <- run $ testPostJson "/api/item" (A.toJSON i)
+    req <- run $ testPostJson "/api/item" (A.object ["payload" A..= A.toJSON i])
     res <- httpLBS req
     assert $ getResponseStatus res == created201
 
@@ -425,12 +439,14 @@ closeDbConnection = close
 handleDb :: (Pipe -> Expectation) -> IO ()
 handleDb = bracket openDbConnection closeDbConnection
 
-startAPI :: IO ()
+startAPI ::
-startAPI = do
+     T.Text -> SecureMem -> T.Text -> B.ByteString -> B.ByteString -> IO ()
+startAPI db passkey nodeAddress nodeUser nodePwd = do
   putStrLn "Starting test server ..."
   pipe <- connect $ host "127.0.0.1"
   c <- access pipe master "zgo" (auth "zgo" "zcashrules")
-  _ <- forkIO (app pipe "test" passkey nodeAddress)
+  let appRoutes = routes pipe db passkey nodeAddress nodeUser nodePwd
+  _ <- forkIO (scotty 3000 appRoutes)
   let myUser =
         User
           (Just (read "6272a90f2b05a74cf1000001" :: ObjectId))
@@ -477,11 +493,11 @@ startAPI = do
           False
           False
           (UTCTime (fromGregorian 2022 4 16) (secondsToDiffTime 0))
-  _ <- access pipe master "test" (delete (select [] "owners"))
+  _ <- access pipe master "test" (Database.MongoDB.delete (select [] "owners"))
   let o = val myOwner
   case o of
     Doc d -> access pipe master "test" (insert_ "owners" d)
-  _ <- access pipe master "test" (delete (select [] "orders"))
+  _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders"))
   myTs <- liftIO getCurrentTime
   let myOrder =
         ZGoOrder
@@ -495,6 +511,7 @@ startAPI = do
           0
           0
           []
+          False
   let ordTest = val myOrder
   case ordTest of
     Doc oT -> access pipe master "test" (insert_ "orders" oT)
@@ -523,14 +540,14 @@ instance Arbitrary ZGoOrder where
     p <- arbitrary
     t <- arbitrary
     tZ <- arbitrary
-    ZGoOrder i a s ts c cur p t tZ <$> arbitrary
+    l <- arbitrary
+    ZGoOrder i a s ts c cur p t tZ l <$> arbitrary
 
 instance Arbitrary LineItem where
   arbitrary = do
     i <- arbitrary
     q <- arbitrary
-    n <- arbitrary
+    LineItem i q <$> arbitrary
-    LineItem i q n <$> arbitrary
 
 instance Arbitrary ObjectId where
   arbitrary = do

zgo-backend.cabal

@@ -100,12 +100,14 @@ test-suite zgo-backend-test
     , aeson
     , base >=4.7 && <5
     , bytestring
+    , configurator
     , hspec
     , hspec-expectations-json
     , hspec-wai
     , http-conduit
     , http-types
     , mongoDB
+    , scotty
     , securemem
     , text
     , time