Refactor Payment type

app/Main.hs

@@ -26,7 +26,8 @@ main = do
   putStrLn "Starting Server..."
   pipe <- connect $ host "127.0.0.1"
   j <- access pipe master "zgo" (auth dbUser dbPassword)
-  {-_ <- forkIO (setInterval 60 (checkZcashPrices pipe))-}
+  _ <- forkIO (setInterval 60 (checkZcashPrices pipe "zgo"))
+  _ <- forkIO (setInterval 75 (scanZcash nodeAddress pipe "zgo"))
   if j
     then putStrLn "Connected to MongoDB!"
     else fail "MongoDB connection failed!"

package.yaml

@@ -45,6 +45,7 @@ library:
   - array
   - random
   - vector
+  - wai-cors
 
 executables:
   zgo-backend-exe:

src/Owner.hs

@@ -7,6 +7,7 @@ module Owner where
 import Data.Aeson
 import qualified Data.Bson as B
 import qualified Data.Text as T
+import Data.Time.Clock
 import Data.Typeable
 import Database.MongoDB
 import GHC.Generics
@@ -35,11 +36,12 @@ data Owner =
     , opaid :: Bool
     , ozats :: Bool
     , oinvoices :: Bool
+    , oexpiration :: UTCTime
     }
   deriving (Eq, Show, Generic, Typeable)
 
 instance ToJSON Owner where
-  toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv) =
+  toJSON (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv eTs) =
     case i of
       Just oid ->
         object
@@ -64,6 +66,7 @@ instance ToJSON Owner where
           , "paid" .= paid
           , "zats" .= zats
           , "invoices" .= inv
+          , "expiration" .= eTs
           ]
       Nothing ->
         object
@@ -88,6 +91,7 @@ instance ToJSON Owner where
           , "paid" .= paid
           , "zats" .= zats
           , "invoices" .= inv
+          , "expiration" .= eTs
           ]
 
 instance FromJSON Owner where
@@ -114,6 +118,7 @@ instance FromJSON Owner where
       paid <- obj .: "paid"
       zats <- obj .: "zats"
       inv <- obj .: "invoices"
+      ets <- obj .: "expiration"
       pure $
         Owner
           (if not (null i)
@@ -139,6 +144,7 @@ instance FromJSON Owner where
           paid
           zats
           inv
+          ets
 
 instance Val Owner where
   cast' (Doc d) = do
@@ -163,9 +169,10 @@ instance Val Owner where
     paid <- B.lookup "paid" d
     zats <- B.lookup "zats" d
     inv <- B.lookup "invoices" d
-    Just (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv)
+    ets <- B.lookup "expiration" d
+    Just (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets)
   cast' _ = Nothing
-  val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv) =
+  val (Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv ets) =
     case i of
       Just oid ->
         Doc
@@ -190,6 +197,7 @@ instance Val Owner where
           , "paid" =: paid
           , "zats" =: zats
           , "invoices" =: inv
+          , "expiration" =: ets
           ]
       Nothing ->
         Doc
@@ -213,6 +221,7 @@ instance Val Owner where
           , "paid" =: paid
           , "zats" =: zats
           , "invoices" =: inv
+          , "expiration" =: ets
           ]
 
 -- Database actions

src/Payment.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Payment where
+
+import Data.Aeson
+import qualified Data.Bson as B
+import qualified Data.Text as T
+import Data.Time.Clock
+import Data.Typeable
+import Database.MongoDB
+import GHC.Generics
+import ZGoTx
+
+data Payment =
+  Payment
+    { p_id :: Maybe ObjectId
+    , pdelta :: Integer
+    , pdone :: Bool
+    , paddress :: T.Text
+    , psession :: T.Text
+    , pblocktime :: Integer
+    , pamount :: Double
+    , ptxid :: T.Text
+    , pmemo :: T.Text
+    }
+  deriving (Eq, Show, Generic)
+
+instance Val Payment where
+  cast' (Doc d) = do
+    i <- B.lookup "_id" d
+    delta <- B.lookup "delta" d
+    done <- B.lookup "done" d
+    a <- B.lookup "address" d
+    s <- B.lookup "session" d
+    bt <- B.lookup "blocktime" d
+    amt <- B.lookup "amount" d
+    t <- B.lookup "txid" d
+    m <- B.lookup "memo" d
+    Just (Payment i delta done a s bt amt t m)
+  cast' _ = Nothing
+  val (Payment i delta done a s bt amt t m) =
+    case i of
+      Just oid ->
+        Doc
+          [ "_id" =: oid
+          , "delta" =: delta
+          , "done" =: done
+          , "address" =: a
+          , "session" =: s
+          , "blocktime" =: bt
+          , "amount" =: amt
+          , "txid" =: t
+          , "memo" =: m
+          ]
+      Nothing ->
+        Doc
+          [ "delta" =: delta
+          , "done" =: done
+          , "address" =: a
+          , "session" =: s
+          , "blocktime" =: bt
+          , "amount" =: amt
+          , "txid" =: t
+          , "memo" =: m
+          ]
+
+upsertPayment :: ZGoTx -> Action IO ()
+upsertPayment p = do
+  let delta = sessionCalc $ amount p
+  let payTx =
+        Payment
+          Nothing
+          delta
+          False
+          (address p)
+          (session p)
+          (blocktime p)
+          (amount p)
+          (txid p)
+          (memo p)
+  let payment = val payTx
+  case payment of
+    Doc d -> upsert (select ["tx" =: payTx] "payments") d
+    _ -> return ()
+
+sessionCalc :: Double -> Integer
+sessionCalc zec
+  | zec >= hiPay = 2419200 -- 1 month in seconds
+  | zec >= medPay = 604800 -- 1 week in seconds
+  | zec >= lowPay = 86400 -- 1 day in seconds
+  | otherwise = 0
+  where
+    (lowPay, medPay, hiPay) = (0.005, 0.025, 0.1)

src/ZGoBackend.hs

@@ -19,6 +19,7 @@ import Data.SecureMem
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as L
 import Data.Time.Clock
+import Data.Time.Clock.POSIX
 import Data.Typeable
 import qualified Data.Vector as V
 import Data.Word
@@ -28,10 +29,12 @@ import GHC.Generics
 import Item
 import Network.HTTP.Simple
 import Network.HTTP.Types.Status
+import Network.Wai.Middleware.Cors
 import Network.Wai.Middleware.HttpAuth
 import Numeric
 import Order
 import Owner
+import Payment
 import System.IO.Unsafe
 import System.Random
 import Test.QuickCheck
@@ -71,6 +74,16 @@ instance (FromJSON r) => FromJSON (RpcResponse r) where
     MakeRpcResponse <$> obj .: "error" <*> obj .: "id" <*> obj .: "result"
   parseJSON _ = mzero
 
+data Payload r =
+  Payload
+    { payload :: r
+    }
+  deriving (Show, Generic, ToJSON)
+
+instance (FromJSON r) => FromJSON (Payload r) where
+  parseJSON (Object obj) = Payload <$> obj .: "payload"
+  parseJSON _ = mzero
+
 -- | Type to model a (simplified) block of Zcash blockchain
 data Block =
   Block
@@ -192,13 +205,13 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
     then do
       let sess = T.pack (fst $ head reg ! 1)
       let addy = T.pack (fst $ head reg ! 2)
-      ZGoTx "" addy sess conf bt a t m
+      ZGoTx Nothing addy sess conf bt a t m
     else do
       if not (null reg2)
         then do
           let sess = T.pack (fst $ head reg2 ! 1)
-          ZGoTx "" "" sess conf bt a t m
+          ZGoTx Nothing "" sess conf bt a t m
-        else ZGoTx "" "" "" conf bt a t m
+        else ZGoTx Nothing "" "" conf bt a t m
 
 -- |Type to model a price in the ZGo database
 data ZGoPrice =
@@ -304,7 +317,16 @@ upsertZGoTx coll t = do
 app :: Pipe -> T.Text -> SecureMem -> T.Text -> IO ()
 app pipe db passkey nodeAddress = do
   let run = access pipe master db
-  scotty 4000 $ do
+  scotty 3000 $ do
+    middleware $
+      cors $
+      const $
+      Just
+        simpleCorsResourcePolicy
+          { corsRequestHeaders = ["Authorization", "Content-Type"]
+          , corsMethods = "DELETE" : simpleMethods
+          , corsOrigins = Nothing
+          }
     middleware $
       basicAuth
         (\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
@@ -359,18 +381,18 @@ app pipe db passkey nodeAddress = do
       liftIO $ run (deleteUser userId)
       status ok200
     --Get txs from DB that have less than 10 confirmations
-    get "/api/pending" $ do
+    {-get "/api/pending" $ do-}
-      sess <- param "session"
+      {-sess <- param "session"-}
-      pending <- liftIO $ run (findPending sess)
+      {-pending <- liftIO $ run (findPending sess)-}
-      case pending of
+      {-case pending of-}
-        [] -> do
+        {-[] -> do-}
-          status noContent204
+          {-status noContent204-}
-        _ -> do
+        {-_ -> do-}
-          Web.Scotty.json
+          {-Web.Scotty.json-}
-            (object
+            {-(object-}
-               [ "message" .= ("Found pending transactions" :: String)
+               {-[ "message" .= ("Found pending transactions" :: String)-}
-               , "txs" .= toJSON (map parseZGoTxBson pending)
+               {-, "txs" .= toJSON (map parseZGoTxBson pending)-}
-               ])
+               {-])-}
     --Get current blockheight from Zcash node
     get "/api/blockheight" $ do
       blockInfo <- makeZcashCall "getblock" ["-1"]
@@ -401,7 +423,8 @@ app pipe db passkey nodeAddress = do
     --Upsert owner to DB
     post "/api/owner" $ do
       o <- jsonData
-      _ <- liftIO $ run (upsertOwner o)
+      let q = payload (o :: Payload Owner)
+      _ <- liftIO $ run (upsertOwner q)
       status created201
     --Get items associated with the given address
     get "/api/items" $ do
@@ -554,7 +577,7 @@ scanZcash addr pipe db = do
   let k = map zToZGoTx (filter (matchTest r . T.unpack . zmemo) txs)
   mapM_ (access pipe master db . upsertZGoTx "txs") k
   let j = map zToZGoTx (filter (matchTest p . T.unpack . zmemo) txs)
-  mapM_ (access pipe master db . upsertZGoTx "payments") j
+  mapM_ (access pipe master db . upsertPayment) j
 
 -- | Function to generate users from login txs
 updateLogins :: T.Text -> Pipe -> T.Text -> IO ()
@@ -566,8 +589,60 @@ updateLogins addr pipe db = do
       db
       (rest =<<
        find (select ["confirmations" =: ["$lt" =: (100 :: Integer)]] "txs"))
-  let parsed = map parseZGoTxBson results
+  let parsed = map (cast' . Doc) results
   mapM_ (access pipe master db . ZGoBackend.addUser pipe db addr) parsed
   putStrLn "Updated logins!"
 
+-- | Function to mark owners as paid
+checkPayments :: Pipe -> T.Text -> IO ()
+checkPayments pipe db = do
+  qPayments <-
+    access pipe master db (rest =<< find (select ["done" =: False] "payments"))
+  let parsedPayments = map (cast' . Doc) qPayments
+  mapM_ (payOwner pipe db) parsedPayments
+
+payOwner :: Pipe -> T.Text -> Maybe Payment -> IO ()
+payOwner p d x =
+  case x of
+    Nothing -> return ()
+    Just k -> do
+      now <- getCurrentTime
+      if posixSecondsToUTCTime (fromInteger (pblocktime k + pdelta k)) <= now
+        then markPaymentDone p d k
+        else markOwnerPaid p d k
+      where markPaymentDone :: Pipe -> T.Text -> Payment -> IO ()
+            markPaymentDone pipe db pmt = do
+              _ <-
+                access
+                  pipe
+                  master
+                  db
+                  (modify
+                     (select ["_id" =: p_id pmt] "payments")
+                     ["$set" =: ["done" =: True]])
+              return ()
+            markOwnerPaid :: Pipe -> T.Text -> Payment -> IO ()
+            markOwnerPaid pipe db pmt = do
+              user <- access pipe master db (findUser $ psession pmt)
+              let parsedUser = parseUserBson =<< user
+              let zaddy = maybe "" uaddress parsedUser
+              owner <- access pipe master db $ findOwner zaddy
+              let parsedOwner = (cast' . Doc) =<< owner
+              let ownerId = o_id =<< parsedOwner
+              _ <-
+                access
+                  pipe
+                  master
+                  db
+                  (modify
+                     (select ["_id" =: ownerId] "owners")
+                     [ "$set" =:
+                       [ "paid" =: True
+                       , "expiration" =:
+                         posixSecondsToUTCTime
+                           (fromInteger (pblocktime pmt + pdelta pmt))
+                       ]
+                     ])
+              markPaymentDone pipe db pmt
+
 debug = flip trace

src/ZGoTx.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 module ZGoTx where
@@ -14,7 +13,7 @@ import GHC.Generics
 -- | Type to model a ZGo transaction
 data ZGoTx =
   ZGoTx
-    { _id :: String
+    { _id :: Maybe ObjectId
     , address :: T.Text
     , session :: T.Text
     , confirmations :: Integer
@@ -23,7 +22,7 @@ data ZGoTx =
     , txid :: T.Text
     , memo :: T.Text
     }
-  deriving (Eq, Show, Generic, ToJSON)
+  deriving (Eq, Show, Generic)
 
 parseZGoTxBson :: B.Document -> Maybe ZGoTx
 parseZGoTxBson d = do
@@ -35,12 +34,12 @@ parseZGoTxBson d = do
   t <- B.lookup "txid" d
   m <- B.lookup "memo" d
   bt <- B.lookup "blocktime" d
-  pure $ ZGoTx (show (i :: B.ObjectId)) a s c bt am t m
+  pure $ ZGoTx i a s c bt am t m
 
 encodeZGoTxBson :: ZGoTx -> B.Document
 encodeZGoTxBson (ZGoTx i a s c bt am t m) =
   if not (null i)
-    then [ "_id" =: (read i :: B.ObjectId)
+    then [ "_id" =: i
          , "address" =: a
          , "session" =: s
          , "confirmations" =: c
@@ -57,3 +56,39 @@ encodeZGoTxBson (ZGoTx i a s c bt am t m) =
          , "txid" =: t
          , "memo" =: m
          ]
+
+instance Val ZGoTx where
+  cast' (Doc d) = do
+    i <- B.lookup "_id" d
+    a <- B.lookup "address" d
+    s <- B.lookup "session" d
+    c <- B.lookup "confirmations" d
+    am <- B.lookup "amount" d
+    t <- B.lookup "txid" d
+    m <- B.lookup "memo" d
+    bt <- B.lookup "blocktime" d
+    Just (ZGoTx i a s c bt am t m)
+  cast' _ = Nothing
+  val (ZGoTx i a s c bt am t m) =
+    case i of
+      Just oid ->
+        Doc
+          [ "_id" =: i
+          , "address" =: a
+          , "session" =: s
+          , "confirmations" =: c
+          , "blocktime" =: bt
+          , "amount" =: am
+          , "txid" =: t
+          , "memo" =: m
+          ]
+      Nothing ->
+        Doc
+          [ "address" =: a
+          , "session" =: s
+          , "confirmations" =: c
+          , "blocktime" =: bt
+          , "amount" =: am
+          , "txid" =: t
+          , "memo" =: m
+          ]

test/Spec.hs

@@ -12,12 +12,16 @@ import Data.Either
 import Data.Maybe
 import Data.SecureMem
 import qualified Data.Text as T
+import Data.Time
+import Data.Time.Calendar
 import Data.Time.Clock
 import Database.MongoDB
+import Item
 import Network.HTTP.Simple
 import Network.HTTP.Types.Status
 import Order
 import Owner
+import Payment
 import System.IO.Unsafe
 import Test.Hspec
 import Test.Hspec.Expectations.Json
@@ -68,7 +72,7 @@ main =
                   "ZGO::5d3d4494-51c0-432d-8495-050419957aea\nReply-To:\nzs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
           zToZGoTx t `shouldBe`
             ZGoTx
-              ""
+              Nothing
               "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
               "5d3d4494-51c0-432d-8495-050419957aea"
               20
@@ -165,9 +169,15 @@ main =
             res <- httpLBS req
             getResponseStatus res `shouldBe` ok200
         describe "Item endpoint" $ do
-          it "add item" $ do pending
+          prop "add item" testItemAdd
-          it "get item" $ do pending
+          it "get items" $ do
-          it "delete item" $ do pending
+            req <- testGet "/api/items" [("address", Just "Zaddy")]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+          it "delete item" $ do
+            req <- testDelete "/api/item/" "627d7ba92b05a76be3000003"
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` ok200
     around handleDb $
       describe "Database actions" $ do
         describe "authentication" $ do
@@ -252,17 +262,13 @@ main =
             _ <- scanZcash nodeAddress p "test"
             threadDelay 1000000
             t <- access p master "test" $ findOne (select [] "payments")
-            case t of
+            let s = (cast' . Doc) =<< t
-              Nothing -> True `shouldBe` False
+            let payDelta = maybe 0 pdelta s
-              Just r -> do
+            payDelta `shouldSatisfy` (> 0)
-                let s = parseZGoTxBson r
-                case s of
-                  Nothing -> True `shouldBe` False
-                  Just z -> confirmations z `shouldSatisfy` (> 0)
           xit "login txs are converted to users" $ \p -> do
             let myTx =
                   ZGoTx
-                    ""
+                    Nothing
                     "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
                     "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca"
                     3
@@ -289,7 +295,7 @@ testGet endpoint body = do
   let pwd = "superSecret"
   let testRequest =
         setRequestQueryString body $
-        setRequestPort 4000 $
+        setRequestPort 3000 $
         setRequestBasicAuth user pwd $
         setRequestMethod "GET" $ setRequestPath endpoint defaultRequest
   return testRequest
@@ -300,7 +306,7 @@ testPost endpoint body = do
   let pwd = "superSecret"
   let testRequest =
         setRequestQueryString body $
-        setRequestPort 4000 $
+        setRequestPort 3000 $
         setRequestBasicAuth user pwd $
         setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
   return testRequest
@@ -311,7 +317,7 @@ testPostJson endpoint body = do
   let pwd = "superSecret"
   let testRequest =
         setRequestBodyJSON body $
-        setRequestPort 4000 $
+        setRequestPort 3000 $
         setRequestBasicAuth user pwd $
         setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
   return testRequest
@@ -321,7 +327,7 @@ testDelete endpoint par = do
   let user = "user"
   let pwd = "superSecret"
   let testRequest =
-        setRequestPort 4000 $
+        setRequestPort 3000 $
         setRequestBasicAuth user pwd $
         setRequestMethod "DELETE" $
         setRequestPath (B.append endpoint par) defaultRequest
@@ -330,7 +336,8 @@ testDelete endpoint par = do
 testOwnerAdd :: Owner -> Property
 testOwnerAdd o =
   monadicIO $ do
-    req <- run $ testPostJson "/api/owner" (A.toJSON o) --`debug` show o
+    req <-
+      run $ testPostJson "/api/owner" (A.object ["payload" A..= A.toJSON o]) --`debug` show o
     res <- httpLBS req
     assert $ getResponseStatus res == created201
 
@@ -341,6 +348,13 @@ testOrderAdd o =
     res <- httpLBS req
     assert $ getResponseStatus res == created201
 
+testItemAdd :: Item -> Property
+testItemAdd i = do
+  monadicIO $ do
+    req <- run $ testPostJson "/api/item" (A.toJSON i)
+    res <- httpLBS req
+    assert $ getResponseStatus res == created201
+
 -- | Open the MongoDB connection
 openDbConnection :: IO Pipe
 openDbConnection = do
@@ -384,6 +398,7 @@ startAPI = do
          , "pin" =: upin myUser
          , "validated" =: uvalidated myUser
          ])
+  myTstamp <- getCurrentTime
   let myOwner =
         Owner
           (Just (read "627ad3492b05a76be3000001"))
@@ -407,6 +422,7 @@ startAPI = do
           False
           False
           False
+          (UTCTime (fromGregorian 2022 5 16) (secondsToDiffTime 0))
   _ <- access pipe master "test" (delete (select [] "owners"))
   let o = val myOwner
   case o of
@@ -428,6 +444,16 @@ startAPI = do
   let ordTest = val myOrder
   case ordTest of
     Doc oT -> access pipe master "test" (insert_ "orders" oT)
+  let myItem1 =
+        Item
+          (Just (read "627d7ba92b05a76be3000003"))
+          "Chair"
+          "Made of wood"
+          "Zaddy"
+          101.99
+  let itemTest = val myItem1
+  case itemTest of
+    Doc iT -> access pipe master "test" (insert_ "items" iT)
   threadDelay 1000000
   putStrLn "Test server is up!"
 
@@ -479,4 +505,14 @@ instance Arbitrary Owner where
     co <- arbitrary
     paid <- arbitrary
     zats <- arbitrary
-    Owner i a n c t tV v vV f l e s ct st p ph w co paid zats <$> arbitrary
+    inv <- arbitrary
+    exp <- arbitrary
+    pure $ Owner i a n c t tV v vV f l e s ct st p ph w co paid zats inv exp
+
+instance Arbitrary Item where
+  arbitrary = do
+    i <- arbitrary
+    n <- arbitrary
+    d <- arbitrary
+    o <- arbitrary
+    Item i n d o <$> arbitrary

zgo-backend.cabal

@@ -28,6 +28,7 @@ library
       Item
       Order
       Owner
+      Payment
       User
       ZGoBackend
       ZGoTx
@@ -55,6 +56,7 @@ library
     , time
     , unordered-containers
     , vector
+    , wai-cors
     , wai-extra
   default-language: Haskell2010